ExcelのVBA内で、Copy中のセルのアドレスを知る方法

takana 2009-10-20 20:43:24 No: 102026 IP: 192.*.*.*

ExcelのVBAでアドインを作成しているのですが、
Excelのセルを選んでCtrl+Cを押した状態の時、
そのコピーの対象となるセルを特定したいのですが、何か良い方法はありませんか？

まず、Application.CutCopyModeプロパティで、Ctrl+Cを押した状態かどうか判定し、Application.CutCopyMode=xlCopyであれば、そのセルを知りたいのです。

編集削除

魔界の仮面弁士 2009-10-20 22:04:40 No: 102027 IP: 192.*.*.*

うーん。これが VB6 であれば、
  Dim s As String
  s = Clipboard.GetText(vbCFLink)
というコードで、
  s = "Excel|[Book1]Sheet1.R3C2:R9C5"
  s = "Excel|[C:\Folder\Book1.xls]シート名.R1C1:R2C2"
などのデータを得られるので、そこから判断する事も出来るのですけれども。

Excel VBA の場合、手軽な方法が思いつかないのですが、
クリップボード系の API で CF_LINK のデータを取得すると、
  s = "Excel" & vbNullChar & "[Book1]Sheet1.R3C2:R9C5" & String(2, 0)
とか、
  s = "Excel" & vbNullChar & "[C:\Folder\Book1.xls]シート名.R1C1:R2C2" & String(2, 0)
といった文字列が得られるので、そこから判断するとか。

編集削除

takana 2009-10-21 22:37:28 No: 102028 IP: 192.*.*.*

魔界の仮面弁士さん回答ありがとうございます。
CF_LINKは
Const CF_LINK = &HBF00
ですよね？

エクセルのセルをコピーした状態で、クリップボード形式に
&HBF00は格納されていないようなのですが？

編集削除

魔界の仮面弁士 2009-10-22 00:46:41 No: 102029 IP: 192.*.*.*

当方の
Excel 2007 + Windows XP Professional Edition
Excel 2003 + Windows XP Media Center Edition 2005
の組み合わせでそれぞれ確認してみたところ、コピー時に
CF_LINK の存在が確認できました。そちらの環境は何ですか?

また、Clipbrd.exe を起動した状態で、適当なセルを選択して
Ctrl + C してみると、クリップブックの[表示]メニューに
"Link" 形式の存在を確認できました。
# フリーソフトの CLCL で確認した場合にも同様。

編集削除

魔界の仮面弁士 2009-10-22 01:00:17 No: 102030 IP: 192.*.*.*

CF_LINK の中身を取り出すとなると、API が必要になりますが、
存在確認だけならば、下記のようにして判断できます。

Ctrl + C でセルをコピーした状態で下記のコードを実行した場合、
どのように表示されますか?

Dim formats() As Variant
formats = Application.ClipboardFormats
If formats(1) = -1 Then
    MsgBox "クリップボードは空です。"
    Exit Sub
End If
Dim fmt As Variant
For Each fmt In formats
    If fmt = XlClipboardFormat.xlClipboardFormatLink Then
        MsgBox "CF_LINK 形式が見つかりました。"
        Exit Sub
    End If
Next
MsgBox "CF_LINK が見つかりません。"

# 中身を MSForms.DataObject で取得できれば楽なのだけれども。

編集削除

takana 2009-10-22 23:52:30 No: 102031 IP: 192.*.*.*

魔界の仮面弁士さん
回答ありがとうございます。

紹介していいただいたコードを実行したところ
"CF_LINK 形式が見つかりました。"となりました。
Clipbrd.exe にも"Link" 形式の存在を確認できました。
ただ、APIで取り出すのは、敷居が高そうです。

ちなみに、VB6で
MsgBox vbCFLink
とすると中身はなにがはいっているのですか？

編集削除

takana 2009-10-23 23:57:54 No: 102032 IP: 192.*.*.*

自己レスです

こんな感じでできました。
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByRef lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As String, ByVal lpUsedDefaultChar As Long) As Long
Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByRef lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar 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 EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long

Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (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)

Public Function GetCopyAddress() As String
    Dim i          As Long
    Dim lngFormat  As Long
    Dim hMem       As Long
    Dim p          As Long
    Dim strData()  As Byte
    Dim lngSize    As Long
    Dim strAddress As String

    Call OpenClipboard(0)
    hMem = GetClipboardData(RegisterClipboardFormat("Link"))
    If hMem = 0 Then
        Call CloseClipboard
        Exit Function
    End If

    lngSize = GlobalSize(hMem)
    p = GlobalLock(hMem)
    ReDim strData(0 To lngSize - 1)
    Call MoveMemory(VarPtr(strData(0)), p, lngSize)
    Call GlobalUnlock(hMem)

    Call CloseClipboard

    For i = 0 To lngSize - 1
        If strData(i) = 0 Then
            strData(i) = Asc(" ")
        End If
    Next i

    GetCopyAddress = AnsiToUnicode(strData())

    MsgBox GetCopyAddress

End Function

Private Function AnsiToUnicode(ByRef strAnsi() As Byte) As String
On Error GoTo ErrHandler
    Dim lngSize   As Long
    Dim strBuf    As String
    Dim lngBufLen As Long
    Dim lngRtnLen As Long

    lngSize = UBound(strAnsi) + 1
    lngBufLen = lngSize * 2 + 10
    strBuf = String$(lngBufLen, vbNullChar)
    lngRtnLen = MultiByteToWideChar(0, 0, strAnsi(0), lngSize, StrPtr(strBuf), lngBufLen)
    If lngRtnLen > 0 Then
        AnsiToUnicode = Left$(strBuf, lngRtnLen)
    End If
ErrHandler:
End Function

編集削除