ExcelVBA ～ クリップボードに送受信するためのAPI（64bit、32bit、兼用）
Excelの「DataObject（Microsoft Forms 2.0 Object Library）」を使う方法が、
なぜかダメだった（短い文字列は行けたのですが）、APIのほうが確実なのでこちらでやりました。
|
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 |
' ' Option Explicit #If VBA7 And Win64 Then Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" (ByVal hWnd As LongPtr) As Long Private Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As Long Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As Long Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long Private Declare PtrSafe Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As LongPtr Private Declare PtrSafe Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As LongPtr) As Long Private Declare PtrSafe Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As LongLong) As LongPtr Private Declare PtrSafe Function GlobalLock Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongPtr Private Declare PtrSafe Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As LongPtr) As Long Private Declare PtrSafe Function GlobalSize Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongLong Private Declare PtrSafe Sub MoveMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As LongLong) #Else Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long Private Declare Function EmptyClipboard Lib "user32.dll" () As Long Private Declare Function CloseClipboard Lib "user32.dll" () As Long Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long Private Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long Private Declare Function GlobalSize Lib "kernel32.dll" (ByVal hMem As Long) As Long Private Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long Private Declare Sub MoveMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long) #End If Public Sub SetClipboard(sUniText As String) #If VBA7 And Win64 Then Dim iStrPtr As LongPtr Dim iLen As LongLong Dim iLock As LongPtr #Else Dim iStrPtr As Long Dim iLen As Long Dim iLock As Long #End If Const GMEM_MOVEABLE As Long = &H2 Const GMEM_ZEROINIT As Long = &H40 Const CF_UNICODETEXT As Long = &HD OpenClipboard 0& EmptyClipboard iLen = LenB(sUniText) iStrPtr = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, iLen + 2&) iLock = GlobalLock(iStrPtr) MoveMemory iLock, StrPtr(sUniText), iLen GlobalUnlock iStrPtr SetClipboardData CF_UNICODETEXT, iStrPtr CloseClipboard End Sub Public Function GetClipboard() As String #If VBA7 And Win64 Then Dim iStrPtr As LongPtr Dim iLen As LongLong Dim iLock As LongPtr #Else Dim iStrPtr As Long Dim iLen As Long Dim iLock As Long #End If Dim sUniText As String Const CF_UNICODETEXT As Long = 13& OpenClipboard 0& If IsClipboardFormatAvailable(CF_UNICODETEXT) Then iStrPtr = GetClipboardData(CF_UNICODETEXT) If iStrPtr Then iLock = GlobalLock(iStrPtr) iLen = GlobalSize(iStrPtr) sUniText = String$(CLng(iLen) \ 2& - 1&, vbNullChar) MoveMemory StrPtr(sUniText), iLock, LenB(sUniText) GlobalUnlock iStrPtr End If GetClipboard = sUniText End If CloseClipboard End Function ' ' |
