BeforePaste event ... Does it work for you ?

[Jaafar Tribak]

Hi everybody,

Workbook Example

I have been working on this for a few days until I have arrived at this piece of coding.

Basically, what the code does is to intercept the pasting operation BEFORE the clipboard data actually reaches the worksheet cells which allows the user to conviniently decide what to do before the pasting takes place.

This BeforePaste pseudo-event takes the following signature :

Public Sub Application_SheetBeforePaste( _
ByVal CutCopyRange As Range, _
ByVal PasteRange As Range, _
ByVal ClipboardFormat As Long, _
ByRef PasteSpecialType As XlPasteType, _
ByRef Cancel As Boolean _
)

The Byref arguments (PasteSpecialType and Cancel) allows for the handling of the Paste operation.

One serious limitation of this code is that if the user pastes the data using Paste Special the event is not fired ! am still looking into this issue

I am not sure how stable the code is or if the code will work on other 32 bit systems .. I will be really interested to know if it works for you guys and if you found other problems other than the ones I mentioned (For 64bit OS the API declarations will need to be changed)

1- Code in a Standard Module :

'-----------------------------------------------------------------------|
'An attempt to create a Pseudo Before Paste event for excel worksheets  |
'LIMITATIONS: the paste event doesn't fire with paste special           |
'             pasting data into excel from outside excel not working    |
'                                                                       |
' Written by jaafar tribak written on 20/03/2015                        |
'-----------------------------------------------------------------------|
Option Explicit

Private Declare Function VirtualProtect Lib "kernel32" ( _
            lpAddress As Any, _
            ByVal dwSize As Long, _
            ByVal flNewProtect As Long, _
            lpflOldProtect As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
            pDest As Any, _
            pSource As Any, _
            ByVal dwLength As Long)

Private Declare Function GetProcAddress Lib "kernel32" ( _
            ByVal hModule As Long, _
            ByVal lpProcName As String) As Long

Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" ( _
            ByVal lpModuleName As String) As Long

Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" ( _
            ByVal idHook As Long, _
            ByVal lpfn As Long, _
            ByVal hmod As Long, _
            ByVal dwThreadId As Long) As Long
 
Private Declare Function UnhookWindowsHookEx Lib "user32" ( _
            ByVal hHook As Long) As Long
 
Private Declare Function CallNextHookEx Lib "user32" ( _
            ByVal hHook As Long, _
            ByVal ncode As Long, _
            ByVal wParam As Long, _
            lParam As Any) As Long

Private Declare Function GetCurrentThreadId Lib "kernel32.dll" () As Long

Private Declare Function SetClipboardViewer Lib "user32" ( _
            ByVal hwnd As Long) As Long

Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" ( _
            ByVal dwExStyle As Long, _
            ByVal lpClassName As String, _
            ByVal lpWindowName As String, _
            ByVal dwStyle As Long, _
            ByVal x As Long, _
            ByVal y As Long, _
            ByVal nWidth As Long, _
            ByVal nHeight As Long, _
            ByVal hWndParent As Long, _
            ByVal hMenu As Long, _
            ByVal hInstance As Long, _
            lpParam As Any) As Long

Private Declare Function DestroyWindow Lib "user32" ( _
            ByVal hwnd As Long) As Long

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
            ByVal hwnd As Long, _
            ByVal nIndex As Long, _
            ByVal dwNewLong As Long) As Long

Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" ( _
            ByVal lpPrevWndFunc As Long, _
            ByVal hwnd As Long, _
            ByVal Msg As Long, _
            ByVal wParam As Long, _
            ByVal lParam As Long) As Long

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
            ByVal hwnd As Long, _
            ByVal wMsg As Long, _
            ByVal wParam As Long, _
            lParam As Any) As Long

Private Declare Function SetProp Lib "user32" Alias "SetPropA" ( _
            ByVal hwnd As Long, _
            ByVal lpString As String, _
            ByVal hData As Long) As Long

Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" ( _
            ByVal hwnd As Long, _
            ByVal lpString As String) As Long

Private Declare Function GetProp Lib "user32" Alias "GetPropA" ( _
            ByVal hwnd As Long, _
            ByVal lpString As String) As Long
            
