VBA Win32API Win64/32 共用 Clipboard Class

コード

注意

現在のところテキストのみです

標準プロシージャ

Sub ClipBoardClassTest()
' 標準モジュール用のコードです
On Error GoTo Clip_Error
' Dim and New For ClipBoadClass
Dim clsClip As ClipBoardClass: Set clsClip = New ClipBoardClass
clsClip.SetClipBoard ("test1")
Debug.Print clsClip.ClipBoard_GetData
Clip_Error:
Call clsClip.ClsClipBoardClass_Err
End Sub

Class Module クラスモジュール

' https://msdn.microsoft.com/ja-jp/vba/access-vba/articles/retrieve-information-from-the-clipboard
' http://keirivba.hateblo.jp/entry/2017/11/03/234832
' [Docs/Windows/Desktop/Data Exchange/Clipboard/Clipboard Overviews](https://docs.microsoft.com/en-us/windows/desktop/dataxchg/clipboard-overviews)
'''''''''''''''''''''''''''''''''''''
' Class Module
' ClipBoardClass
' Win 64/32
''''''''''''''''''''''''''''''''''''''''
# If VBA7 Then
Private Declare PtrSafe Function OpenClipboard Lib "User32" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "User32" () As Long
Private Declare PtrSafe Function GetClipboardData Lib "User32" (ByVal wFormat As _
LongPtr) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "User32" () As LongPtr
Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
'クリップボードにデータを渡す
Private Declare PtrSafe Function SetClipboardData Lib "User32" ( _
ByVal wFormat As Long, _
ByVal hMem As LongPtr) As LongPtr

'指定したサイズ分のメモリを割り当て
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" ( _
ByVal wFlags As Long, _
ByVal dwBytes As LongPtr) As LongPtr

'メモリブロックをロックして最初の1バイトへのポインタを返す
Private Declare PtrSafe Function GlobalLock Lib "kernel32" ( _
ByVal hMem As LongPtr) As LongPtr

'メモリのロックを解除
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" ( _
ByVal hMem As LongPtr) As Long
'バッファに文字列をコピー
Private Declare PtrSafe Function lstrcpy Lib "kernel32" ( _
ByVal lpString1 As Any, _
ByVal lpString2 As Any) As LongPtr
# Else
'Open close get globalalloc GlobalLock GloablUnlock GlobalSize lstcpy Empty
Private Declare Function OpenClipboard Lib "User32" (ByVal hWnd As Long) _
As Long
Private Declare Function CloseClipboard Lib "User32" () 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 GlobalAlloc Lib "kernel32" (ByVal wFlags, ByVal _
dwBytes 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 Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _
ByVal lpString2 As Any) As Long
# End If
'GlobalALock
Private Const GHND = &H42
' SetClipboadData
Private Const CF_TEXT = &H1
Private Const CF_LINK = &HBF00
Private Const CF_BITMAP = 2
Private Const CF_METAFILE = 3
Private Const CF_DIB = 8
Private Const CF_PALETTE = 9
Private Const MAXSIZE = 4096
Public Sub ClsClipBoardClass_Err()
OpenClipboard (0)
EmptyClipboard
CloseClipboard
End Sub

Public Function SetClipBoard(MyString As String)
# If VBA7 Then
Dim hGlobalMemory As LongPtr
Dim lpGlobalMemory As LongPtr
Dim hClipMemory As LongPtr
Dim X As LongPtr
# Else
Dim hGlobalMemory As Long
Dim lpGlobalMemory As Long
Dim hClipMemory As Long
Dim X As Long
# End If
'移動可能なグローバルメモリを割り当て
hGlobalMemory = GlobalAlloc(GHND, LenB(MyString) + 1)
'ブロックをロックして、メモリへのfarポインタを取得
lpGlobalMemory = GlobalLock(hGlobalMemory)
'文字列をグローバルメモリへコピー
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
'メモリのロックを解除します。
If GlobalUnlock(hGlobalMemory) <> 0 Then
MsgBox "メモリのロックを解除できません" & vbCrLf & _
"処理が失敗しました"
GoTo OutOfHere2
End If

'データをコピーするクリップボードを開く
If OpenClipboard(0&) = 0 Then
MsgBox "クリップボードを開くことができません" & vbCrLf & _
"処理が失敗しました"
Exit Function
End If

' クリップボードの内容を消去
X = EmptyClipboard()

' データをクリップボードへコピー
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)

OutOfHere2:
'クリップボードの状態チェック
If CloseClipboard() = 0 Then
MsgBox "クリップボードを閉じることができません"
End If
End Function

Public Function ClipBoard_GetData()
# If VBA7 Then
Dim hClipMemory As LongPtr
Dim lpClipMemory As LongPtr
# Else
Dim hClipMemory As Long
Dim lpClipMemory As Long
# End If
Dim MyString As String
Dim RetVal As Long

If OpenClipboard(0&) = 0 Then
MsgBox "Cannot open Clipboard. Another app. may have it open"
Exit Function
End If

' Obtain the handle to the global memory
' block that is referencing the text.
hClipMemory = GetClipboardData(CF_TEXT)
If IsNull(hClipMemory) Then
MsgBox "Could not allocate memory"
GoTo OutOfHere
End If

' Lock Clipboard memory so we can reference
' the actual data string.
lpClipMemory = GlobalLock(hClipMemory)

If Not IsNull(lpClipMemory) Then
MyString = Space$(MAXSIZE)
RetVal = lstrcpy(MyString, lpClipMemory)
RetVal = GlobalUnlock(hClipMemory)
' Peel off the null terminating character.
MyString = Mid(MyString, 1, InStr(1, MyString, Chr$(0), 0) - 1)
Else
MsgBox "Could not lock memory to copy string from."
End If

OutOfHere:
RetVal = CloseClipboard()
ClipBoard_GetData = MyString
End Function

''''SampleCode For Module
' 標準モジュール用のコードです
' Classモジュールでは動きません。かならず標準モジュールに記述してください。

'Sub ClipBoardClassTest()
'' 標準モジュール用のコードです
'On Error GoTo Clip_Error
'' Dim and New For ClipBoadClass
'Dim clsClip As ClipBoardClass: Set clsClip = New ClipBoardClass
'clsClip.SetClipBoard ("test1")
'Debug.Print clsClip.ClipBoard_GetData
'Clip_Error:
'Call clsClip.ClsClipBoardClass_Err
'End Sub

長所

ExcelやAccessは、ExcelはAppllication、AccessはDocmdと異なるクリップボード取得があるが、Win32APIを使うとその苦労がなくなる。

Access

Private Sub cmdPaste_Click()
' Access
Me!txtNotes.SetFocus
DoCmd.RunCommand acCmdPaste
End Sub

参考

クリップボードから情報を取得します。
Access用