VBA クリップボードの値を取得する方法(API) 64Bit対応版 - Excel

それでは、標準モジュールを開いて以下のソースをコピペしてください。

Option Explicit

#If VBA7 And Win64 Then
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function MoveMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
#Else
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd 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 CloseClipboard Lib "user32" () As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock 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)
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
#End If

'**
' コピーアドレスの取得
'**
Public Function GetCopyAddress(SheetName As String) As String
On Error GoTo ErrHandler
    
    Dim i As Long
    Dim Format As Long
    Dim Data() As Byte
    Dim Address As String
#If VBA7 And Win64 Then
    Dim hMem As LongPtr
    Dim Size As LongPtr
    Dim p As LongPtr
#Else
    Dim hMem As Long
    Dim Size As Long
    Dim p As Long
#End If
    
    Call OpenClipboard(0)
    hMem = GetClipboardData(RegisterClipboardFormat("Link"))
    If hMem = 0 Then
        Call CloseClipboard
        Exit Function
    End If
    
    Size = GlobalSize(hMem)
    p = GlobalLock(hMem)
    ReDim Data(0 To CLng(Size) - CLng(1))
#If VBA7 And Win64 Then
    Call MoveMemory(Data(0), ByVal p, Size)
#Else
    Call MoveMemory(CLng(VarPtr(Data(0))), p, Size)
#End If
    Call GlobalUnlock(hMem)
    
    Call CloseClipboard
    
    For i = 0 To CLng(Size) - CLng(1)
        If Data(i) = 0 Then
            Data(i) = Asc(" ")
        End If
    Next i
    
    Address = StrConv(Data, vbUnicode)
Debug.Print "Address: " + Address
    If InStr(Address, "]" & SheetName) <> 0 Then
        GetCopyAddress = Trim(Replace(Mid(Address, InStr(Address, "]" & SheetName)), "]" & SheetName, ""))
    Else
        GetCopyAddress = ""
    End If
    Exit Function
    
ErrHandler:
    Call CloseClipboard
    GetCopyAddress = ""
End Function

次に、シートの Worksheet_SelectionChange に以下のソースを記述します。

Option Explicit

'**
' ワークシート選択変更
'**
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Cells As String
    Dim CopyRange As Range
    ' コピーモードの場合
    If Application.CutCopyMode = xlCopy Then
        ' セルを取得
        Cells = GetCopyAddress(Me.Name)
Debug.Print "### コピーされたセル ###"
Debug.Print "R1C1形式: " & Cells
        ' R1C1形式からA1形式に変換
        Set CopyRange = Range(Application.ConvertFormula(Cells, xlR1C1, xlA1))
Debug.Print "A1形式: " & CopyRange.Address
    End If
End Sub

画像のようにセルに値を埋めてコピーし、セルを移動してみてください。

結果は以下のようになります。

### コピーされたセル ###
R1C1形式: R1C1:R5C3
A1形式: $A$1:$C$5

・Share the Clipboard with VBA and the Windows API Francesco Foti's weblog

http://francescofoti.com/2013/12/11/share-the-clipboard-with-vba-and-the-windows-api/

VBAでAPIを利用してクリップボードの値を取得する方法を紹介しました。

このように、既存の 32Bit版 で作られた VBA プログラムは、その多くが 64Bit 版では動作しません。64Bit 版の Office を導入する際は、よく検討することが必要となります。