Which Range is currently being Cut or Copied ?

[Jaafar Tribak]

Hi dear forum members,

I have a vba situation where I need to know the address of the range that is currently being copied (or cut) ie: when Application.CutCopyMode <> 0 .

I wonder if I am overlooking some easy solution or missing something obvious.

Regards.

 

[shknbk2]

It doesn't appear to be possible. Lots of other questions asking the same thing.

https://www.excelforum.com/excel-programming-vba-macros/1213141-get-marching-ants-range.html

https://stackoverflow.com/questions...rn-the-location-of-the-marching-ants-in-excel

However, if there is a solution, that might be handy someday.

 

[Jaafar Tribak]

It doesn't appear to be possible. Lots of other questions asking the same thing.

https://www.excelforum.com/excel-programming-vba-macros/1213141-get-marching-ants-range.html

https://stackoverflow.com/questions...rn-the-location-of-the-marching-ants-in-excel

However, if there is a solution, that might be handy someday.

Wow!! I never thought this question was asked so many times before .

Thanks for the links.

I'll take the Windows API route and see if that will offer a solution.

 

[Jaafar Tribak]

This worked for me :

In a Standard Module:

Option Explicit

#If  VBA7 Then
    Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
    Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
#Else
    Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Declare Function CloseClipboard Lib "user32" () As Long
    Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
    Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
#End  If



Function GetCutCopyRange() As Range
    #If  VBA7 Then
        Dim hClipMem As LongPtr, lMemSize As LongPtr, lMemPtr As LongPtr
    #Else
        Dim hClipMem As Long, lMemSize As Long, lMemPtr As Long
    #End  If
   
    Const CF_LINK = &HC215&
    Dim bytBuffer() As Byte
    Dim oSheet As Worksheet
    Dim sClipLinkString As String, sRangeAddr As String, sSheetName As String, sWbookName As String
 
    On Error GoTo errHandler
    DoEvents
    If OpenClipboard(0) Then
        hClipMem = GetClipboardData(CF_LINK)
        If hClipMem Then lMemSize = GlobalSize(hClipMem)
        If lMemSize Then lMemPtr = GlobalLock(hClipMem)
        If lMemPtr Then
            ReDim bytBuffer(0 To CLng(lMemSize) - 1) As Byte
            Call CopyMemory(bytBuffer(0), ByVal lMemPtr, lMemSize)
            sClipLinkString = strConv(bytBuffer, vbUnicode)
            sClipLinkString = Right(sClipLinkString, Len(sClipLinkString) - InStrRev(sClipLinkString, "[") + 1)
            sClipLinkString = Replace(sClipLinkString, vbNullChar & vbNullChar, "")
            sRangeAddr = Split(sClipLinkString, vbNullChar)(1)
            sRangeAddr = Application.ConvertFormula(sRangeAddr, xlR1C1, xlA1)
            sSheetName = Split(Split(sClipLinkString, vbNullChar)(0), "]")(1)
            sWbookName = Split(Split(sClipLinkString, vbNullChar)(0), "]")(0) & "]"
            sWbookName = Replace(Replace(sWbookName, "[", ""), "]", "")
            Set oSheet = CallByName(Workbooks(sWbookName).Sheets, "Item", VbGet, sSheetName)
            Set GetCutCopyRange = CallByName(oSheet, "Range", VbGet, sRangeAddr)
            Call GlobalUnlock(hClipMem)
        End If
        Call CloseClipboard
    End If
   
errHandler:
    Call GlobalUnlock(hClipMem)
    Call CloseClipboard

End Function

Usage example:

Sub Test()

    Dim oCutCopyRange As Range
    Dim sCutOrCopied As String
   
    Set oCutCopyRange = GetCutCopyRange
   
    If Not oCutCopyRange Is Nothing Then
        sCutOrCopied = IIf(Application.CutCopyMode = xlCopy, "Copied", "Cut")
        sCutOrCopied = "Range being " & sCutOrCopied & ":" & vbNewLine
        MsgBox sCutOrCopied & oCutCopyRange.Address(, , , True)
    Else
        MsgBox "No range to cut or copy"
    End If

End Sub

One issue with the above function is that it gives erronous results whith non-contiguous ranges because Excel copies the whole range and doesn't adjust the copied range until the data is actually pasted.

For example:
If you copy the non-contiguous range A1:A2,E1:E2, excel copies A1:E2 to the clipboard and so the GetCutCopyRange function returns the wrong range.

Not sure how to work around this problem.

 

[Fazza]

