Paste event in Excel ? - Half way there.

[Jaafar Tribak]

Workbook Demo.

Hi all. Here is the signature of the paste event handler :

Private Sub Workbook__Paste _
(ByVal Target As Object, ByRef Cancel As Boolean)
    
    [COLOR=seagreen]'prevent pasting into Cell A1.[/COLOR]
    If Not Intersect(Target, Range("a1")) Is Nothing Then
        Cancel = True
        MsgBox "Pasting is not allowed into Range:" & _
        vbCrLf & Range("a1").Address, vbCritical
    End If
 
End Sub

where Target can be a Range or Shape and the Cancel argumet is passed ByRef to indicate that the pasting is to be stopped. Just as native excel events.

Still 2 unsolved limitations rest all working fine.

1 - "Paste Special" functionality had to be removed. I could raise the event upon pasting via Paste Special but for some obscure reason the Intersect/Union Methods are not recognised inside the event handler and so the Cancel argument never gets a chance to be filled with the data.

2 - I couldn't find a way to prevent Dragging & Dropping from other applications as no messages seem to be sent to Excel during this operation .

Word of caution: The code uses a WH_CALLWNDPROC system hook . As with all hooks, editing,debugging the code inside the VBE while the hook is running is a recipie for disaster so anyone trying this be careful and make sure the hook is properly removed first.

Project:

Add a Class Module ,name it CPasteMonitor and put the following code in it :

Option Explicit
 
Private Declare Function FindWindow _
Lib "user32.dll" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
 
Private Declare Function GetDesktopWindow Lib _
"user32.dll" () As Long
 
Private Declare Function ShowWindow _
Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal nCmdShow As Long) As Long
 
Private Declare Function LockWindowUpdate _
Lib "user32.dll" _
(ByVal hwndLock As Long) As Long
 
Private Declare Function GetFocus Lib _
"user32.dll" () As Long
 
Private Declare Function SendMessage Lib _
"user32.dll" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByRef lParam As Any) As Long
 
Private Declare Function PostMessage Lib _
"user32.dll" _
Alias "PostMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) 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 GetWindowLong Lib _
"user32" Alias "GetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long) As Long
 
