View Single Post
 
Old 05-29-2024, 11:33 AM
p45cal's Avatar
p45cal p45cal is offline Windows 10 Office 2021
Expert
 
Join Date: Apr 2014
Posts: 956
p45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond repute
Default

Plagiarism alert:
see vba - Can I Get the Source Range Of Excel Clipboard Data? - Stack Overflow


I copied this from that website to a standard code module:
Code:
'https://officeaccelerators.wordpress.com/2013/11/27/reading-data-with-format-from-clipboard/
'https://social.msdn.microsoft.com/Forums/sqlserver/en-US/ee9e0d28-0f1e-467f-8d1d-1a86b2db2878/a-clipboard-object-for-vba-including-microsoft-word?forum=worddev

#If VBA7 And Win64 Then
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongLong) As Long
    Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare PtrSafe Function RegisterClipboardFormat Lib "user32.dll" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
    Private Declare PtrSafe Function GlobalLock Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As LongPtr) As Long
    Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
#Else
    Private Declare Function CloseClipboard Lib "user32" () As Long
    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 IsClipboardFormatAvailable 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 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 CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cbCopy As Long)
#End If

'test routine displays a message box with the marching ants range
'_2022_10_30
Function fTest_GetClipboardRange()
Dim rngClipboard As Range
    Set rngClipboard = fGetClipboardRange
    If rngClipboard Is Nothing Then
        MsgBox ("No Excel range was found on the clipboard.")
    ElseIf Application.CutCopyMode = xlCopy Then 'this is always copy because of sheet add
        MsgBox (fGetClipboardRange.Address & " has been copied to the clipboard.")
    ElseIf Application.CutCopyMode = xlCut Then
        MsgBox (fGetClipboardRange.Address & " has been cut to the clipboard.")
    End If
End Function

'reads excel copy-paste range from the clipboard and returns range object or nothing if not found
'_2022_03_19
Function fGetClipboardRange() As Range  'get excel copy or cut range from clipboard
Dim strClipboard As String  'raw clipboard data
Dim arrClipboard() As String    'parse into an array
    Set fGetClipboardRange = Nothing    'default is nothing
    
    strClipboard = fGetClipboardData("link")    'get the link data string
    If strClipboard = "" Then Exit Function 'done if it's empty
    arrClipboard = Split(strClipboard, Chr(0))  'else parse at null characters
    If arrClipboard(0) <> "Excel" Then Exit Function    'excel should be first
    strClipboard = "'" & arrClipboard(1) & "'!" & arrClipboard(2)   'parse the range from the others
    strClipboard = Application.ConvertFormula(strClipboard, xlR1C1, xlA1)   'convert to a1 style
    Set fGetClipboardRange = Range(strClipboard)    'range needs a1 style

End Function

'read clipboard for specified format into string or null string
'_2022_03_19
Function fGetClipboardData(strFormatId As String) As String 'read clipboard into string
#If VBA7 And Win64 Then
    Dim hMem As LongPtr 'memory handle
    Dim lngPointer As LongPtr   'memory pointer
#Else
    Dim hMem As Long 'memory handle
    Dim lngPointer As Long   'memory pointer
#End If
Dim arrData() As Byte   'clipboard reads into this array
Dim lngSize As Long 'size on clipboard
Dim lngFormatId As Long 'id number, for format name
    fGetClipboardData = ""  'default

    lngFormatId = fGetClipboardFormat(strFormatId)  'get format
    If lngFormatId <= 0 Then Exit Function  'zero if format not found

    CloseClipboard  'in case clipboard is open
    If CBool(OpenClipboard(0)) Then 'open clipboard
        hMem = GetClipboardData(lngFormatId)    'get memory handle
        If hMem > 0 Then    'if there's a handle
            lngSize = CLng(GlobalSize(hMem))    'get memory size
            If lngSize > 0 Then 'if we know the size
                lngPointer = GlobalLock(hMem)   'get memory pointer
                If lngPointer > 0 Then  'make sure we have the pointer
                    ReDim arrData(0 To lngSize - 1) 'size array
                    CopyMemory arrData(0), ByVal lngPointer, lngSize    'data from pointer to array
                    fGetClipboardData = StrConv(arrData, vbUnicode) 'convert array to string
                End If
                GlobalUnlock hMem   'unlock memory
            End If
        End If
    End If
    CloseClipboard  'don't leave the clipboard open
    
End Function

'return format number form format number, format number from format name or 0 for not found
'_2022_03_19
Function fGetClipboardFormat(strFormatId As String) As Long 'verify, or get format number from format name
Dim lngFormatId As Long 'format id number
    fGetClipboardFormat = 0 'default false

    If IsNumeric(strFormatId) Then  'for format number
        lngFormatId = CLng(strFormatId) 'use number for built in format
        CloseClipboard  'in case clipboard is already open
        If CBool(OpenClipboard(0)) = False Then 'done if can't open clipboard
        ElseIf CBool(IsClipboardFormatAvailable(lngFormatId)) = True Then   'true if format number found
            fGetClipboardFormat = lngFormatId   'return format number
        End If
        CloseClipboard  'don't leave the clipboard open
    Else
        lngFormatId = RegisterClipboardFormat(strFormatId & Chr(0)) 'else get number from format name
        If (lngFormatId > &HC000&) Then fGetClipboardFormat = lngFormatId   'if valid return format number
    End If

 End Function
and this in another module:

Code:
Sub blah()
MsgBox fGetClipboardRange.Address(external:=True)

'or:

Set myrng = fGetClipboardRange
MsgBox "'" & myrng.Parent.Name & "'!" & myrng.Address(0, 0)
Selection.Formula2 = "=" & "'" & myrng.Parent.Name & "'!" & myrng.Address(0, 0)
'also:
'Selection.Formula2 = "=" & fGetClipboardRange.Address(external:=True)
End Sub
It seems to put non-contiguous ranges into a single range containing all of them.
It will complain if the copied item isn't a range.
Reply With Quote