greetings, Jaafar
What about pasting a copy to a temporary worksheet?
Interrogate it to check for contiguous or not ranges. Delete worksheet when done.
regards, Fazza

 

[Jaafar Tribak]

greetings, Jaafar
What about pasting a copy to a temporary worksheet?
Interrogate it to check for contiguous or not ranges. Delete worksheet when done.
regards, Fazza

Thanks for your recommendation.

I actually had thought about a similar workaround but in addition to that being a rustic fix, perhaps the main issue is the fact that when pasting a non-contiguous range, excel joins the parts of the copied range into a single block.- This makes it impossible to extrapolate the relative position of the rows and columns that is necessary to work out the exact address of the range being copied.

Regards.

 

[Fazza]

I can imagine this being flaky, but.. any chance of looping through the copied information & matching up the contents against the source cells?
I think that even for you very simple example A1:A2, E1:E2 it would not be robust/reliable.

 

[Jaafar Tribak]

I can imagine this being flaky, but.. any chance of looping through the copied information & matching up the contents against the source cells?
I think that even for you very simple example A1:A2, E1:E2 it would not be robust/reliable.

Wouldn't that also require knowing the address of the source cells beforehand which is what we are actually trying to figure out in the first place ?

Excel provides no event for when the user performs a range Cut\Copy operation even the sheet change event doesn't fire when making a range copy... The Sheet Selection change won't help with this either.

If there was such an event, the problem with non-contigious ranges would be easy to solve.

I have an idea that might work and that is hooking the CommandBras event and checking in it the value of the clipboard sequence number which changes everytime a cut or copy operation is carried out.

I'll post the code when I finish testing it.

Regards.

 

[Jaafar Tribak]

Ok- Finally, I seem to have managed to get through this by detecting the change in the clipboard serial number within the commandbars OnUpdate event and so far, the code seems very robust.

The GetCutCopyRange function now works with contigious as well as non-contigious ranges


Workbook example


1- Code in the ThisWorkbook Module:

Option Explicit

Private WithEvents CmndBrs As CommandBars

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Declare PtrSafe Function GetClipboardSequenceNumber Lib "user32" () As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Declare Function GetClipboardSequenceNumber Lib "user32" () As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If


Private Sub Workbook_Activate()
    Call SetCommandBarsHook
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Call SetCommandBarsHook
End Sub

Private Sub SetCommandBarsHook()

    If CmndBrs Is Nothing Then
        With Application
            .CutCopyMode = 0
            .CommandBars.FindControl(ID:=128).Tag = _
            .ActiveWindow.RangeSelection.Address(False, False, , True) & "|" & GetClipboardSequenceNumber
            Set CmndBrs = .CommandBars
        End With
    End If

End Sub


Private Sub CmndBrs_OnUpdate()

    Dim sCutOrCopiedRangeAddr() As String
    
    With Application
        If TypeName(.Selection) = "Range" Then
            sCutOrCopiedRangeAddr = Split(.CommandBars.FindControl(ID:=128).Tag, "|")
            If sCutOrCopiedRangeAddr(1) <> GetClipboardSequenceNumber And .CutCopyMode <> 0 Then
                .CommandBars.FindControl(ID:=128).Tag = _
                .ActiveWindow.RangeSelection.Address(False, False, , True) & "|" & GetClipboardSequenceNumber
                sCutOrCopiedRangeAddr = Split(.CommandBars.FindControl(ID:=128).Tag, "|")
            End If
        End If
    End With

End Sub

Usage Example
2- Code in a Standard Module:

Option Explicit

Sub Test()

    Dim oCutCopyRange As Range
    Dim sCutOrCopyOperation As String

    Set oCutCopyRange = GetCutCopyRange

    If Not oCutCopyRange Is Nothing Then
        sCutOrCopyOperation = IIf(Application.CutCopyMode = xlCopy, "Copied", "Cut")
        sCutOrCopyOperation = "Range being *" & sCutOrCopyOperation & "*" & Chr(32) & ":" & vbNewLine & vbNewLine
        MsgBox sCutOrCopyOperation & oCutCopyRange.Address(False, False, , True)
    Else
        MsgBox "No range being cut or copied !", vbCritical
    End If

End Sub



Function GetCutCopyRange() As Range

    Dim sCutOrCopiedRangeAddr() As String
    
    If Application.CutCopyMode <> 0 Then
        sCutOrCopiedRangeAddr = Split(Application.CommandBars.FindControl(ID:=128).Tag, "|")
        Set GetCutCopyRange = Range(sCutOrCopiedRangeAddr(0))
    End If

End Function

 

[Fazza]

You're a Champion, Jaafar