Private Declare Function GetActiveWindow Lib "user32" () As Long


Private Const PAGE_EXECUTE_READWRITE = &H40&
Private Const GWL_WNDPROC = (-4)
Private Const HCBT_ACTIVATE = 5
Private Const WH_CBT = 5
Private Const WM_DRAWCLIPBOARD = &H308
Private Const WM_CLOSE = &H10

Private btOldAsmGetClipData(4) As Byte
Private oCopyRange As Range
 
 
Sub InstallHook()
    If GetProp(Application.hwnd, "GetClipDataFncAddr") = 0 Then
        Call HookFnc("user32", "GetClipboardData", AddressOf PasteCallback)
        Call CreateClipBoardWatcherWindow
    End If
End Sub

Sub UnInstallHook()
    SetWindowLong GetProp(Application.hwnd, "HiddenWnd"), _
    GWL_WNDPROC, GetProp(Application.hwnd, "PrevProcAddr")
    UnhookFunc "GetClipboardData"
    UnhookWindowsHookEx GetProp(Application.hwnd, "hHook")
    DestroyWindow GetProp(Application.hwnd, "HiddenWnd")
    RemoveProp Application.hwnd, "PrevProcAddr"
    RemoveProp Application.hwnd, "HiddenWnd"
    RemoveProp Application.hwnd, "hHook"
    RemoveProp Application.hwnd, "GetClipDataFncAddr"
    Set oCopyRange = Nothing
End Sub

Private Sub CreateClipBoardWatcherWindow()
    Dim lHiddenWnd As Long
    
    lHiddenWnd = CreateWindowEx(0, "Static", _
    vbNullString, 0, 0, 0, _
    1, 1, 0, 0, 0, 0)
    SetProp Application.hwnd, "HiddenWnd", lHiddenWnd
    SetClipboardViewer lHiddenWnd
    SubClassClipBoardWatcherWindow lHiddenWnd
End Sub

Private Sub SubClassClipBoardWatcherWindow(ByVal hwnd As Long)
    Dim lPrevProcAddr As Long

    lPrevProcAddr = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf ClipBoardWindowCallback)
    SetProp Application.hwnd, "PrevProcAddr", lPrevProcAddr
End Sub

Private Sub UnSubClassClipBoardWatcherWindow(ByVal hwnd As Long)
    SetWindowLong hwnd, _
    GWL_WNDPROC, GetProp(Application.hwnd, "PrevProcAddr")
End Sub

