'//Persistent ClibBorad Content for excel.
'//Tested on Office2010 x64Bit/Win x64.
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongLong) As Long
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongLong) As LongPtr
Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
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" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#Else
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
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 GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#End If
Private bCellCut As Boolean
Private sClipBrdLinkData As String
Private vFirstCellVal As String
Private vLastCellVal As String
Private WithEvents oCmndBars As CommandBars
Private Sub Workbook_Open()
Set oCmndBars = Application.CommandBars
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
With Target
If Not IsError(.Cells(1, 1).Value) And Not IsError(.Cells(.Rows.Count, .Columns.Count).Value) Then
If (.Cells(1, 1).Value <> vFirstCellVal) And _
(.Cells(.Rows.Count, .Columns.Count).Value <> vLastCellVal) Then bCellCut = True Else bCellCut = False
End If
End With
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Set oCmndBars = Application.CommandBars
With Target
If Not IsError(.Cells(1, 1).Value) And Not IsError(.Cells(.Rows.Count, .Columns.Count).Value) Then
vFirstCellVal = .Cells(1, 1).Value
vLastCellVal = .Cells(.Rows.Count, .Columns.Count).Value
End If
End With
End Sub
Private Sub oCmndBars_OnUpdate()
Static lCopyCutMode As XlCutCopyMode
Dim oCopyCutRange As Range
Dim lFormatID As Long
If (GetAsyncKeyState(VBA.vbKeyEscape) <> 0) Then
sClipBrdLinkData = ""
Exit Sub
End If
lFormatID = RegisterClipboardFormat("Link" & Chr$(0))
Set oCopyCutRange = GetCopyCutRange(ClipBoard_GetLinkData(lFormatID))
If Not oCopyCutRange Is Nothing Then
If Application.CutCopyMode = 0 Then
If lCopyCutMode = xlCut And bCellCut Then oCopyCutRange.Clear: sClipBrdLinkData = "": _
Application.CutCopyMode = 0: Exit Sub
If lCopyCutMode = xlCopy Then oCopyCutRange.Copy Else oCopyCutRange.Cut
End If
End If
lCopyCutMode = Application.CutCopyMode
End Sub
Private Function ClipBoard_GetLinkData(wFormat As Long) As String
#If VBA7 Then
Dim hData As LongPtr
Dim lByteLen As LongPtr
Dim lPointer As LongPtr
Dim lSize As LongLong
#Else
Dim hData As Long
Dim lByteLen As Long
Dim lPointer As Long
Dim lSize As Long
#End If
Dim lRet As Long
Dim arData() As Byte
lRet = OpenClipboard(0)
If lRet > 0 Then
If IsClipboardFormatAvailable(wFormat) Then
hData = GetClipboardData(wFormat)
If hData <> 0 Then
lByteLen = GlobalSize(hData)
lSize = GlobalSize(hData)
lPointer = GlobalLock(hData)
If lSize > 0 Then
ReDim arData(0 To CLng(lSize) - CLng(1)) As Byte
CopyMemory arData(0), ByVal lPointer, lSize
GlobalUnlock hData
sClipBrdLinkData = StrConv(arData, vbUnicode)
End If
End If
End If
CloseClipboard
End If
ClipBoard_GetLinkData = sClipBrdLinkData
End Function
Private Function GetCopyCutRange(ByVal ClipLinkData As String) As Range
Dim sWbk As String, sWsh As String, sRangeAddr As String
Dim arRowsCols() As String, sRangeRows As String
Dim lTopLeftRow As Long, lTopLeftCol As Long
Dim lBottomRightRow As Long, lBottomRightCol As Long
Dim i As Integer
Dim oCopyCutRange As Range
On Error Resume Next
If InStrRev(ClipLinkData, Chr$(0) & "L", -1) Then
Mid(ClipLinkData, InStrRev(ClipLinkData, Chr$(0) & "L"), 2) = Chr$(0) & "R"
Mid(ClipLinkData, InStrRev(ClipLinkData, ":L"), 2) = ":" & "R"
End If
sWbk = Mid(ClipLinkData, InStr(ClipLinkData, "[") + 1, InStrRev(ClipLinkData, "]") - 1 - InStr(ClipLinkData, "["))
sWsh = Mid(ClipLinkData, InStr(ClipLinkData, "]") + 1, InStrRev(ClipLinkData, Chr$(0) & "R") - 1 - InStr(ClipLinkData, "]"))
sRangeAddr = Mid(ClipLinkData, InStrRev(ClipLinkData, Chr$(0) & "R") + 1, Len(ClipLinkData))
arRowsCols = Split(sRangeAddr, ":")
For i = 0 To UBound(arRowsCols)
sRangeRows = Left(arRowsCols(i), InStr(arRowsCols(i), "C") - 1)
If i = 0 Then
lTopLeftRow = Replace(sRangeRows, "R", "")
lTopLeftCol = Right(arRowsCols(i), Len(arRowsCols(i)) - InStr(arRowsCols(i), "C"))
Set oCopyCutRange = Cells(lTopLeftRow, lTopLeftCol)
Else
lBottomRightRow = Replace(sRangeRows, "R", "")
lBottomRightCol = Right(arRowsCols(i), Len(arRowsCols(i)) - InStr(arRowsCols(i), "C"))
Set oCopyCutRange = Range(Cells(lTopLeftRow, lTopLeftCol), Cells(lBottomRightRow, lBottomRightCol))
End If
Next
Set GetCopyCutRange = Workbooks(sWbk).Worksheets(sWsh).Range(oCopyCutRange.Address)
End Function
