Excel VBA 値の貼り付けとUnicode テキスト貼り付け

クリップボードの内容（数値もしくは文字列）を貼り付ける際、
アクティブなセルに値もしくはUnicodeテキストとして
貼り付けるコードを書こうとしています。
コピー＆ペーストする内容は1つのセルだったり、複数のセル範囲だったり、
はたまたExcel以外のアプリケーションからのコピーだったりします。

それぞれについては下記のように書けば希望通りになるのですが
どちらであっても対応できるよう、
両方の機能を一つのプロシージャでまとめることは可能でしょうか？

■エクセルシート上の値（セルや範囲）からの貼り付け
Selection.PasteSpecial Paste:=xlValues

■外部ファイル（HTMLなど）からのUnicodeテキスト貼り付け
ActiveSheet.PasteSpecial Format:="Unicode テキスト"

これらは「マクロの記録」を参考にしたものですが、
Rangeオブジェクト用とWorksheetオブジェクト用に分かれているので
クリップボードの種別判定？やエラー判定？のようなif文等による
何らかの分岐が必要なのかなと思い、自分なりに調べてみましたが、
具体的な方法がわからず困っております。

どちらにも対応できるコードにするにはどうすれば良いでしょうか？
どうぞよろしくお願いいたします。

No.3 ベストアンサー 回答者： KenKen_SP 回答日時： 2010/03/12 02:52

ついでに　Application.ClipboardFormats　を使った簡易サンプル。

なお、HTMLソースのコピーの場合は、テキスト貼り付けになりません。
対策するなら、#2 のようにクリップボードから直接テキストを
取り出して自前処理する必要があります。

Public Sub Sample2()

　　If IsCBFormatAvailable(xlClipboardFormatLink) Then
　　　　Selection.PasteSpecial Paste:=xlPasteValues
　　ElseIf IsCBFormatAvailable(xlClipboardFormatText) Then
　　　　ActiveSheet.PasteSpecial Format:="Unicode テキスト"
　　Else
　　　　' その他...Excel でも Shape とか Graph がありますよね
　　　　ActiveSheet.Paste
　　End If

End Sub

' // 指定したフォーマットのデータがクリップボードにあるか？
'
Public Function IsCBFormatAvailable(ByVal wFormat As XlClipboardFormat) As Boolean
　　
　　Dim fmt As Variant
　　For Each fmt In Application.ClipboardFormats
　　　　If CLng(fmt) = wFormat Then
　　　　　　IsCBFormatAvailable = True
　　　　　　Exit For
　　　　End If
　　Next

End Function

この回答へのお礼

簡易版も作ってくださりありがとうございました！まだ実際には試せていませんが、
On Errorステートメントで対処するよりもちゃんとifで分岐させた方が気持ちが良いし、
今のところ外部からはテキスト以外のものをマクロで貼り付けることはしませんが
もし何かそうなった時にも対応できそうなので、
KenKen_SP様のコードを使わせていただこうと思います。
ありがとうございました！

お礼日時：2010/03/12 10:34

No.2 回答者： KenKen_SP 回答日時： 2010/03/12 02:33

本質問の回答としては、#1 ご回答のように

　　Application.ClipboardFormats

で解決（あとは使い方と工夫の問題）すると思います。

IsClipboardFormatAvailable API を使うとこんな感じで細かな
条件分岐も可能ですよ。ただ本来数行で済むものを、なぜこんなに
ソースが長くなっているのかは、別件で

　　なんで HTML ソースそのまんま貼りつかねーのさ
　　ヾ(*｀Д´*)ノ"

ってうなってたからです。
タイムリーすぎ。。と思ってしまったからです。

Option Explicit

Private Declare Function OpenClipboard Lib "user32.dll" ( _
　　　　ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" ( _
　　　　ByVal wFormat As Long) As Long
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare Function RegisterClipboardFormat Lib "user32.dll" _
　　　　Alias "RegisterClipboardFormatA" ( _
　　　　ByVal lpString As String) As Long
Private Declare Function GetClipboardData Lib "user32.dll" ( _
　　　　ByVal wFormat As Long) As Long
Private Declare Function SetClipboardData Lib "user32.dll" ( _
　　　　ByVal wFormat As Long, _
　　　　ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32.dll" ( _
　　　　ByVal wFlags As Long, _
　　　　ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" ( _
　　　　ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" ( _
　　　　ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32.dll" ( _
　　　　ByVal hMem As Long) As Long
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
　　　　ByVal Destination As Long, _
　　　　ByVal Source As Long, _
　　　　ByVal Length As Long)

