'クリップボードへのテキストデータ入出力を行う関数(Excel95)

Option Explicit

Private Const CF_TEXT = &h1
Private Const GHND = &h42

Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
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" Alias "SetClipboardData" (ByVal Fmt As Long, ByVal hData As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long

Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal wBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem 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" Alias "lstrcpyA" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long

'クリップボードからテキストを取得する関数
Function GetClipboardText() As Variant
    Dim hglb As Long, lptstr As Long, iLength As Long, iRet As Long
    Dim sBuffer As String

    On Error GoTo ErrorHandler

    GetClipboardText = False

    'テキストデータかチェック
'    If IsClipboardFormatAvailable(CF_TEXT) = 0 Then Exit Function

    'クリップボードのオープン
    If OpenClipboard(0) = 0 Then Exit Function

    'クリップボードのグローバルメモリハンドルを取得
    hglb = GetClipboardData(CF_TEXT)
    If hglb = 0 Then
        iRet = CloseClipboard()
        Exit Function
    End If

    'グローバルメモリのロック
    lptstr = GlobalLock(hglb)
    If lptstr = 0 Then
        iRet = CloseClipboard()
        Exit Function
    End If

    'グローバルメモリのサイズを取得
    iLength = GlobalSize(hglb)
    If iLength = 0 Then
        GetClipboardText = ""
        iRet = GlobalUnlock(hglb)
        iRet = CloseClipboard()
        Exit Function
    End If

    '文字列変数へコピー
    sBuffer = String(iLength, " ")
    If lstrcpy(sBuffer, lptstr) <> 0 Then
        GetClipboardText = Mid$(sBuffer, 1, InStr(1, sBuffer, Chr$(0), 0) - 1)
    End If

    'グローバルメモリのロック解除
    iRet = GlobalUnlock(hglb)

    'クリップボードのクローズ
    iRet = CloseClipboard()
    Exit Function

ErrorHandler:
    If hglb <> 0 Then iRet = GlobalUnlock(hglb)
    iRet = CloseClipboard()
End Function


'クリップボードへテキストデータを登録する関数
Function SetClipboardText(string1 As String) As Boolean
    Dim hglb As Long, lptstr As Long, iRet As Long
    Dim sBuffer As String

    On Error GoTo ErrorHandler

    SetClipboardText = False
    sBuffer = string1

    'グローバルメモリの割り当て
    hglb = GlobalAlloc(GHND, LenB(sBuffer) + 1)
    If hglb = 0 Then Exit Function

    'グローバルメモリのロック
    lptstr = GlobalLock(hglb)
    If lptstr = 0 Then
        iRet = GlobalFree(hglb)
        Exit Function
    End If

    'グローバルメモリへコピー
    If lstrcpy(lptstr, sBuffer) = 0 Then
        iRet = GlobalUnlock(hglb)
        iRet = GlobalFree(hglb)
        Exit Function
    End If

    'グローバルメモリのロック解除
    If GlobalUnlock(hglb) <> 0 Then
        iRet = GlobalFree(hglb)
        Exit Function
    End If

    'クリップボードのオープン
    If OpenClipboard(0) = 0 Then
        iRet = GlobalFree(hglb)
        Exit Function
    End If

    'クリップボードのクリア
    If EmptyClipboard() = 0 Then
        iRet = CloseClipboard()
        iRet = GlobalFree(hglb)
        Exit Function
    End If

    'クリップボードへ登録
    If SetClipboarddata(CF_TEXT, hglb) = 0 Then
        iRet = CloseClipboard()
        iRet = GlobalFree(hglb)
        Exit Function
    End If

    'クリップボードのクローズ
    If CloseClipboard() <> 0 Then
        SetClipboardText = True
    End If

    Exit Function

ErrorHandler:
    If hglb <> 0 Then iRet = GlobalFree(hglb)
    iRet = CloseClipboard()
    Exit Function
End Function


'クリップボードをクリアする関数
Function ClipboardClear() As Boolean
    Dim iRet As Long

    ClipboardClear = False

    'クリップボードのオープン
    If OpenClipboard(0) = 0 Then Exit Function

    'クリップボードのクリア
    If EmptyClipboard() = 0 Then
        iRet = CloseClipboard()
        Exit Function
    End If

    'クリップボードのクローズ
    If CloseClipboard() = 0 Then Exit Function
    ClipboardClear = True
End Function


Sub SetClipboardText_Test()
    If SetClipboardText("TestText") Then
        MsgBox GetClipboardText()
    End If
End Sub