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

Option Explicit

Const CF_TEXT = &h1
Const GHND = &h42

Private Declare Function OpenClipboard Lib "USER" (ByVal hwnd As Integer) As Integer
Private Declare Function CloseClipboard Lib "USER" () As Integer
Private Declare Function EmptyClipboard Lib "USER" () As Integer
Private Declare Function SetClipboarddata Lib "USER" (ByVal wFormat As Integer, ByVal hData As Integer) As Integer
Private Declare Function GetClipboardData Lib "USER" (ByVal wFormat As Integer) As Integer
Private Declare Function GlobalAlloc Lib "KERNEL" (ByVal wFlags As Integer, ByVal wBytes As Long) As Integer
Private Declare Function GlobalFree Lib "KERNEL" (ByVal hMem As Integer) As Integer
Private Declare Function GlobalLock Lib "KERNEL" (ByVal hMem As Integer) As Long
Private Declare Function GlobalUnlock Lib "KERNEL" (ByVal hMem As Integer) As Integer
Private Declare Function GlobalSize Lib "KERNEL" (ByVal hMem As Integer) As Long
Private Declare Function lstrcpy Lib "KERNEL" (ByVal pString1 As Any, ByVal pString2 As Any) As Long


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

    On Error GoTo ErrorHandler

    GetClipboardText16 = False

    'クリップボードのオープン
    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
        GetClipboardText16 = ""
        iRet = GlobalUnlock(hglb)
        iRet = CloseClipboard()
        Exit Function
    End If

    '文字列変数へコピー
    sBuffer = String(iLength, " ")
    If lstrcpy(sBuffer, lptstr) <> 0 Then
        GetClipboardText16 = 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 SetClipboardText16(string1 As String) As Boolean
    Dim hglb As Integer, lptstr As Long, iRet As Integer
    Dim sBuffer As String

    On Error GoTo ErrorHandler

    SetClipboardText16 = 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
        SetClipboardText16 = True
    End If

    Exit Function

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


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

    ClipboardClear16 = False

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

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

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


Sub SetClipboardText16_Test()
    If SetClipboardText16("TestText") Then
        MsgBox GetClipboardText16()
    End If
End Sub