Private Declare Function GetClassName Lib "user32" _
Alias "GetClassNameA" _
(ByVal hwnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long
 
Private Declare Function GetWindowText Lib "user32.dll" _
Alias "GetWindowTextA" _
(ByVal hwnd As Long, _
ByVal lpString As String, _
ByVal cch As Long) As Long
 
Private Declare Function GetProp Lib "user32" _
Alias "GetPropA" _
(ByVal hwnd As Long, _
ByVal lpString As String) 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 SetClipboardViewer _
Lib "user32" _
(ByVal hwnd As Long) As Long
 
Private Declare Function OpenClipboard Lib "user32.dll" _
(ByVal hwnd As Long) As Long
 
Private Declare Function CloseClipboard Lib _
"user32.dll" () As Long
 
Private Declare Function EmptyClipboard Lib _
"user32.dll" () As Long
 
Private Declare Function SetClipboardData Lib _
"user32.dll" _
(ByVal wFormat As Long, _
ByVal hMem As Long) As Long
 
Private Declare Function EnumClipboardFormats _
Lib "user32" _
(ByVal wFormat As Long) As Long
 
Private Const WH_CALLWNDPROC = 4
Private Const HC_ACTION = 0
Private Const GWL_HINSTANCE = (-6)
Private Const WM_ACTIVATEAPP = &H1C
Private Const WM_ENABLE = &HA
Private Const WM_RENDERFORMAT = &H305
Private Const WM_DRAWCLIPBOARD = &H308
 
'Private Const PASTE_SPECIAL_WND_CAPTION _
'As String = "Collage spécial"       '  French XL.
 
Private Const PASTE_SPECIAL_WND_CAPTION _
As String = "Paste Special"       '  English XL.
 
Event Paste _
(ByVal Target As Object, ByRef Cancel As Boolean)

Public Function HookProc _
(ByVal uCode As Long, ByVal wParam As Long, _
lParam As CWPSTRUCT) As Long
 
    Dim sBuffer As String
    Dim lRetVal As Long
    Dim lR As Long
    Dim bCancel As Boolean
    Static oCopySource As Object
    
    On Error Resume Next
    
    Select Case uCode
    
            Case HC_ACTION
            
                'delay clipboard rendering.
                If lParam.message = WM_DRAWCLIPBOARD Then
                    Set oCopySource = Selection
                    Application.DisplayAlerts = False
                    If (OpenClipboard(0)) Then
                        lR = EnumClipboardFormats(0)
                        If (lR <> 0) Then
                            Do
                                SetClipboardData lR, 0
                                lR = EnumClipboardFormats(lR)
                            Loop While lR <> 0
                        End If
                        CloseClipboard
                    End If
                End If
          
                'prevent pasting from
                'other applications.
                If lParam.message = WM_ACTIVATEAPP Then
                    Application.DisplayAlerts = False
                    If lParam.wParam Then
                        OpenClipboard 0
                        EmptyClipboard
                        CloseClipboard
                    End If
                End If
                
                'remove paste special functionality.-
                'Still working on this !!
                If lParam.message = WM_ENABLE Then
                    sBuffer = Space(256)
                    lRetVal = GetWindowText _
                    (GetFocus, sBuffer, Len(sBuffer))
                    If Left(sBuffer, lRetVal) = _
                    PASTE_SPECIAL_WND_CAPTION Then
                        OpenClipboard (0)
                        EmptyClipboard
                        CloseClipboard
                        MsgBox "Paste Special deactivated."
                    End If
                End If
                
                'handle stdrd paste.
                If lParam.message = WM_RENDERFORMAT Then
                    RaiseEvent Paste(ByVal Selection, bCancel)
                    If bCancel Then
                        Application.DisplayAlerts = False
                        OpenClipboard (0)
                        EmptyClipboard
                        CloseClipboard
                    Else
                        If Application.CutCopyMode = xlCopy Then
                            oCopySource.Copy
                        End If
                    End If
                End If
    End Select
    
    HookProc = CallNextHookEx(hHook, uCode, wParam, lParam)
 
End Function
 
Public Sub EndHooking()
 
    UnhookWindowsHookEx GetProp(GetDesktopWindow, "hHook")
    RemoveProp GetDesktopWindow, "hHook"
    hHook = 0
    Set oPasteMonitorPtr = Nothing
 
End Sub
 
Public Sub SetHook()
 
    SetClipboardViewer FindWindow _
    ("XLMAIN", Application.Caption)
    
    hHook = SetWindowsHookEx _
    (WH_CALLWNDPROC, AddressOf HookFuncCaller, _
    GetAppInstance, GetCurrentThreadId)
    
    If hHook Then
        SetProp GetDesktopWindow, "hHOOK", hHook
    End If
 
End Sub
 
Private Function GetAppInstance() As Long
 
    GetAppInstance = _
    GetWindowLong(FindWindow("XLMAIN", Application.Caption) _
    , GWL_HINSTANCE)
 
End Function

Add a Standard Module for safe hooking (SafeHooking) and put the following code in it:

Option Explicit
 
'Public declares.
'================
Public Type CWPSTRUCT
    lParam As Long
    wParam As Long
    message As Long
    hwnd As Long
End Type
 
Public oPasteMonitorPtr As CPasteMonitor
Public oCopySource As Object
Public hHook As Long
Public lXLhwnd As Long
 
'Private declares.
'=================
Private Declare Function FindWindow Lib "user32.dll" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
 
Private Declare Function GetDesktopWindow Lib _
"user32.dll" () As Long
 
Private Declare Function ShowWindow Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal nCmdShow As Long) As Long
 