Private Const GMEM_MOVEABLE　As Long = &H2
Private Const CF_UNICODETEXT As Long = 13

Sub PasteSample()

　　Dim CF_HTML　　　　 As Long ' Html
　　Dim CF_LINK　　　　 As Long ' Range Object
　　
　　CF_LINK = RegisterClipboardFormat("LINK")
　　CF_HTML = RegisterClipboardFormat("HTML Format")
　　
　　If IsClipboardFormatAvailable(CF_LINK) Then
　　　　' セルのコピーの場合。。。application.CutCopyModeでも判断できそう
　　　　Selection.PasteSpecial Paste:=xlValues
　　ElseIf IsClipboardFormatAvailable(CF_HTML) Then
　　　　' IE で Web ページをコピーした場合( CF_HTML )
　　　　ActiveSheet.PasteSpecial Format:="Unicode テキスト"
　　ElseIf IsClipboardFormatAvailable(CF_UNICODETEXT) Then
　　　　Dim buf As String
　　　　buf = ClipBoardGetText()
　　　　If InStr(1, buf, "<html", vbTextCompare) Or InStr(1, buf, "<body", vbTextCompare) Then
　　　　　　' Htmlソースのコピー等はソースのまま貼り付けてみる
　　　　　　' ...っぽく見せかけるの...無理やり...(´д｀ ；)
　　　　　　Dim v As Variant
　　　　　　v = Split(buf, vbCrLf)
　　　　　　Selection.Cells(1).Resize(UBound(v)).Value = Application.Transpose(v)
　　　　Else
　　　　　　' 単純テキストの場合
　　　　　　ActiveSheet.PasteSpecial Format:="Unicode テキスト"
　　　　End If
　　Else
　　　　' その他
　　　　ActiveSheet.Paste
　　End If

End Sub

' // クリップボードから Unicode Text を取得する
'
Public Function ClipBoardGetText() As String

　　Dim hMem　　　　　　 As Long
　　Dim lp　　　　　　　 As Long
　　Dim sz　　　　　　　 As Long
　　Dim buf()　　　　　　As Byte
　　
　　If OpenClipboard(0&) <> 0 Then
　　　　hMem = GetClipboardData(CF_UNICODETEXT)
　　　　If hMem <> 0 Then
　　　　　　lp = GlobalLock(hMem)
　　　　　　sz = GlobalSize(hMem)
　　　　　　ReDim buf(0 To sz)
　　　　　　MoveMemory VarPtr(buf(0)), lp, sz
　　　　　　GlobalUnlock hMem
　　　　End If
　　　　CloseClipboard
　　　　ClipBoardGetText = Left$(buf, InStr(buf, vbNullChar) - 1)
　　End If

End Function

' // クリップボードに Unicode Text をコピーする
'
Public Function ClipBoardSetText(ByVal srcText As String) As Boolean

　　Dim hMem　　　　　　 As Long
　　Dim lp　　　　　　　 As Long
　　Dim sz　　　　　　　 As Long
　　Dim buf()　　　　　　As Byte

　　If OpenClipboard(0&) <> 0 Then
　　　　EmptyClipboard
　　　　buf = srcText & vbNullChar
　　　　sz = UBound(buf) - LBound(buf) + 1
　　　　hMem = GlobalAlloc(GMEM_MOVEABLE, sz)
　　　　If hMem <> 0 Then
　　　　　　lp = GlobalLock(hMem)
　　　　　　MoveMemory lp, VarPtr(buf(LBound(buf))), sz
　　　　　　GlobalUnlock hMem
　　　　　　ClipBoardSetText = CBool(SetClipboardData(CF_UNICODETEXT, hMem) <> 0)
　　　　End If
　　　　CloseClipboard
　　End If

