ExcelのVBA内で、Copy中のセルのアドレスを知る方法 (ID:102032)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

自己レスです

こんな感じでできました。
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

←解決時は質問者本人がここをチェックしてください。

戻る