クリップボードにテキストデータを設定する。

#If VBA7 And Win64 Then
    Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
    Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
    Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
    Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
    Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
    Declare PtrSafe Function lstrcpy Lib "kernel32" Alias "lstrcpyW" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long
#Else
    Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
    Declare Function EmptyClipboard Lib "user32" () As Long
    Declare Function CloseClipboard Lib "user32" () As Long
    Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
    Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
    Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyW" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long
#End If

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

'*******************************************************************
'　クリップボードにテキストデータを送信
'*******************************************************************
Sub Clipboard_SetTextData()
    
    Call SetClipboard("この文字列をクリップボードに送ります。")
    
End Sub

'*******************************************************************
'　クリップボードにテキストデータを送信（テキストデータのみ）
'-------------------------------------------------------------------
'　　第１引数：クリップボードに送信する文字列
'*******************************************************************
Sub SetClipboard(sSetText As String)
    Dim lCBHndl As Long
    Dim lMemPtr As Long
    Dim lMemHndl As Long
    Dim lLen As Long
    Dim lRetVal As Long
    
    'クリップボードを開く
    If OpenClipboard(0&) = 0 Then
        MsgBox "(Error)クリップボードが開けません。" & _
                      "他アプリ等が利用している可能性があります。"
       Exit Sub
    End If
    
    'クリップボードの内容を消去
    lRetVal = EmptyClipboard
    
    lLen = LenB(sSetText) + 2&
    
    'メモリをヒープから割り当てる
    lMemHndl = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, lLen)
    
    'グローバルメモリオブジェクトのロックとメモリブロックのポインタ取得
    lMemPtr = GlobalLock(lMemHndl)
    If Not IsNull(lMemPtr) Then
        lRetVal = lstrcpy(lMemPtr, StrPtr(sSetText))
        
        'アンロック、グローバルメモリオブジェクトのロックカウントを減らす
        lRetVal = GlobalUnlock(lMemHndl)
        
        'クリップボードに送る
        lCBHndl = SetClipboardData(CF_UNICODETEXT, lMemHndl)
    
    Else
        MsgBox "(Error)ロックができませんでした。"
    End If
    
    'クリップボードを閉じる
    lRetVal = CloseClipboard

End Sub