Share the Clipboard with VBA and the Windows API
Accessing the clipboard in Windows becomes quite tricky in VBA, particularly if you have to stay 32 and 64 bits compatible.
Here’s my compilation of portable routines, inspired by MSDN, Internet scraping and good sense.
First the Declares section (I know, it pours out of the frame on the right, just select and copy the text):
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 |
'Update 20.05.2017, those 3 declarations were missing: Const GMEM_ZEROINIT = &H40 Const GMEM_MOVEABLE = &H2 Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT) #If Win64 Then 'To copy text on the clipboard Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr) Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongLong) As Long Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongLong) As LongPtr Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongLong) As LongPtr Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongLong) As Long Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long Private Declare PtrSafe Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As Any, ByVal lpString2 As String) As LongPtr Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongLong) As LongLong Private Declare PtrSafe Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long #Else Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long) Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long Private Declare Function CloseClipboard Lib "user32" () As Long Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function EmptyClipboard Lib "user32" () As Long Private Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) 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 #End If Public Enum eCBFormat 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 CF_OWNERDISPLAY = &H80 CF_DSPTEXT = &H81 CF_DSPBITMAP = &H82 CF_DSPMETAFILEPICT = &H83 CF_DSPENHMETAFILE = &H8E CF_PRIVATEFIRST = &H200 CF_PRIVATELAST = &H2FF CF_GDIOBJFIRST = &H300 CF_GDIOBJLAST = &H3FF End Enum |
Then the VBA code:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 |
#If Win64 Then Public Function ClipBoard_HasFormat(ByVal phWnd As LongLong, _ ByVal peCBFormat As eCBFormat) As Boolean #Else Public Function ClipBoard_HasFormat(ByVal phWnd As Long, _ ByVal peCBFormat As eCBFormat) As Boolean #End If Dim lRet As Long If OpenClipboard(phWnd) > 0 Then lRet = EnumClipboardFormats(0) If lRet <> 0 Then Do If lRet = peCBFormat Then ClipBoard_HasFormat = True Exit Do End If lRet = EnumClipboardFormats(lRet) Loop While lRet <> 0 End If CloseClipboard Else 'Problem: Cannot open clipboard End If End Function #If Win64 Then Public Function ClipBoard_GetTextData(ByVal phWnd As LongLong) As String Dim hData As LongPtr Dim lByteLen As LongPtr Dim lPointer As LongPtr Dim lSize As LongLong #Else Public Function ClipBoard_GetTextData(ByVal phWnd As Long) As String Dim hData As Long Dim lByteLen As Long Dim lPointer As Long Dim lSize As Long #End If Dim lRet As Long Dim abData() As Byte Dim sText As String lRet = OpenClipboard(phWnd) If lRet > 0 Then hData = GetClipboardData(eCBFormat.CF_TEXT) If hData <> 0 Then lByteLen = GlobalSize(hData) lSize = GlobalSize(hData) lPointer = GlobalLock(hData) If lSize > 0 Then ReDim abData(0 To CLng(lSize) - CLng(1)) As Byte CopyMemory abData(0), ByVal lPointer, lSize GlobalUnlock hData sText = StrConv(abData, vbUnicode) End If Else 'Problem: Cannot open clipboard End If CloseClipboard End If ClipBoard_GetTextData = sText End Function Public Function ClipBoard_SetData(psData As String) As Boolean #If Win64 Then Dim hGlobalMemory As LongLong Dim lpGlobalMemory As LongPtr Dim hClipMemory As LongLong #Else Dim hGlobalMemory As Long Dim lpGlobalMemory As Long Dim hClipMemory As Long #End If Dim fOK As Boolean fOK = True ' Allocate moveable global memory. #If Win64 Then hGlobalMemory = GlobalAlloc(GHND, LenB(psData) + 1) #Else hGlobalMemory = GlobalAlloc(GHND, Len(psData) + 1) #End If If hGlobalMemory = 0 Then Exit Function End If ' Lock the block to get a far pointer ' to this memory. lpGlobalMemory = GlobalLock(hGlobalMemory) ' Copy the string to this global memory. lpGlobalMemory = lstrcpy(lpGlobalMemory, psData) ' Unlock the memory. If GlobalUnlock(hGlobalMemory) <> 0 Then fOK = False GoTo OutOfHere2 End If ' Open the Clipboard to copy data to. If OpenClipboard(0&) = 0 Then fOK = False Exit Function End If ' Clear the Clipboard. Call EmptyClipboard ' Copy the data to the Clipboard. hClipMemory = SetClipboardData(eCBFormat.CF_TEXT, hGlobalMemory) OutOfHere2: Call CloseClipboard ClipBoard_SetData = fOK End Function |
Update: just a quick sample (Access VBA):
|
1 2 3 4 5 |
If ClipBoard_HasFormat(Application.hWndAccessApp, eCBFormat.CF_TEXT) Then Dim sText As String sText = ClipBoard_GetTextData(Application.hWndAccessApp) '... End If |
There’s an Access 2016 demo database (on devinfo.net), open it, go to the VBA editor (ALT+F11), go to the debug Windows (CTRL+G), type “Test” (without the quotes of course) and hit ENTER; any text in the clipboard will be displayed in the debug window.
Enjoy.