End Function

この回答へのお礼

大作コードをありがとうございます。
一行一行じっくりと勉強してみたいと思います。
ありがとうございました！

お礼日時：2010/03/12 10:28

No.1 回答者： mitarashi 回答日時： 2010/03/11 23:16

エクセルVBAのヘルプのコード（ちょっとアレンジ）ですが、これでクリップボードの中味を調べるのはいかがでしょうか。

Sub test()
Dim aFmts ,fmt

aFmts = Application.ClipboardFormats
For Each fmt In aFmts
Debug.Print fmt
Next fmt
End Sub
得られた数値は、下記と見比べてください（これもヘルプから）。試しにエクセルのセル群を
コピーしてみた結果ではこれでも全部の種類はカバーできていない様でした。xl2000の例です。
Sub test2()
Debug.Print xlClipboardFormatBIFF
Debug.Print xlClipboardFormatBIFF2
Debug.Print xlClipboardFormatBIFF3
Debug.Print xlClipboardFormatBIFF4
Debug.Print xlClipboardFormatBinary
Debug.Print xlClipboardFormatBitmap
Debug.Print xlClipboardFormatCGM
Debug.Print xlClipboardFormatCSV
Debug.Print xlClipboardFormatDIF
Debug.Print xlClipboardFormatDspText
Debug.Print xlClipboardFormatEmbeddedObject
Debug.Print xlClipboardFormatEmbedSource
Debug.Print xlClipboardFormatLink
Debug.Print xlClipboardFormatLinkSource
Debug.Print xlClipboardFormatLinkSourceDesc
Debug.Print xlClipboardFormatMovie
Debug.Print xlClipboardFormatNative
Debug.Print xlClipboardFormatObjectDesc
Debug.Print xlClipboardFormatObjectLink
Debug.Print xlClipboardFormatOwnerLink
Debug.Print xlClipboardFormatPICT
Debug.Print xlClipboardFormatPrintPICT
Debug.Print xlClipboardFormatRTF
Debug.Print xlClipboardFormatScreenPICT
Debug.Print xlClipboardFormatStandardFont
Debug.Print xlClipboardFormatStandardScale
Debug.Print xlClipboardFormatSYLK
Debug.Print xlClipboardFormatTable
Debug.Print xlClipboardFormatText
Debug.Print xlClipboardFormatToolFace
Debug.Print xlClipboardFormatToolFacePICT
Debug.Print xlClipboardFormatVALU
Debug.Print xlClipboardFormatWK1
End Sub
WindowsXPなら、下記も参考になります。
http://www.atmarkit.co.jp/fwin2k/win2ktips/103cl …

この回答への補足

とりあえず対処療法的に下記のようにしましたが、
希望動作はしてくれるものの自信は全くありません。
よろしければアドバイスをお願いいたします・・・。
（ちなみにOn Errorステートメントを使用しない場合、エラーコードは1004です。）

Sub Value_Paste()

' Value_Paste Macro
' 値・テキストのみの貼り付け

On Error GoTo WSObj

'Excelからのコピーにのみ有効（Rangeオブジェクト用）
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False

Exit Sub

WSObj:

'Excel以外からのコピーにのみ有効 （Worksheetオブジェクト用）
ActiveSheet.PasteSpecial Format:="Unicode テキスト"

End Sub

補足日時：2010/03/12 00:21

この回答へのお礼

ご回答ありがとうございます。
ClipboardFormatsによる配列はこうやって調べられるんですね。
勉強になります。ただ、実はこれでイミディエイトに表示される値が
セルをコピーした状態（セルが点線点滅）だと「-1」一行のみなのですが
これはつまりクリップボードの中身が空？ということなのでしょうか。
また、試しにこのブラウザ上で「Sub test2()」という文字列をコピーして
エクセルに戻ってtest()を実行してみたところ、下記の4行が表示されました。
0
44
48
50
残念ながら私にはこれをどのように利用すれば良いか分からず・・・。
せっかくお返事いただいたのに活用しきれず申し訳ありません。

お礼日時：2010/03/11 23:44