CodeItBetter Programming Another VB Programming Blog

'Controls - How to Copy the contents of a Picture Box into Clipboard
Option Explicit
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Private Declare Function BitBlt Lib "gdi32" (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 Const SRCCOPY = &HCC0020
Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, _
    ByVal nHeight As Long) As Long
Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
 
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, _
    ByVal hMem As Long) As Long
Private Declare Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" _
    (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CountClipboardFormats Lib "user32" () As Long
Private Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" _
    (ByVal lpString As String) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
 
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, _
    lpvSource As Any, ByVal cbCopy As Long)
 
Public Enum EPredefinedClipboardFormatConstants
    [_First] = 1
    CF_TEXT = 1
    CF_BITMAP = 2
    CF_METAFILEPICT = 3
    CF_SYLK = 4
    CF_DIF = 5
    CF_TIFF = 6
    CF_OEMTEXT = 7
    CF_DIB = 8
    CF_PALETTE = 9
    CF_PENDATA = 10
    CF_RIFF = 11
    CF_WAVE = 12
    CF_UNICODETEXT = 13
    CF_ENHMETAFILE = 14
    CF_HDROP = 15
    CF_LOCALE = 16
    CF_MAX = 17
    [_Last] = 17
End Enum
 
Public Function CopyEntirePictureToClipboard(ByRef objFrom As Object) As Boolean
    Dim lhDC As Long
    Dim lhBmp As Long
    Dim lhBmpOld As Long
 
    lhDC = CreateCompatibleDC(objFrom.hdc)
    If (lhDC <> 0) Then
        lhBmp = CreateCompatibleBitmap(objFrom.hdc, objFrom.ScaleWidth \ Screen.TwipsPerPixelX, objFrom.ScaleHeight \ Screen.TwipsPerPixelY)
        If (lhBmp <> 0) Then
            lhBmpOld = SelectObject(lhDC, lhBmp)
 
            BitBlt lhDC, 0, 0, objFrom.ScaleWidth \ Screen.TwipsPerPixelX, objFrom.ScaleHeight \ Screen.TwipsPerPixelY, objFrom.hdc, 0, 0, SRCCOPY
 
            SelectObject lhDC, lhBmpOld
 
            EmptyClipboard
            OpenClipboard 0
            SetClipboardData CF_BITMAP, lhBmp
            CloseClipboard
        End If
        DeleteObject lhDC
        CopyEntirePictureToClipboard = True
    Else
        CopyEntirePictureToClipboard = False
    End If
End Function