Option Compare Database
Option Explicit

'文字列にしか対応してません
'VBではクリップボード関数を使いましょう

'IMEをオンにすると落ちることがあります。(-_-;)
'   ↓
'プロチョンでした。(00/03/16)

Public Const GHND = &H42
Public Const CF_TEXT = 1
Public Const MAXSIZE = 4096

'クリップボードを開く
Declare Function OpenClipboard Lib "User32" (ByVal hWnd As Long) As Long
'クリップボードを閉じる
Declare Function CloseClipboard Lib "User32" () As Long
'メモリのロックを解除
Declare Function GlobalUnlock Lib "KERNEL32" (ByVal hMem As Long) As Long
'メモリをロック
Declare Function GlobalLock Lib "KERNEL32" (ByVal hMem As Long) As Long
'メモリ割り当て
Declare Function GlobalAlloc Lib "KERNEL32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
'文字列をグローバル メモリへコピー
Declare Function lstrcpy Lib "KERNEL32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
'クリップボードハンドル取得
Declare Function GetClipboardData Lib "User32" (ByVal wFormat As Long) As Long

'クリップボードの内容を消去
Declare Function EmptyClipboard Lib "User32" () As Long
'データをクリップボードへコピー
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long

Function ClipBoard_GetData()
'クリップボードから情報を取り出す
    Dim hClipMemory As Long, lpClipMemory As Long, MyString As String, RetVal As Long
    
    If OpenClipboard(0&) = 0 Then
        MsgBox "他のアプリケーションが使用しているため、クリップボードを開けません。", vbCritical
        Exit Function
    End If
    
    hClipMemory = GetClipboardData(CF_TEXT)
    If IsNull(hClipMemory) Then
        MsgBox "クリップボードハンドル取得に失敗しました", vbCritical
        GoTo OutOfHere
    End If
    
    lpClipMemory = GlobalLock(hClipMemory)
    If Not IsNull(lpClipMemory) Then
        MyString = Space$(MAXSIZE)
        RetVal = lstrcpy(MyString, lpClipMemory)
        RetVal = GlobalUnlock(hClipMemory)
        
        On Error Resume Next
        MyString = Mid(MyString, 1, InStr(1, MyString, Chr$(0), 0) - 1)
        If Err Then 'text以外のデータ
            MsgBox "クリップボードのデータはテキストでありません", vbCritical
            Err.Clear
            MyString = ""
        End If
        On Error GoTo 0
    Else
        MsgBox "クリップボード メモリをロックできません", vbCritical
    End If
OutOfHere:
    RetVal = CloseClipboard()
    If MyString = "" Then
        ClipBoard_SetData MyString
    Else
        ClipBoard_GetData = MyString
    End If
End Function

Function ClipBoard_SetData(MyString As String)
'クリップボードへ情報を送信
    Dim hGlobalMemory As Long, lpGlobalMemory As Long, hClipMemory As Long, X As Long
    
    'hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1) 'プロチョンでした。(00/03/16)
    hGlobalMemory = GlobalAlloc(GHND, LenB(StrConv(MyString, vbFromUnicode)) + 1) 'これが正しい。LenBだけでもいいです。(00/03/16)
    lpGlobalMemory = GlobalLock(hGlobalMemory)
    lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
    If GlobalUnlock(hGlobalMemory) <> 0 Then
        MsgBox "メモリのロックを解除できません。処理が失敗しました。", vbCritical
        GoTo OutOfHere2
    End If
    
    If OpenClipboard(0&) = 0 Then
        MsgBox "クリップボードを開くことができません。処理が失敗しました。", vbCritical
        Exit Function
    End If
    X = EmptyClipboard()
    hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
    If CloseClipboard() = 0 Then
        MsgBox "クリップボードを閉じることができません。", vbCritical
    End If
End Function