Guardar controles como imagen.

[Jefe_Negro]

Esto funciona pero es un poco lioso. lo encontre con el google y comente unas cuantas lineas porque fallaba. los controles tienen que estar en un picture y se extraen a traves del portapapeles.

Código:

'*********** Code Start ***********
' This code was originally written by Dev Ashish.
' It is not to be altered or distributed,
' except as part of an application.
' You are free to use it in any application,
' provided the copyright notice is left unchanged.
'
' Code Courtesy of
' Dev Ashish
Private Type RECT
  Left As Long
  Right As Long
  Top As Long
  Bottom As Long
End Type

Private Type BITMAP
  bmType As Long
  bmWidth As Long
  bmHeight As Long
  bmWidthBytes As Long
  bmPlanes As Integer
  bmBitsPixel As Integer
  bmBits As Long
End Type

Private Declare Function apiGetDC Lib "user32" _
  Alias "GetDC" _
  (ByVal hwnd As Long) _
  As Long

Private Declare Function apiReleaseDC Lib "user32" _
  Alias "ReleaseDC" _
  (ByVal hwnd As Long, _
  ByVal hdc As Long) _
  As Long

Private Declare Function apiCreateCompatibleDC Lib "gdi32" _
  Alias "CreateCompatibleDC" _
  (ByVal hdc As Long) _
  As Long

Private Declare Function apiCreateCompatibleBitmap Lib "gdi32" _
  Alias "CreateCompatibleBitmap" _
  (ByVal hdc As Long, _
  ByVal nWidth As Long, _
  ByVal nHeight As Long) _
  As Long

Private Declare Function apiDeleteDC Lib "gdi32" _
  Alias "DeleteDC" _
  (ByVal hdc As Long) _
  As Long

Private Declare Function apiSelectObject Lib "gdi32" _
  Alias "SelectObject" _
  (ByVal hdc As Long, _
  ByVal hObject As Long) _
  As Long

Private Declare Function apiBitBlt Lib "gdi32" _
  Alias "BitBlt" _
  (ByVal hDestDC As Long, _
  ByVal x As Long, _
  ByVal y As Long, _
  ByVal nWidth As Long, _
  ByVal nHeight As Long, _
  ByVal hSrcDC As Long, _
  ByVal xSrc As Long, _
  ByVal ySrc As Long, _
  ByVal dwRop As Long) _
  As Long

Private Declare Function apiDeleteObject Lib "gdi32" _
  Alias "DeleteObject" _
  (ByVal hObject As Long) _
  As Long

Private Declare Function apiGetObjectBmp Lib "gdi32" _
  Alias "GetObjectA" _
  (ByVal hObject As Long, _
  ByVal nCount As Long, _
  lpObject As BITMAP) _
  As Long

Private Declare Function apiOpenClipboard Lib "user32" _
  Alias "OpenClipboard" _
  (ByVal hwnd As Long) _
  As Long

Private Declare Function apiEmptyClipboard Lib "user32" _
  Alias "EmptyClipboard" _
  () As Long

Private Declare Function apiSetClipboardData Lib "user32" _
  Alias "SetClipboardData" _
  (ByVal wFormat As Long, _
  ByVal hMem As Long) As Long

Private Declare Function apiCloseClipboard Lib "user32" _
  Alias "CloseClipboard" _
  () As Long

Private Declare Function apiGetDeviceCaps Lib "gdi32" _
  Alias "GetDeviceCaps" (ByVal hdc As Long, _
  ByVal nIndex As Long) As Long

Private Declare Function apiGetSysMetrics Lib "user32" _
  Alias "GetSystemMetrics" _
  (ByVal nIndex As Long) As Long

Private Const CF_BITMAP = 2
Private Const IMAGE_BITMAP& = 0
Private Const SRCCOPY = &HCC0020
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const SM_CYCAPTION = 4
Private Const SM_CXBORDER = 5
Private Const SM_CYBORDER = 6
Private Const SM_CXDLGFRAME = 7
Private Const SM_CYDLGFRAME = 8
Private Const SM_CXFRAME = 32
Private Const SM_CYFRAME = 33

Function fImageToClipboard(frm As Form, _
            imageCtl As Control) As Boolean