Private Declare Function LockWindowUpdate Lib "user32.dll" _
(ByVal hwndLock As Long) As Long
 
Private Declare Function SendMessage Lib "user32.dll" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByRef lParam As Any) As Long
 
Private Declare Function PostMessage Lib "user32.dll" _
Alias "PostMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
 
Private Declare Function OpenClipboard Lib "user32.dll" _
(ByVal hwnd As Long) As Long
 
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
 
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long

Private Const WM_USER = &H400
Private Const WM_SETREDRAW = &HB
Private Const SW_SHOW = 5

'Public Subs.
'============
Public Sub StartPasteMonitoring()
    
    Call Refresh_VBIDE
    
End Sub
 
Public Sub StopPasteMonitoring()
 
    'Remove hook if still running.
    On Error Resume Next
    Call oPasteMonitorPtr.EndHooking
 
End Sub

Public Function HookFuncCaller _
(ByVal uCode As Long, ByVal wParam As Long, lParam As CWPSTRUCT) _ As Long
 
    Call oPasteMonitorPtr.HookProc(ByVal uCode, ByVal wParam, lParam)
 
End Function

'Private Subs.
'============
Private Sub Refresh_VBIDE()
 
    If hHook Then Exit Sub
    
    OpenClipboard (0)
    EmptyClipboard
    CloseClipboard
    
    SendMessage _
    GetDesktopWindow, ByVal WM_SETREDRAW, ByVal 0&, 0&
    
    Application.SendKeys ("%{F11}")
    DoEvents
    
    LockWindowUpdate FindWindow _
    ("wndclass_desked_gsk", vbNullString)
    
    SendMessage _
    GetDesktopWindow, ByVal WM_SETREDRAW, ByVal 0&, 0&
    
    PostMessage _
    FindWindow("wndclass_desked_gsk", vbNullString), _
    ByVal WM_USER + &HC44, ByVal &H30, ByVal 0&
    
    PostMessage _
    FindWindow("wndclass_desked_gsk", vbNullString), _
    ByVal WM_USER + &HC44, ByVal &H33, ByVal 0&
    
    PostMessage _
    FindWindow("wndclass_desked_gsk", vbNullString), _
    ByVal WM_USER + &HC44, ByVal &H83, ByVal 0&
    
    Application.OnTime Now + TimeSerial(0, 0, 0.1), "UnLockScrUpdate"

End Sub
Private Sub UnLockScrUpdate()

    lXLhwnd = FindWindow("XLMAIN", Application.Caption)
    
    SendMessage _
    GetDesktopWindow, WM_SETREDRAW, ByVal 1, 0&
    
    ShowWindow FindWindow _
    ("wndclass_desked_gsk", vbNullString), 0&
    
    ShowWindow lXLhwnd, SW_SHOW
    
    LockWindowUpdate 0&
    
    Call ThisWorkbook.IntiatePasteMonitor(ByVal True)
End Sub

Place the following code in the Worbook Module :

Option Explicit
 
Private WithEvents Workbook_ As CPasteMonitor

'our paste event handler.
'========================
Private Sub Workbook__Paste _
(ByVal Target As Object, ByRef Cancel As Boolean)
    
    'prevent pasting into Cell A1.
    If Not Intersect(Target, Range("a1")) Is Nothing Then
        Cancel = True
        MsgBox "Pasting is not allowed into Range:" & _
        vbCrLf & Range("a1").Address, vbCritical
    End If
 
End Sub

'Private Subs.
'============
Private Sub Workbook_Open()
 
    Call StartPasteMonitoring
    
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
 
    'Remove hook if still running.
    On Error Resume Next
    Call StopPasteMonitoring
    Set Workbook_ = Nothing
 
End Sub
 
'Public Subs.
'============
Public Sub IntiatePasteMonitor(ByVal bDummy As Boolean)
 
    Set Workbook_ = New CPasteMonitor
    Set oPasteMonitorPtr = Workbook_
    Workbook_.SetHook
 
