こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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

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

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

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

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

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

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

投稿日時 - 2010-03-11 19:15:09

QNo.5744014

困ってます

質問者が選んだベストアンサー

ついでに 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

投稿日時 - 2010-03-12 02:52:07

お礼

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

投稿日時 - 2010-03-12 10:34:45

このQ&Aは役に立ちましたか?

5人が「このQ&Aが役に立った」と投票しています

回答(3)

ANo.2

本質問の回答としては、#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 02:33:50

お礼

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

投稿日時 - 2010-03-12 10:28:57

ANo.1

エクセル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/103clipbook/103clipbook.html

投稿日時 - 2010-03-11 23:16:07

補足

とりあえず対処療法的に下記のようにしましたが、
希望動作はしてくれるものの自信は全くありません。
よろしければアドバイスをお願いいたします・・・。
(ちなみに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:28

お礼

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

投稿日時 - 2010-03-11 23:44:39

あなたにオススメの質問