Excel VBAでクリップボードに全角文字を格納する

結論としては、ExcelのDataObjectを利用してクリップボードに全角文字の格納ができませんでした。（どうやら2バイトとか3バイトとかのマルチバイトがダメらしいです。。）
試した環境は、Windows 7のExcel 2010と、Windows 8.1のExcel 2013で、ともに64bitマシンです。以前（XP 32bit Excel 2003）はできていた気がするので、原因はx64なのか、Officeのバージョンなのか。。

いろいろ調べてみたのですが有効な情報が得られず、えらい苦労したので備忘録です。

そして、解決方法には、Win32APIを利用しました。

やりたいこと：クリップボードへの文字列格納
やってみたこと： MSForms.DataObjectでクリップボードにアクセス
現象：半角文字は成功、全角混在は失敗
対策： Win32APIを利用

やりたいこと：クリップボードへの文字列格納

お仕事でExcelの表を使っていて、表から報告書を作った後、クリップボードに、日付（y/m）と日本語文字列というキーワードを格納したいのです。

そうすると、マクロを動かしたら、その日のキーワードが生成できて、別の記録ツールに貼りつけられて手間が省けるという寸法です。いちいち日付変えるのが面倒だし、ミスのリスクもあるし。
セルからコピーすると改行が入っちゃってそれも消すのが手間。。

やってみたこと： MSForms.DataObjectでクリップボードにアクセス

VBAでクリップボードを操作するというようなことをネットで調べて、DataObjectを使えばよいらしいということになり、以下のようなコードをテスト実行してみました。

Sub SetClipBoardSample()
    Dim myDO As DataObject
    Dim myStr As String
    myStr = "Hello World!"
    Set myDO = New DataObject
    myDO.SetText myStr
    myDO.PutInClipboard
End Sub

そして見事に成功！
クリップボードツールに、しっかりと文字列「Hello World!」が表示されます。

ところが・・・

現象：半角文字は成功、全角混在は失敗

肝心のキーワードは日付と日本語。つまり半角全角混合文字列です。
Hello World!を「ハローワールド」に置き換えてテスト実行したところ、うまくいかず。

クリップボードツールでは、クリップボードに何も出力されていないように見えます。
実際、貼り付けようとしても何も貼り付きません。前の情報が残っているのではなく、情報がクリアされているようです。

半角だけならうまくいくので、日付だけならちゃんとできます。でも、しっかりキーワードでないと実用がめんどいのです。

文字コードで指定してみたらどうか、とも思ってやってみたのですが、なんだかうまくいかず。。

対策： Win32APIを利用

あちこち調べて見えてきたのは、どうやらMSForms.DataObjectでは全角（マルチバイト？）を格納することは不可能らしいということでした。

そして、TwitterでWin32APIでの解決という方法を知ります。

DLLの扱い方を調査して挫折

いろいろ見てみたのですが、難しい言葉を調べる気力がなく。。

お手軽に使いたいので、呪文だと思うことにしました。
なので、ネットで見つけたサンプルコードをそのままいただいて、標準モジュールに貼り付けてブラックボックス化。Public Functionなので、別モジュールから呼び出すということで解決しました。

ちょっとずるいような気もしますが、これで問題なく動作しました。
x86とx64だと少し違うようなのですが、x64環境ではこれで動いています。

サンプルコード

いただきもののサンプルコードを載せておきます。なくなっちゃうと困るので。。
オリジナルはこちらです。感謝です！^ ^

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

サンプルコード（呼び出し側）

たとえばこんな使い方。

Sub SetClipBoardSample02()
    Dim blnReturn As Boolean
    blnReturn = CopyText("ともだちひろばのひろば since 2014")
End Sub

以上です。