Private Function ClipBoardWindowCallback _
(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    On Error Resume Next
    If TypeName(Selection) <> "Range" Or GetActiveWindow <> Application.hwnd Then
        UnhookFunc "GetClipboardData": Set oCopyRange = Nothing
        Call RemoveProp(Application.hwnd, "GetClipDataFncAddr"): Exit Function
    Else
        If GetProp(Application.hwnd, "GetClipDataFncAddr") = 0 Then
            Call HookFnc("user32", "GetClipboardData", AddressOf PasteCallback)
        End If
    End If
    Select Case uMsg
        Case Is = WM_DRAWCLIPBOARD
            Set oCopyRange = Selection
    End Select
    ClipBoardWindowCallback = _
    CallWindowProc(GetProp(Application.hwnd, "PrevProcAddr"), hwnd, uMsg, wParam, lParam)
End Function

Private Sub DisableClipBoardWarning()
    Dim lhHook As Long

    UnhookWindowsHookEx GetProp(Application.hwnd, "hHook")
    lhHook = SetWindowsHookEx _
    (WH_CBT, AddressOf StopClipBoardWarningHookCallBack, 0, GetCurrentThreadId)
    SetProp Application.hwnd, "hHook", lhHook
End Sub

Private Function StopClipBoardWarningHookCallBack _
(ByVal idHook As Long, ByVal wParam As Long, lParam As Long) As Long
    If idHook = HCBT_ACTIVATE Then
        Call SendMessage(wParam, WM_CLOSE, 0, 0)
        UnhookWindowsHookEx GetProp(Application.hwnd, "hHook")
    End If
    StopClipBoardWarningHookCallBack = _
    CallNextHookEx(GetProp(Application.hwnd, "hHook"), idHook, ByVal wParam, ByVal lParam)
End Function

Private Sub HookFnc(ByVal module As String, ByVal fnc As String, ByVal NewAddr As Long)
    Dim hModule As Long
    Dim hFnc As Long
    
    hModule = GetModuleHandle(module)
    If hModule = 0 Then Exit Sub
    hFnc = GetProcAddress(hModule, fnc)
    If hFnc = 0 Then Exit Sub
    SetProp Application.hwnd, "GetClipDataFncAddr", hFnc
    If Not GetMem(hFnc, VarPtr(btOldAsmGetClipData(0)), UBound(btOldAsmGetClipData) + 1) Then
        Exit Sub
    End If
    Call Redirect(hFnc, NewAddr)
End Sub

Private Sub UnhookFunc(ByVal fnc As String)
   Call PutMem(GetProp(Application.hwnd, "GetClipDataFncAddr"), _
   VarPtr(btOldAsmGetClipData(0)), UBound(btOldAsmGetClipData) + 1)
End Sub

Private Function Redirect(ByVal OldAddr As Long, ByVal NewAddr As Long) As Boolean
    Dim btAsm(4)    As Byte
    Dim lngNewAddr  As Long
    
    lngNewAddr = NewAddr - OldAddr - (UBound(btAsm) + 1)
    btAsm(0) = &HE9                     ' JMP near
    CopyMemory btAsm(1), lngNewAddr, 4   ' rel. addr
    Redirect = PutMem(OldAddr, VarPtr(btAsm(0)), UBound(btAsm) + 1)
End Function

Private Function GetMem(ByVal lpAddr As Long, ByVal pData As Long, ByVal dlen As Long) As Boolean
    Dim lngOldProtect As Long
    
    If 0 = VirtualProtect(ByVal lpAddr, dlen, PAGE_EXECUTE_READWRITE, lngOldProtect) Then
        Exit Function
    End If
    CopyMemory ByVal pData, ByVal lpAddr, dlen
    VirtualProtect ByVal lpAddr, dlen, lngOldProtect, lngOldProtect
    GetMem = True
End Function

Private Function PutMem(ByVal lpAddr As Long, ByVal pData As Long, ByVal dlen As Long) As Boolean
    Dim lngOldProtect As Long

    If 0 = VirtualProtect(ByVal lpAddr, dlen, PAGE_EXECUTE_READWRITE, lngOldProtect) Then
        Exit Function
    End If
    CopyMemory ByVal lpAddr, ByVal pData, dlen
    VirtualProtect ByVal lpAddr, dlen, lngOldProtect, lngOldProtect
    PutMem = True
End Function

Private Function PasteCallback(ByVal wFormat As Long) As Long
    Dim ePasteType As XlPasteType
    Dim bCancel As Boolean
    Dim sFullCutCopyRangeAddr As String
    Dim eCtCpMode As XlCutCopyMode

    On Error Resume Next

    eCtCpMode = Application.CutCopyMode
    Call UnSubClassClipBoardWatcherWindow(GetProp(Application.hwnd, "HiddenWnd"))
    Call ThisWorkbook.Application_SheetBeforePaste(oCopyRange, Selection, wFormat, ePasteType, bCancel)
    sFullCutCopyRangeAddr = oCopyRange.Address(, , , True)
    sFullCutCopyRangeAddr = Replace(sFullCutCopyRangeAddr, "'", "***~{*")
    If bCancel Then
        Call DisableClipBoardWarning
        Application.CutCopyMode = False
        Application.OnTime Now, "'CancelMacro """ & sFullCutCopyRangeAddr & """ , """ & eCtCpMode & """'"
        Exit Function
    End If
    If ePasteType = 0 Then Exit Function
    With Application
        If .CutCopyMode = xlCut Then
            Call DisableClipBoardWarning
            .CutCopyMode = False
            .OnTime Now, "'CutPasteMacro """ & sFullCutCopyRangeAddr & """, """ & _
            Selection.Address & """ , """ & ePasteType & """'"
        ElseIf .CutCopyMode = xlCopy Then
            Selection.PasteSpecial ePasteType
            Call DisableClipBoardWarning
            .CutCopyMode = False
            .OnTime Now, "'CopyPasteMacro """ & sFullCutCopyRangeAddr & """'"
        End If
    End With
End Function
 
Public Sub CopyPasteMacro(ByVal CopyRangeAddr As String)
    On Error Resume Next
    CopyRangeAddr = Replace(CopyRangeAddr, "***~{*", "'")
    Range(CopyRangeAddr).Copy
    Call SubClassClipBoardWatcherWindow(GetProp(Application.hwnd, "HiddenWnd"))
End Sub

Public Sub CutPasteMacro(ByVal CutRangeAddr As String, ByVal PasteRangeAddr As String, ByVal PasteType As XlPasteType)
    On Error Resume Next
    CutRangeAddr = Replace(CutRangeAddr, "***~{*", "'")
    Range(CutRangeAddr).Copy
    Range(PasteRangeAddr).PasteSpecial PasteType
    Range(CutRangeAddr).Clear
    Call SubClassClipBoardWatcherWindow(GetProp(Application.hwnd, "HiddenWnd"))
End Sub

Public Sub CancelMacro(ByVal CutCopyRangeAddr As String, ByVal CutCopyMd As XlCutCopyMode)
    On Error Resume Next
    CutCopyRangeAddr = Replace(CutCopyRangeAddr, "***~{*", "'")
    If CutCopyMd = xlCut Then
        Range(CutCopyRangeAddr).Cut
    ElseIf CutCopyMd = xlCopy Then
        Range(CutCopyRangeAddr).Copy
    End If
    Call SubClassClipBoardWatcherWindow(GetProp(Application.hwnd, "HiddenWnd"))
End Sub

2- Code in the ThisWorkbook Module :

Option Explicit

Private Sub Workbook_Open()
'    Call InstallHook
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call UnInstallHook
End Sub

Public Sub Application_SheetBeforePaste( _
    ByVal CutCopyRange As Range, _
    ByVal PasteRange As Range, _
    ByVal ClipboardFormat As Long, _
    ByRef PasteSpecialType As XlPasteType, _
    ByRef Cancel As Boolean _
    )
    
   [COLOR=#008000] '\  EXAMPLE :
    '\ ==========
    '\  Column (A:A)     ===>  : Only "Values" are allowed to be pasted.
    '\  Column (H:H)     ===>  : Only "Formattings" are allowed to be pasted.
    '\  All other Cells  ===>  : No Pasting is allowed.[/COLOR]
    
        If Union(Columns("A:A"), PasteRange).Address = Columns("A:A").Address Then
            PasteSpecialType = xlPasteValues
        ElseIf Union(Columns("H:H"), PasteRange).Address = Columns("H:H").Address Then
            PasteSpecialType = xlPasteFormats
        Else
            Cancel = True
            MsgBox "Pasting not allowed on range : " & vbCrLf & vbCrLf & _
            PasteRange.Address, vbExclamation, "Before Paste Event"
        End If
        
End Sub

Regards

 

[RickXL]

Hi,

You might be interested in this: Catch Paste

 

[Jaafar Tribak]

Hi Rick,

I already know of Pieterse's method .. It relies on assigning all possible Paste keyboard shortcuts and Paste commandbar buttons to one's own paste code .. his approach doesn't work with drag & drop operations nor does it work when pasting data via code

I was hoping to find a more (low level) way of intercepting the paste operation but i am still stuck on making it work with Paste Speciale

I am in the process of writing a small standard dll in PowerBasic .. this dll can then be easily recreated from vba and used without the need to register it ( just as a standard Windows API) .. It is way more stable than my previous code and shoudn't crash excel even if the Stop IDE button is pressed

If anything worthwhile comes up , i will post the code here.

Regards.

 

[willrock9999]

Jaafar Tribak: Sorry for this inconvenient reply. I've tried to send you a private message, but I got the following errors:
"Jaafar Tribak has exceeded their stored private messages quota and cannot accept further messages until they clear some space."
Would you mind to send me an email to tdhtra@gmail.com? Because I can't contact you now. I have some problems that I need your help to be able to solve it.
Thanks.