On Error GoTo ErrHandler
Dim hwnd As Long
Dim hdc As Long
Dim lngRet As Long
Dim hMemDC As Long
Dim hObject As Object
Dim blnBMPResize As Boolean
Dim lpRect As RECT
Dim lpObject As BITMAP
Dim hBitmap As Long
Dim intSizeMode As Integer
Dim blnRecordSelector As Boolean
Dim strPicture As String
Dim blnIsOLE As Boolean
Dim blnFileExists As Boolean

  blnIsOLE = False
  strPicture = imageCtl.Picture
  If blnIsOLE Then
    imageCtl.SetFocus
    DoCmd.RunCommand acCmdCopy
    Err.Raise vbObjectError + 65530
  End If

  blnRecordSelector = frm.RecordSelectors
  frm.RecordSelectors = False

  hwnd = frm.hwnd
  hdc = apiGetDC(hwnd)
  hMemDC = apiCreateCompatibleDC(hdc)
  With lpRect
    .Left = imageCtl.Left
    .Top = imageCtl.Top
    .Right = imageCtl.Width + imageCtl.Left
    .Bottom = imageCtl.Top + imageCtl.Height
  End With

  With lpRect
    If Not frm.BorderStyle Then _
        .Top = .Top + apiGetSysMetrics(SM_CYCAPTION)
    Select Case frm.BorderStyle
      Case 1 ' thin
        .Left = .Left + apiGetSysMetrics(SM_CXBORDER)
        .Top = .Top + apiGetSysMetrics(SM_CYBORDER)
      Case 2 ' sizeable
        .Left = .Left + apiGetSysMetrics(SM_CXFRAME)
        .Top = .Top + apiGetSysMetrics(SM_CYFRAME)
      Case 3 ' dialog
        .Left = .Left + apiGetSysMetrics(SM_CXDLGFRAME)
        .Top = .Top + apiGetSysMetrics(SM_CYDLGFRAME)
    End Select
    .Left = ConvertTwipsToPixels(.Left, 0)
    .Top = ConvertTwipsToPixels(.Top, 1)
    .Bottom = ConvertTwipsToPixels(.Bottom, 1)
    .Right = ConvertTwipsToPixels(.Right, 0)
  End With

  If blnFileExists Then
   With lpRect
      If .Right + .Left > lpObject.bmWidth Then
        hBitmap = apiCreateCompatibleBitmap(hdc, _
                        .Right - .Left, .Bottom - .Top)
      Else
        blnBMPResize = True
        intSizeMode = imageCtl.SizeMode
        imageCtl.SizeMode = acOLESizeStretch
        frm.Repaint
        With lpObject
          hBitmap = apiCreateCompatibleBitmap(hdc, .bmWidth, .bmHeight)
        End With
      End If
      lngRet = apiSelectObject(hMemDC, hBitmap)
      lngRet = apiBitBlt(hMemDC, 0&, 0&, .Right - .Left, _
                .Bottom - .Top, hdc, .Left, .Top, SRCCOPY)
    End With
  Else
    With lpRect
      hBitmap = apiCreateCompatibleBitmap(hdc, .Right - .Left, _
                                                .Bottom - .Top)
      blnBMPResize = True
      intSizeMode = imageCtl.SizeMode
      imageCtl.SizeMode = acOLESizeStretch
      frm.Repaint
      lngRet = apiSelectObject(hMemDC, hBitmap)
      lngRet = apiBitBlt(hMemDC, 0&, 0&, .Right - .Left, _
              .Bottom - .Top, hdc, .Left, .Top, SRCCOPY)
    End With
  End If
  Call apiOpenClipboard(hwnd)
  Call apiEmptyClipboard
  Call apiSetClipboardData(CF_BITMAP, hBitmap)

  fImageToClipboard = True
ExitHere:
  On Error Resume Next
  Call apiCloseClipboard
  If blnBMPResize Then _
    imageCtl.SizeMode = intSizeMode
  frm.RecordSelectors = blnRecordSelector
  Call apiDeleteObject(hObject)
  Call apiDeleteDC(hMemDC)
  Call apiReleaseDC(hwnd, hdc)
  Exit Function
ErrHandler:
  If Err.Number = 438 Then
    blnIsOLE = True
    Resume Next
  Else
    fImageToClipboard = False
    Resume ExitHere
    Resume
  End If
End Function

Private Function ConvertTwipsToPixels(lngTwips As Long, _
                                lngDirection As Long) _
                                As Long
    Dim lngDC As Long
    Dim lngPixelsPerInch As Long
    Const nTwipsPerInch = 1440
    Const SM_CXSCREEN = 0
    Const SM_CYSCREEN = 1
    lngDC = apiGetDC(SM_CXSCREEN)
    If (lngDirection = SM_CXSCREEN) Then
        lngPixelsPerInch = apiGetDeviceCaps(lngDC, LOGPIXELSX)
    Else
        lngPixelsPerInch = apiGetDeviceCaps(lngDC, LOGPIXELSY)
    End If
    lngDC = apiReleaseDC(SM_CXSCREEN, lngDC)
    ConvertTwipsToPixels = lngTwips / nTwipsPerInch * lngPixelsPerInch
End Function

Private Sub Command2_Click()

    fImageToClipboard Me, Picture1
    SavePicture Clipboard.GetData, "c:\prueba.bmp"
    
End Sub