End Sub

Tested on Excel 2003 Win XP.

Regards.

 

[Jaafar Tribak]

Has anyone tried this ? - I would appreciate some feedback to see if the code works as it should on different systems and maybe make some improvements.

Regards.

 

[Jonmo1]

I tried it out, and it seems to work as advertised.

Did you intend for paste special to be disabled all togheher, regardless if it's in the disallowed range? If so, then it works.

1 peculiar quirk I found

When copy/pasting within the allowed range:
Say I copy C1
Paste to F1
Then paste again (without copying anything new) to say H1
Then F1 becomes highlighted as if it was copied.
Then paste again (without copying anything new) to say G5
Then H1 becomes highlighted as if it was copied.

And so on.

Not sure if that's a big deal, because it's recopying the same data that was pasted..
It's just odd..


Other than that, it's pretty cool, and works well.
Haven't done any extensive testing though..

 

[Jaafar Tribak]

I tried it out, and it seems to work as advertised.

Did you intend for paste special to be disabled all togheher, regardless if it's in the disallowed range? If so, then it works.

1 peculiar quirk I found

When copy/pasting within the allowed range:
Say I copy C1
Paste to F1
Then paste again (without copying anything new) to say H1
Then F1 becomes highlighted as if it was copied.
Then paste again (without copying anything new) to say G5
Then H1 becomes highlighted as if it was copied.

And so on.

Not sure if that's a big deal, because it's recopying the same data that was pasted..
It's just odd..


Other than that, it's pretty cool, and works well.
Haven't done any extensive testing though..

Jonmo.

Sorry for the delay .My mother passed away so I couldn't respond earlier.


As you said, the Paste Special is altogether removed. It was intended. I am still working on this so it's not completly disabled and is properly handled in the Workbook__Paste _ event handler like the normal Copy/Cut/Paste - It's more difficult.

As for the recopying the pasted data this is due to the fact that when handling the WM_RENDERFORMAT Windows Message, the initial Clipboard data is lost so the only workaround I found is to store it in the Public variable oCopySource by copying the pasted data . Not exactly very elegant but gets the job done.

Again thanks for taking the time to test this.

Regards.

 

[Jaafar Tribak]

Fresh download upon someone's request .

 

[James_B]

Hi Jaafar,

Sorry to hear about your mother.

Regarding the Paste Special issues: I guess you could use a home-grown version of Intersect if the only worry is that you can't call that particular method? I guess it would either have to use a dummy sheet to work or to be based on examining the range references. Is this potentially useful?

 

[Colin Legg]

My condolences, Jaafar. I am sorry to hear this sad news.



The Range property has its own syntax for union and intersect - they might be worth a shot.

Intersect equivalents:

    'intersect syntax
    Debug.Print Application.Intersect(Range("E1:E10"), Target).Address  
    Debug.Print Range("E1:E10 " & Target.Address).Address

Note the space after E1:E10 so, if Target address is A5:J5, the string argument passed into the range property is "E1:E10 A5:J5"

For union:

    'union syntax
    Debug.Print Application.Union(Range("E1:E10"), Target).Address
    Debug.Print Range("E1:E10," & Target.Address).Address

 

[Jaafar Tribak]

Thank you for your kind consideration and sympathy.

Also, thank you for your suggestions which I have tried out but they don't seem to make any difference.

Looking more closely at the hook code , the Paste Special window raises the WM_ENABLE Msg at which point Excel enters a Modal mode and that's most likely why the Event handler doesn't execute properly.

The idea of a designing the Paste event handler with the same signature as that of other native Excel event handlers was to make it very intuitive for the user and to flexibly allow the user to define the Pasting criteria inside the event handler without them having to worry about the working background code inside the Class module. Unfortunatly, it is this particular code design that seems to be causing the above wierd issues.

Anyway, i'll keep trying and if anything comes up i'll post back.