Excel VBA クリップボードが文字化けする場合の対策

time 2017/12/01

普通にexcelのDataObjectを利用すると「□□」が張り付くバグがあります。

・【Wordマクロ】クリップボードへのデータ入力・取得のエラーへの対処
・開いているファイルのアドレスを取るマクロ動かすとなぜか□□が張り付く

それには以下2通りの方法にて回避することが可能です。

テキストボックス経由で行う方法

参考サイト：
[VBA]DataObjectを使ったクリップボード操作が上手くいかない場合の対処法

Private Function GetCB() As String 'クリップボードから文字列を取得
    Dim Form As Object: Set Form = CreateObject("Forms.TextBox.1")
    Form.MultiLine = True
    If Form.CanPaste = True Then Form.Paste
    GetCB = Form.Text
End Function
Private Sub SetCB(str As String) 'クリップボードに文字列を格納
  With CreateObject("Forms.TextBox.1")
    .MultiLine = True
    .Text = str
    .SelStart = 0
    .SelLength = .TextLength
    .Copy
  End With
End Sub

GetCBがお目当てのクリップボードからデータを取得するコードになりますが、SetCBにて逆にクリップボードへの格納も可能です。

補足：
知恵袋より、GetCBの使い方ですが、

Sub 使い方()
　　　　Debug.Print GetCB()
　　　　Range("A1") = GetCB()
End Sub

これだけでコピペの文字列がA1に入ります。

API経由で行う方法

参考サイト：

MS純正
・クリップボードに情報を送信する
・クリップボードから情報を取得する

'Clipboard(★set☆get)===================================================================================
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long '★☆
Private Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long '★☆
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem 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 GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long '★
Private Declare Function EmptyClipboard Lib "user32" () As Long '★
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long '★
Private Const GHND = &H42 '★
Private Const CF_TEXT = 1 '★

Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long '☆
Private Const MAXSIZE = 4096 '☆
'Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long '使ってない?
'==========================================================================================
Function ClipBoard_SetData(str As String)
	Dim MyStr As String: MyStr = str & Chr(0) 'chr(0)を付加しないとlstrcpyでデリミタが認識できません。
	Dim hGlobalMemory As Long: hGlobalMemory = GlobalAlloc(GHND, LenB(MyStr) + 1) '移動可能なグローバルメモリを割り当てる
	Dim lpGlobalMemory As Long: lpGlobalMemory = GlobalLock(hGlobalMemory) 'ブロックをロックして、メモリへのfarポインタを取得
	lpGlobalMemory = lstrcpy(lpGlobalMemory, MyStr) '文字列をグローバルメモリへコピー
	If GlobalUnlock(hGlobalMemory) <> 0 Then 'メモリのロックを解除
		MsgBox "メモリのロック解除に失敗しました"
		GoTo OutOfHere2
	End If
	If OpenClipboard(0&) = 0 Then 'クリップボードを開いて確保する (他アプリが変更できないようにする)
		MsgBox "クリップボードの確保に失敗しました"
		Exit Function
	End If
	Dim x As Long: x = EmptyClipboard() '確保したクリップボードを掃除する
	Dim hClipMemory As Long: hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory) 'メモリのデータをクリップボードへTEXT形式でセットする
OutOfHere2:
	If CloseClipboard() = 0 Then 'クリップボードの状態チェック
		MsgBox "クリップボードを閉じれませんでした"
	End If
End Function
Function ClipBoard_GetData()
	If OpenClipboard(0&) = 0 Then 'クリップボードの状態チェック
		MsgBox "クリップボードを開けませんでした": Exit Function
	End If
	Dim hClipMemory As Long: hClipMemory = GetClipboardData(CF_TEXT) 'テキストを参照しているハンドルをグローバルメモリに取得
	If IsNull(hClipMemory) Then
		MsgBox "メモリが割り当てられません"
		GoTo OutOfHere
	End If
	Dim lpClipMemory As Long: lpClipMemory = GlobalLock(hClipMemory) 'メモリをロックして、実際のデータ文字列を参照できるようにする
	If Not IsNull(lpClipMemory) Then
		Dim MyString As String: MyString = Space$(MAXSIZE)
		Dim RetVal As Long
		RetVal = lstrcpy(MyString, lpClipMemory)
		RetVal = GlobalUnlock(hClipMemory)
		MyString = Mid(MyString, 1, InStr(1, MyString, Chr$(0), 0) - 1) '終端Null文字を取り除く
	Else
		MsgBox "メモリの確保に失敗しました"
	End If
OutOfHere:
	RetVal = CloseClipboard()
	ClipBoard_GetData = MyString
End Function

function内でmsgboxを返すのはダサいですので、エラーコードを返すようにするなり工夫して使ってみてください。
IQ145の女子高生「ずいぶんとダサいコードを書いているのね」(ちがw)