さすらいのプログラマ

Option Explicit

'Win32API宣言
Public Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function EmptyClipboard Lib "user32" () As Long
Public Declare Function CloseClipboard Lib "user32" () As Long
Public Declare Function SetClipboardData Lib "user32" (ByVal uFormat As Long, ByVal hData As Long) As Long
Public Declare Function GlobalAlloc Lib "kernel32" (ByVal uFlag As Long, ByVal dwBytes As Long) As Long
Public Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Public Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
'本来はＣ言語用の文字列コピーだが、２つ目の引数をStringとしているので変換が行われた上でコピーされる。
Public Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As Long, ByVal lpString2 As String) As Long

'定数宣言
Public Const GMEM_MOVEABLE         As Long = &H2
Public Const GMEM_ZEROINIT         As Long = &H40
Public Const GHND                  As Long = (GMEM_MOVEABLE Or GMEM_ZEROINIT)
Public Const CF_TEXT               As Long = 1
Public Const CF_OEMTEXT            As Long = 7

Public Function CopyText(str As String) As Boolean
    Dim hGlobal As Long
    Dim length As Long
    Dim p As Long
    
    '戻り値をとりあえず、Falseに設定しておく。
    CopyText = False
    If OpenClipboard(0) <> 0 Then
        If EmptyClipboard() <> 0 Then
            '長さの算出(本来はUnicodeから変換後の長さを使うほうがよい)
            length = LenB(str) + 1
            'コピー先の領域確保
            hGlobal = GlobalAlloc(GHND, length)
            p = GlobalLock(hGlobal)
            '文字列をコピー
            Call lstrcpy(p, str)
            'クリップボードに渡すときにはUnlockしておく必要がある
            Call GlobalUnlock(hGlobal)
            'クリップボードへ貼り付ける
            Call SetClipboardData(CF_TEXT, hGlobal)
            'クリップボードをクローズ
            Call CloseClipboard
            'コピー成功
            CopyText = True
        End If
    End If
End Function