クリップボード処理 (PutInClipboardの代案) | VBA

'**********************************************************************
' クリップボード処理
'   PutInClipboardが通らないパソコンがあるための代替処理
'**********************************************************************

#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" (ByVal hMem As LongPtr) As LongPtr
    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 Sub MoveMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
#End If

Const GMEM_MOVEABLE As Long = &H2
Const GMEM_ZEROINIT As Long = &H40
Const CF_UNICODETEXT As Long = &HD

'*******************************************************************************
' クリップボードへコピー
'  input  : MyString = コピーする文字列
'*******************************************************************************
Public Sub SetClipboard(MyString As String)
#If VBA7 And Win64 Then
    Dim hGlobalMemory  As LongPtr
    Dim lpGlobalMemory As LongPtr
    Dim text_len As LongLong
#Else
    Dim hGlobalMemory  As Long
    Dim lpGlobalMemory As Long
    Dim text_len As Long
#End If

    If OpenClipboard(0&) = 0 Then
        MsgBox "クリップボードが開きません。"
        Exit Sub
    End If

    'クリップボードのデータをクリアー
    EmptyClipboard

    text_len = LenB(MyString) + 2&

     '移動可能なグローバルメモリーを割り当て
    hGlobalMemory = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, text_len)
    If IsNull(hGlobalMemory) Then
        MsgBox "メモリーを確保できません。"
        GoTo EXIT_FUNC
    End If

    'ブロックをロックして、メモリーへのfarポインターを取得
    lpGlobalMemory = GlobalLock(hGlobalMemory)
    If IsNull(lpGlobalMemory) Then
        MsgBox "メモリーをロックできません。"
        GoTo EXIT_FUNC
    End If

    '文字列をグローバルメモリーへコピー
    Call MoveMemory(lpGlobalMemory, StrPtr(MyString), text_len)

     'メモリーのロックを解除します。
    If GlobalUnlock(hGlobalMemory) <> 0 Then
        MsgBox "メモリーのロックを解除できません。"
        GoTo EXIT_FUNC
    End If

     ' データをクリップボードへコピー
    Call SetClipboardData(CF_UNICODETEXT, hGlobalMemory)

EXIT_FUNC:
    CloseClipboard
End Sub