Capturing the Paste Event (API Hooking - Redirection)

Jaafar Tribak

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,694
Office Version
  1. 2016
Platform
  1. Windows
Hi all,

I have put together this code which basically detects worksheet paste operations before they actually happen. This allows for manipulating the data while still in the clipboard as well as for cancelling the paste operation if so desired.

I have used in this vba project some basic api redirection (api hooking) which I have been exploring lately. I found out that the best api function to be hijacked to this end is the little known "GetClipboardSequenceNumber" api which is exported by the user32.dll. This api conviniently fires everytime a paste operation is about to happen unlike the GetClipboardData api.

File Demo:
BeforePaste_Event.xlsm

The code seems to be quite stable ... unhandled runtime errors inside the BeforePaste_Event event are ok because they are handled beforehand in the bas module. Resetting the vbe project while the hook is still installed doesn't crash excel.
One limitation though, is the fact that complie errors inside the BeforePaste_Event event handler are not allowed. They will simply crash excel !! So, the user will have to pay attention to this.

I have also used low level interface calls to brievely mute the system sounds. This is to prevent the annoying beep sound that comes up when cancelling the paste operation as excel will complain if nothing is in the clipboard while trying to carry out a paste operation.

This little vba project was a good exercise for learning how to hook (hijack) api functions as well as for how to use core audio interfaces in vba without 3rd party dependencies.

Tested in xl2013 x32bit and xl2016 x64bit


1- Code in a Standard Module:
VBA Code: 
Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
    Private Declare PtrSafe Function DispCallFunc Lib "oleaut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
    Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByRef lpiid As Any) As Long
    Private Declare PtrSafe Function CoCreateInstance Lib "ole32" (ByRef rclsid As GUID, ByVal pUnkOuter As LongPtr, ByVal dwClsContext As Long, ByRef riid As GUID, ByRef ppv As LongPtr) As Long
    Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As LongPtr, ByRef cGUID As Any) As Long
    Private Declare PtrSafe Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr) As Long
    Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal PV As LongPtr)
    Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hKBhook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hKBhook As LongPtr) As Long
    Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExW" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
    Private Declare PtrSafe Function GetProcAddress Lib "kernel32" (ByVal hModule As LongPtr, ByVal lpProcName As String) As LongPtr
    Private Declare PtrSafe Function VirtualProtect Lib "kernel32.dll" (ByVal lpAddress As LongPtr, ByVal dwSize As LongPtr, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
    Private Declare Function DispCallFunc Lib "oleaut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
    Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByRef lpiid As Any) As Long
    Private Declare Function CoCreateInstance Lib "ole32" (ByRef rclsid As GUID, ByVal pUnkOuter As LongPtr, ByVal dwClsContext As Long, ByRef riid As GUID, ByRef ppv As LongPtr) As Long
    Private Declare Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As LongPtr, ByRef cGUID As Any) As Long
    Private Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr) As Long
    Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal PV As LongPtr)
    Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare Function CallNextHookEx Lib "user32" (ByVal hKBhook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hKBhook As LongPtr) As Long
    Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExW" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
    Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As LongPtr, ByVal lpProcName As String) As LongPtr
    Private Declare Function VirtualProtect Lib "kernel32.dll" (ByVal lpAddress As LongPtr, ByVal dwSize As LongPtr, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare Function GetActiveWindow Lib "user32" () As LongPtr
#End If

#If Win64 Then
    Private Const NULL_PTR = 0^
    Private Const PTR_LEN = 8&
#Else
    Private Const NULL_PTR = 0&
    Private Const PTR_LEN = 4&
#End If
Private Const SIZE = PTR_LEN * 1.5

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0& To 7&) As Byte
End Type

Private Type HOOK_DATA
    #If Win64 Then
        OriginBytes(0& To 11&) As Byte
        HookBytes(0& To 11&) As Byte
    #Else
        OriginBytes(0& To 5&) As Byte
        HookBytes(0& To 5&) As Byte
    #End If
    pFunc As LongPtr
    pHooker As LongPtr
End Type



Sub StartEventSinking(Optional ByVal Dummy As Boolean)
    Call HookPaste
End Sub
  
Sub StopEventSinking(Optional ByVal Dummy As Boolean)
    Call UnHookPaste
End Sub



' _______________________________________ PRIVATE ROUTINES __________________________________________

Private Sub HookPaste()
    Const PAGE_EXECUTE_READWRITE As Long = &H40&
    Dim uClipboardSequence As HOOK_DATA
    Dim hmod  As LongPtr
    Dim OriginProtect As Long
    Dim i As Long
 
    Call KillTimer(Application.hwnd, NULL_PTR)
    If GetProp(ThisWorkbook.Windows(1&).hwnd, "FuncPtr") Then
        Call UnHookPaste
    End If
    With uClipboardSequence
        hmod = GetModuleHandle("user32.dll")
        .pFunc = GetProcAddress(hmod, "GetClipboardSequenceNumber")
        Call SetProp(ThisWorkbook.Windows(1&).hwnd, "FuncPtr", .pFunc)
        If VirtualProtect(ByVal .pFunc, SIZE, PAGE_EXECUTE_READWRITE, OriginProtect) <> 0& Then
            Call CopyMemory(ByVal VarPtr(.OriginBytes(0&)), ByVal .pFunc, SIZE)
            For i = LBound(.OriginBytes) To UBound(.OriginBytes)
                Call SetProp(ThisWorkbook.Windows(1&).hwnd, "OrignPtr" & i, .OriginBytes(i))
            Next i
            .pHooker = Choose(1&, AddressOf Redirect)
            #If Win64 Then
                .HookBytes(0&) = &H48
                .HookBytes(1&) = &HB8
                Call CopyMemory(.HookBytes(2&), .pHooker, PTR_LEN)
                .HookBytes(10&) = &HFF
                .HookBytes(11&) = &HE0
            #Else
                .HookBytes(0&) = &H68
                Call CopyMemory(.HookBytes(1&), .pHooker, PTR_LEN)
                .HookBytes(5&) = &HC3
            #End If
            Call CopyMemory(ByVal .pFunc, ByVal VarPtr(.HookBytes(0&)), SIZE)
        End If
    End With

End Sub

Private Sub UnHookPaste()
    #If Win64 Then
        Const UPPER_BOUND = 11&
        Dim bytes(0& To UPPER_BOUND) As Byte
    #Else
        Const UPPER_BOUND = 5&
        Dim bytes(0& To UPPER_BOUND) As Byte
    #End If
    Dim i As Long
    With ThisWorkbook.Windows(1)
        If GetProp(.hwnd, "FuncPtr") Then
            For i = 0& To UPPER_BOUND
                bytes(i) = CByte(GetProp(.hwnd, "OrignPtr" & i))
            Next i
            Call SetProp(.hwnd, "VarPtr", VarPtr(bytes(0&)))
            Call CopyMemory(ByVal GetProp(.hwnd, "FuncPtr"), _
                 ByVal GetProp(.hwnd, "VarPtr"), SIZE)
            Call RemoveProp(.hwnd, "FuncPtr")
            Call RemoveProp(.hwnd, "OrignPtr")
            Call RemoveProp(.hwnd, "VarPtr")
        End If
    End With
End Sub

Private Function Redirect() As Long
    Dim bCancel As Boolean
    Dim bDataFromExcel As Boolean
    Dim oDataObj As Object
    On Error GoTo ErrHandler
    If GetActiveWindow <> Application.hwnd Then Exit Function
    Call UnHookPaste
    If GetAsyncKeyState(VBA.vbKeyRButton) = 0& Then
        Set oDataObj = GetObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        bDataFromExcel = (Application.CutCopyMode <> False)
        Call ThisWorkbook.BeforePaste_Event( _
             ByVal ActiveWindow.RangeSelection, ByVal oDataObj, ByVal Application.CutCopyMode, _
             ByVal bDataFromExcel, ByVal Application.ClipboardFormats, bCancel)
        Call ClearClipBoard(bCancel)
    End If
    Call KillTimer(Application.hwnd, NULL_PTR)
    Call SetTimer(Application.hwnd, NULL_PTR, 0&, AddressOf ReHookPaste)
    Exit Function
ErrHandler:
    MsgBox Err.Number & vbTab & Err.Description
End Function

Private Sub ReHookPaste()
    Call KillTimer(Application.hwnd, NULL_PTR)
    Call SetWinHook(False)
    Call KillTimer(Application.hwnd, 1)
    Call SetTimer(Application.hwnd, 1, 4000&, AddressOf RestoreSystemSounds)
    Call HookPaste
End Sub

Private Sub RestoreSystemSounds()
    On Error Resume Next
    Call KillTimer(Application.hwnd, 1)
    Call MuteSytemSounds(False)
End Sub

Private Sub ClearClipBoard(bCancel As Boolean)
    If bCancel Then
        Call OpenClipboard(NULL_PTR)
        'Abort annoying warning empty-clipboard popup.
        Call MuteSytemSounds(True)
        Call SetWinHook(True)
        Call EmptyClipboard
        Call CloseClipboard
    End If
End Sub

Private Sub SetWinHook(ByVal bHook As Boolean)
    Const WH_CBT = 5&
    Dim hCBTHook As LongPtr
    With ThisWorkbook.Windows(1)
        If bHook Then
            If GetProp(.hwnd, "hCBTHook") = NULL_PTR Then
                hCBTHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc, NULL_PTR, GetCurrentThreadId)
                Call SetProp(.hwnd, "hCBTHook", hCBTHook)
            End If
        Else
            If GetProp(.hwnd, "hCBTHook") Then
                Call UnhookWindowsHookEx(GetProp(.hwnd, "hCBTHook"))
                Call RemoveProp(.hwnd, "hCBTHook")
            End If
        End If
    End With
End Sub

Private Function HookProc( _
    ByVal idHook As Long, _
    ByVal wParam As LongPtr, _
    ByVal lParam As LongPtr _
) As LongPtr

    Const HCBT_CREATEWND = 3&, HC_ACTION = 0&
    Dim sBuffer As String * 256&, lRet As Long

    If idHook < HC_ACTION Then
        HookProc = CallNextHookEx(GetProp(ThisWorkbook.Windows(1&).hwnd, "hCBTHook"), _
                   idHook, wParam, lParam)
        Exit Function
    End If
    If idHook = HCBT_CREATEWND Then
        lRet = GetClassName(wParam, sBuffer, 256&)
        If VBA.Left(sBuffer, lRet) = "#32770" Then
            'Abort window creation.
            HookProc = -1
        End If
    End If
End Function

Private Function MuteSytemSounds(ByVal bMute As Boolean) As Boolean

    Const CLSID_MMDeviceEnumerator = "{BCDE0395-E52F-467C-8E3D-C4579291692E}"
    Const IID_IMMDeviceEnumerator = "{A95664D2-9614-4F35-A746-DE8DB63617E6}"
    Const IID_IAudioSessionManager = "{BFA971F1-4D5E-40BB-935E-967039BFBEE4}"
    Const IID_IAudioSessionControl2 = "{bfb7ff88-7239-4fc9-8fa2-07c950be9c6d}"
    Const IID_ISimpleAudioVolume = "{87CE5498-68D6-44E5-9215-6DA47EF883D8}"
    Const IID_NULL = "{00000000-0000-0000-0000-000000000000}"
    Const S_OK = 0&, CLSCTX_ALL = 7&
    
    Dim tClsID As GUID, tIID As GUID
    Dim pDeviceEnumerator As LongPtr, pdefaultDevice As LongPtr
    Dim eRender As Long, eMultimedia As Long
    Dim pIAudioSessionManager As LongPtr, pSessionEnumerator As LongPtr
    Dim pAudioSessionControl As LongPtr, pSessionControl2 As LongPtr, pAudioVolume As LongPtr
    Dim lSessionsCount As Long, i As Long, lRet As Long
    Dim pDispName As LongPtr, sDispName As String

    lRet = CLSIDFromString(StrPtr(CLSID_MMDeviceEnumerator), tClsID)
    lRet = IIDFromString(StrPtr(IID_IMMDeviceEnumerator), tIID)

    'Create an enumerator for the audio endpoint devices
    lRet = CoCreateInstance(tClsID, NULL_PTR, CLSCTX_ALL, tIID, pDeviceEnumerator)
    If lRet Then Debug.Print "Failed to get IMMDeviceEnumerator.": GoTo Xit
 
    eRender = 0&: eMultimedia = 1&
    'IMMDeviceEnumerator::GetDefaultAudioEndpoint Method.
    lRet = vtblStdCall(pDeviceEnumerator, 4& * PTR_LEN, vbLong, eRender, eMultimedia, VarPtr(pdefaultDevice))
    If lRet Then Debug.Print "Failed to get IMMDevice.": GoTo Xit
    
    lRet = IIDFromString(StrPtr(IID_IAudioSessionManager), tIID)
    'IMMDevice::Activate Method.
    lRet = vtblStdCall(pdefaultDevice, 3& * PTR_LEN, vbLong, VarPtr(tIID), CLSCTX_ALL, NULL_PTR, VarPtr(pIAudioSessionManager))
    If lRet Then Debug.Print "Failed to get IAudioSessionManager.": GoTo Xit

    'IAudioSessionManager2::GetSessionEnumerator Method.
    lRet = vtblStdCall(pIAudioSessionManager, 5& * PTR_LEN, vbLong, VarPtr(pSessionEnumerator))
    If lRet Then Debug.Print "Failed to get IAudioSessionEnumerator.": GoTo Xit

    'IAudioSessionEnumerator::GetCount
     lRet = vtblStdCall(pSessionEnumerator, 3& * PTR_LEN, vbLong, VarPtr(lSessionsCount))
 
    If lSessionsCount >= 0& Then
 
        For i = 0& To lSessionsCount - 1&

            'IAudioSessionEnumerator::GetSession Method.
             lRet = vtblStdCall(pSessionEnumerator, 4& * PTR_LEN, vbLong, i, VarPtr(pAudioSessionControl))
             If lRet Then Debug.Print "Failed to get IAudioSessionControl.": GoTo Xit

            'IAudioSessionControl::QueryInterface(IAudioSessionControl2)
            lRet = IIDFromString(StrPtr(IID_IAudioSessionControl2), tIID)
            lRet = vtblStdCall(pAudioSessionControl, 0& * PTR_LEN, vbLong, VarPtr(tIID), VarPtr(pSessionControl2))
            If lRet Then Debug.Print "Failed to get IAudioSessionControl2.": GoTo Xit

            'IAudioSessionControl::GetDisplayName Method.
            lRet = vtblStdCall(pAudioSessionControl, 4& * PTR_LEN, vbLong, VarPtr(pDispName))
            sDispName = GetStrFromPtrW(pDispName)

            'IAudioSessionControl2::IsSystemSoundsSession Method.
            lRet = vtblStdCall(pSessionControl2, 15& * PTR_LEN, vbLong)
            
            If lRet = S_OK Or VBA.InStr(sDispName, "AudioSrv.Dll") Then

                'IAudioSessionControl::QueryInterface(ISimpleAudioVolume)
                lRet = IIDFromString(StrPtr(IID_ISimpleAudioVolume), tIID)
                lRet = vtblStdCall(pAudioSessionControl, 0& * PTR_LEN, vbLong, VarPtr(tIID), VarPtr(pAudioVolume))
                If lRet Then Debug.Print "Failed to get ISimpleAudioVolume.": GoTo Xit

                'ISimpleAudioVolume::SetMute Method.
                lRet = IIDFromString(StrPtr(IID_NULL), tIID)
                lRet = vtblStdCall(pAudioVolume, 5& * PTR_LEN, vbLong, CLng(bMute), VarPtr(tIID))
                If lRet = S_OK Then
                    MuteSytemSounds = True  'Success.
                End If
                
            End If
    
            'Release Interfaces.
            lRet = vtblStdCall(pAudioVolume, 2& * PTR_LEN, vbLong)
            lRet = vtblStdCall(pSessionControl2, 2& * PTR_LEN, vbLong)
            lRet = vtblStdCall(pAudioSessionControl, 2& * PTR_LEN, vbLong)

        Next i

    End If
    
Xit:
    'Release Interfaces.
    If (pDeviceEnumerator And pdefaultDevice And pIAudioSessionManager And pSessionEnumerator) Then
        lRet = vtblStdCall(pSessionEnumerator, 2& * PTR_LEN, vbLong)
        lRet = vtblStdCall(pIAudioSessionManager, 2& * PTR_LEN, vbLong)
        lRet = vtblStdCall(pdefaultDevice, 2& * PTR_LEN, vbLong)
        lRet = vtblStdCall(pDeviceEnumerator, 2& * PTR_LEN, vbLong)
    End If

End Function

Private Function vtblStdCall( _
    ByVal InterfacePointer As LongPtr, _
    ByVal VTableOffset As Long, _
    ByVal FunctionReturnType As Long, _
    ParamArray FunctionParameters() As Variant _
) As Variant

    Const CC_STDCALL = 4&
    Dim vParamPtr() As LongPtr
    Dim pIndex As Long, pCount As Long
    Dim vParamType() As Integer
    Dim vRtn As Variant, vParams() As Variant

    If InterfacePointer = 0& Or VTableOffset < 0& Then Exit Function
    If Not (FunctionReturnType And &HFFFF0000) = 0& Then Exit Function

    vParams() = FunctionParameters()
    pCount = Abs(UBound(vParams) - LBound(vParams) + 1&)
    If pCount = 0& Then
        ReDim vParamPtr(0& To 0&)
        ReDim vParamType(0& To 0&)
    Else
        ReDim vParamPtr(0& To pCount - 1&)
        ReDim vParamType(0& To pCount - 1&)
        For pIndex = 0& To pCount - 1&
            vParamPtr(pIndex) = VarPtr(vParams(pIndex))
            vParamType(pIndex) = VarType(vParams(pIndex))
        Next
    End If

    pIndex = DispCallFunc(InterfacePointer, VTableOffset, CC_STDCALL, FunctionReturnType, pCount, _
    vParamType(0&), vParamPtr(0&), vRtn)
    If pIndex = 0& Then
        vtblStdCall = vRtn
    Else
        SetLastError pIndex
    End If

End Function

Private Function GetStrFromPtrW(ByVal lpString As LongPtr) As String
    Call SysReAllocString(VarPtr(GetStrFromPtrW), lpString)
    Call CoTaskMemFree(lpString)
End Function

Private Sub Auto_Close()
    Call StopEventSinking
End Sub


2- Code Usage Example in the ThisWorkbook Module:
VBA Code: 
Option Explicit

Public Sub Start()
    Call StartEventSinking
End Sub

Public Sub Finish()
    Call StopEventSinking
End Sub


'\ Pseudo-Event Handler must be declared Public so it can be seen by the bas_API module.
'\ Set Cancel argument to TRUE to abort the pasting operation.
'\ RunTime Errors are handled remotely in the bas_API module.
'\ Compile Errors inside the event handler will crash excel!!

Public Sub BeforePaste_Event( _
    ByVal Target As Range, _
    ByVal DataObject As Object, _
    ByVal CutCopyMode As XlCutCopyMode, _
    ByVal DataFromExcel As Boolean, _
    ByVal ClipBoardFormatsArray As Variant, _
    ByRef Cancel As Boolean _
)

    Dim vfmt As Variant
    
    Debug.Print "Available ClipBoard Formats:"
    For Each vfmt In ClipBoardFormatsArray
        Debug.Print vfmt
    Next
    
    With DataObject
        .GetFromClipboard
        If .GetFormat(1&) Then
            MsgBox "Pasting :" & vbLf & "[" & WorksheetFunction.Clean(.GetText(1&)) & "]" & _
                   vbLf & vbLf & "In Range: " & Target.Address(External:=True), vbInformation
        End If
    End With
    
    Debug.Print "IsPastedDataComingFromExcel", DataFromExcel
    
    Debug.Print "CutCopyMode", CutCopyMode
    
    Debug.Print "=========================="
    
'    Cancel = True

End Sub
 

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
Sort by date Sort by votes
My observations while testing the code.

1. In my language version, the name of the ThisWorkbook module is localized (in Polish Ten_skoroszyt). Therefore, the call in the Redirect function should be changed to the localized version of the name of ThisWorkbook module. In the Polish case, the call should look like this:
VBA Code: 
        Call Ten_skoroszyt.BeforePaste_Event( _
             ByVal ActiveWindow.RangeSelection, ByVal oDataObj, ByVal Application.CutCopyMode, _
             ByVal bDataFromExcel, ByVal Application.ClipboardFormats, bCancel)
By the way, why do you force passing by value in the above code snippet when the BeforePaste_Event procedure has all the relevant ByVal parameters declared?

2. Since the values of the constants do not appeal to me (I prefer names, however) I tried to modify your code slightly. In the standard module I added a function:
VBA Code: 
Function decode_ClipboardFormat(x As XlClipboardFormat) As String
    Dim sD As String

    Select Case x
        Case xlClipboardFormatBIFF12: sD = "xlClipboardFormatBIFF12" ' 63
        Case xlClipboardFormatBIFF: sD = "xlClipboardFormatBIFF" ' 8
        Case xlClipboardFormatBIFF2: sD = "xlClipboardFormatBIFF2" ' 18
        Case xlClipboardFormatBIFF3: sD = "xlClipboardFormatBIFF3" ' 20
        Case xlClipboardFormatBIFF4: sD = "xlClipboardFormatBIFF4" ' 30
        Case xlClipboardFormatBinary: sD = "xlClipboardFormatBinary" ' 15
        Case xlClipboardFormatBitmap: sD = "xlClipboardFormatBitmap" ' 9
        Case xlClipboardFormatCGM: sD = "xlClipboardFormatCGM" ' 13
        Case xlClipboardFormatCSV: sD = "xlClipboardFormatCSV" ' 5
        Case xlClipboardFormatDIF: sD = "xlClipboardFormatDIF" ' 4
        Case xlClipboardFormatDspText: sD = "xlClipboardFormatDspText" ' 12
        Case xlClipboardFormatEmbeddedObject: sD = "xlClipboardFormatEmbeddedObject" ' 21
        Case xlClipboardFormatEmbedSource: sD = "xlClipboardFormatEmbedSource" ' 22
        Case xlClipboardFormatLink: sD = "xlClipboardFormatLink" ' 11
        Case xlClipboardFormatLinkSource: sD = "xlClipboardFormatLinkSource" ' 23
        Case xlClipboardFormatLinkSourceDesc: sD = "xlClipboardFormatLinkSourceDesc" ' 32
        Case xlClipboardFormatMovie: sD = "xlClipboardFormatMovie" ' 24
        Case xlClipboardFormatNative: sD = "xlClipboardFormatNative" ' 14
        Case xlClipboardFormatObjectDesc: sD = "xlClipboardFormatObjectDesc" ' 31
        Case xlClipboardFormatObjectLink: sD = "xlClipboardFormatObjectLink" ' 19
        Case xlClipboardFormatOwnerLink: sD = "xlClipboardFormatOwnerLink" ' 17
        Case xlClipboardFormatPICT: sD = "xlClipboardFormatPICT" ' 2
        Case xlClipboardFormatPrintPICT: sD = "xlClipboardFormatPrintPICT" ' 3
        Case xlClipboardFormatRTF: sD = "xlClipboardFormatRTF" ' 7
        Case xlClipboardFormatScreenPICT: sD = "xlClipboardFormatScreenPICT" ' 29
        Case xlClipboardFormatStandardFont: sD = "xlClipboardFormatStandardFont" ' 28
        Case xlClipboardFormatStandardScale: sD = "xlClipboardFormatStandardScale" ' 27
        Case xlClipboardFormatSYLK: sD = "xlClipboardFormatSYLK" ' 6
        Case xlClipboardFormatTable: sD = "xlClipboardFormatTable" ' 16
        Case xlClipboardFormatText: sD = "xlClipboardFormatText" ' 0
        Case xlClipboardFormatToolFace: sD = "xlClipboardFormatToolFace" ' 25
        Case xlClipboardFormatToolFacePICT: sD = "xlClipboardFormatToolFacePICT" ' 26
        Case xlClipboardFormatVALU: sD = "xlClipboardFormatVALU" ' 1
        Case xlClipboardFormatWK1: sD = "xlClipboardFormatWK1" ' 10
        Case Else: sD = _
            "Unrecognized value of the argument in decode_ClipboardFormat function (" & x & ")!"
    End Select

    decode_ClipboardFormat = sD

End Function
and modified the loop in the BeforePaste_Event procedure:
VBA Code: 
    Debug.Print "Available ClipBoard Formats:"
    For Each vfmt In ClipBoardFormatsArray
        Debug.Print decode_ClipboardFormat(CLng(vfmt))
    Next
Then I ran the code, copied the cell and pasted it into the sheet. In the immediate window, I mostly got the names of the constants. However, I found that the enumerative type does not provide all possible constants, No names for the values 33, 42, 44, 45, 50 and 58. Do you perhaps know what this is due to, and what clipboard formats these numbers might correspond to?

Artik
 
Upvote 0
@Artik

Thank you for testing the code and for the valuable feedback and suggestions.
1. In my language version, the name of the ThisWorkbook module is localized (in Polish Ten_skoroszyt). Therefore, the call in the Redirect function should be changed to the localized version of the name of ThisWorkbook module. In the Polish case, the call should look like this:
Click to expand...
I have amended the code to incorporate your suggestion so the code now works regardless of the workbook code name. I have done this by passing 'ThisWorkbook' to the StartEventSinking routine so the actual workbook is later used in the Redirect function.

By the way, why do you force passing by value in the above code snippet when the BeforePaste_Event procedure has all the relevant ByVal parameters declared?
Click to expand...
Correct. Passing ByVal was unnecessary so I have removed it.

I mostly got the names of the constants. However, I found that the enumerative type does not provide all possible constants, No names for the values 33, 42, 44, 45, 50 and 58. Do you perhaps know what this is due to, and what clipboard formats these numbers might correspond to?
Click to expand...
Not sure about those particular clip formats as excel has many specific/weird clipboard clip formats.

Instead of using the XlClipboardFormat enums provided by excel, I have decided to use the EnumClipboardFormats api to retrieve all the formats available in the clipboard. Doing this yields more accurate results and the returned values are compatible with legacy clipboard functions such GetClipboardData/GetClipboardData which can later be used to manipulate the clipboard data if so desired.

I have added a new additional array argument to the event handler (ClipBoardFormatsNamesArray) to hold the clipboard formats names. Both arrays are filled in the bas module to keep the client code in the ThisWorkbook module clean & simple. Retrieving the formats values & format names is easier as shown in the next example.

Finally, I have fixed a nasty bug that went unnoticed that was happening when working with multiple excel windows/workbooks and which was making the code unstable. I fixed this bug by replacing ThisWorkbook.Windows(1&).hwnd with ThisWorkbook.Application.hwnd and storing the new hwnd in a module level variable for later use in the Redirect function.

Based on all the above, I have now fully updated the code as follows as well as the uploaded workbook demo.

Again, thanks for pointing all this things out to me.

UPDATE:
File Demo:
BeforePaste_Event.xlsm


1- bas Module code:
VBA Code: 
Option Explicit

Private Enum EPredefinedClipboardFormatConstants
    [_First] = 1&
        CF_TEXT = 1&
        CF_BITMAP = 2&
        CF_METAFILEPICT = 3&
        CF_SYLK = 4&
        CF_DIF = 5&
        CF_TIFF = 6&
        CF_OEMTEXT = 7&
        CF_DIB = 8&
        CF_PALETTE = 9&
        CF_PENDATA = 10&
        CF_RIFF = 11&
        CF_WAVE = 12&
        CF_UNICODETEXT = 13&
        CF_ENHMETAFILE = 14&
        CF_HDROP = 15&
        CF_LOCALE = 16&
        CF_MAX = 17&
    [_Last] = 17&
End Enum

#If VBA7 Then
    Private Declare PtrSafe Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
    Private Declare PtrSafe Function DispCallFunc Lib "oleaut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
    Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByRef lpiid As Any) As Long
    Private Declare PtrSafe Function CoCreateInstance Lib "ole32" (ByRef rclsid As GUID, ByVal pUnkOuter As LongPtr, ByVal dwClsContext As Long, ByRef riid As GUID, ByRef ppv As LongPtr) As Long
    Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As LongPtr, ByRef cGUID As Any) As Long
    Private Declare PtrSafe Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr) As Long
    Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal PV As LongPtr)
    Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hKBhook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hKBhook As LongPtr) As Long
    Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExW" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
    Private Declare PtrSafe Function GetProcAddress Lib "kernel32" (ByVal hModule As LongPtr, ByVal lpProcName As String) As LongPtr
    Private Declare PtrSafe Function VirtualProtect Lib "kernel32.dll" (ByVal lpAddress As LongPtr, ByVal dwSize As LongPtr, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
    Private Declare Function DispCallFunc Lib "oleaut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
    Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByRef lpiid As Any) As Long
    Private Declare Function CoCreateInstance Lib "ole32" (ByRef rclsid As GUID, ByVal pUnkOuter As LongPtr, ByVal dwClsContext As Long, ByRef riid As GUID, ByRef ppv As LongPtr) As Long
    Private Declare Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As LongPtr, ByRef cGUID As Any) As Long
    Private Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr) As Long
    Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal PV As LongPtr)
    Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare Function CallNextHookEx Lib "user32" (ByVal hKBhook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hKBhook As LongPtr) As Long
    Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExW" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
    Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As LongPtr, ByVal lpProcName As String) As LongPtr
    Private Declare Function VirtualProtect Lib "kernel32.dll" (ByVal lpAddress As LongPtr, ByVal dwSize As LongPtr, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare Function GetActiveWindow Lib "user32" () As LongPtr
    Private Declare Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
    Private Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
#End If

#If Win64 Then
    Private Const NULL_PTR = 0^
    Private Const PTR_LEN = 8&
#Else
    Private Const NULL_PTR = 0&
    Private Const PTR_LEN = 4&
#End If
Private Const SIZE = PTR_LEN * 1.5

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0& To 7&) As Byte
End Type

Private Type HOOK_DATA
    #If Win64 Then
        OriginBytes(0& To 11&) As Byte
        HookBytes(0& To 11&) As Byte
    #Else
        OriginBytes(0& To 5&) As Byte
        HookBytes(0& To 5&) As Byte
    #End If
    pFunc As LongPtr
    pHooker As LongPtr
End Type

Private oWbk As Workbook
Private hwnd As LongPtr


Sub StartEventSinking(ByVal Wb As Workbook)
    Set oWbk = Wb
    hwnd = Wb.Application.hwnd
    Call HookPaste
End Sub

Sub StopEventSinking(Optional ByVal Dummy As Boolean)
    Call UnHookPaste
    Set oWbk = Nothing
End Sub



' _______________________________________ PRIVATE ROUTINES __________________________________________

Private Sub HookPaste()
    Const PAGE_EXECUTE_READWRITE As Long = &H40&
    Dim uClipboardSequence As HOOK_DATA
    Dim hmod  As LongPtr
    Dim OriginProtect As Long
    Dim i As Long

    Call KillTimer(Application.hwnd, NULL_PTR)
    If GetProp(ThisWorkbook.Application.hwnd, "FuncPtr") Then
        Call UnHookPaste
    End If
    With uClipboardSequence
        hmod = GetModuleHandle("user32.dll")
        .pFunc = GetProcAddress(hmod, "GetClipboardSequenceNumber")
        Call SetProp(ThisWorkbook.Application.hwnd, "FuncPtr", .pFunc)
        If VirtualProtect(ByVal .pFunc, SIZE, PAGE_EXECUTE_READWRITE, OriginProtect) <> 0& Then
            Call CopyMemory(ByVal VarPtr(.OriginBytes(0&)), ByVal .pFunc, SIZE)
            For i = LBound(.OriginBytes) To UBound(.OriginBytes)
                Call SetProp(ThisWorkbook.Application.hwnd, "OrignPtr" & i, .OriginBytes(i))
            Next i
            .pHooker = Choose(1&, AddressOf Redirect)
            #If Win64 Then
                .HookBytes(0&) = &H48
                .HookBytes(1&) = &HB8
                Call CopyMemory(.HookBytes(2&), .pHooker, PTR_LEN)
                .HookBytes(10&) = &HFF
                .HookBytes(11&) = &HE0
            #Else
                .HookBytes(0&) = &H68
                Call CopyMemory(.HookBytes(1&), .pHooker, PTR_LEN)
                .HookBytes(5&) = &HC3
            #End If
            Call CopyMemory(ByVal .pFunc, ByVal VarPtr(.HookBytes(0&)), SIZE)
        End If
    End With

End Sub

Private Sub UnHookPaste()
    #If Win64 Then
        Const UPPER_BOUND = 11&
        Dim bytes(0& To UPPER_BOUND) As Byte
    #Else
        Const UPPER_BOUND = 5&
        Dim bytes(0& To UPPER_BOUND) As Byte
    #End If
    Dim i As Long
    With ThisWorkbook.Windows(1)
        If GetProp(.hwnd, "FuncPtr") Then
            For i = 0& To UPPER_BOUND
                bytes(i) = CByte(GetProp(.hwnd, "OrignPtr" & i))
            Next i
            Call SetProp(.hwnd, "VarPtr", VarPtr(bytes(0&)))
            Call CopyMemory(ByVal GetProp(.hwnd, "FuncPtr"), _
                 ByVal GetProp(.hwnd, "VarPtr"), SIZE)
            Call RemoveProp(.hwnd, "FuncPtr")
            Call RemoveProp(.hwnd, "OrignPtr")
            Call RemoveProp(.hwnd, "VarPtr")
        End If
    End With
End Sub

Private Function Redirect() As Long

    Dim bCancel As Boolean
    Dim bDataFromExcel As Boolean
    Dim oDataObj As Object
    Dim Index As Long
    Dim vClipFormatsArray() As Variant
    Dim vClipFormatsNamesArray() As Variant
    Dim oDict As Object

    On Error GoTo ErrHandler
    If GetActiveWindow <> hwnd Then Exit Function
    Call UnHookPaste
    If GetAsyncKeyState(VBA.vbKeyRButton) = 0& Then
        Set oDataObj = GetObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        bDataFromExcel = (Application.CutCopyMode <> False)
        Set oDict = GetClipFormats
        With GetClipFormats
            ReDim vClipFormatsArray(.Count - 1&)
            ReDim vClipFormatsNamesArray(.Count - 1&)
            For Index = 0& To .Count - 1&
                vClipFormatsArray(Index) = .Keys()(Index)
                vClipFormatsNamesArray(Index) = .Items()(Index)
            Next
        End With
        Call oWbk.BeforePaste_Event( _
             ActiveWindow.RangeSelection, oDataObj, Application.CutCopyMode, _
             bDataFromExcel, vClipFormatsArray, vClipFormatsNamesArray, bCancel)
        Call ClearClipBoard(bCancel)
    End If
    Call KillTimer(Application.hwnd, NULL_PTR)
    Call SetTimer(Application.hwnd, NULL_PTR, 0&, AddressOf ReHookPaste)
    Exit Function
ErrHandler:
    MsgBox "Error#: " & Err.Number & vbLf & Err.Description, , "RunTime Error!"

End Function

Private Sub ReHookPaste()
    Call KillTimer(Application.hwnd, NULL_PTR)
    Call SetWinHook(False)
    Call KillTimer(Application.hwnd, 1)
    Call SetTimer(Application.hwnd, 1, 4000&, AddressOf RestoreSystemSounds)
    Call HookPaste
End Sub

Private Sub RestoreSystemSounds()
    On Error Resume Next
    Call KillTimer(Application.hwnd, 1)
    Call MuteSytemSounds(False)
End Sub

Private Sub ClearClipBoard(bCancel As Boolean)
    If bCancel Then
        Call OpenClipboard(NULL_PTR)
        'Abort annoying warning empty-clipboard popup and its sound.
        Call MuteSytemSounds(True)
        Call SetWinHook(True)
        Call EmptyClipboard
        Call CloseClipboard
    End If
End Sub

Private Sub SetWinHook(ByVal bHook As Boolean)
    Const WH_CBT = 5&
    Dim hCBTHook As LongPtr
    With ThisWorkbook.Windows(1)
        If bHook Then
            If GetProp(.hwnd, "hCBTHook") = NULL_PTR Then
                hCBTHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc, NULL_PTR, GetCurrentThreadId)
                Call SetProp(.hwnd, "hCBTHook", hCBTHook)
            End If
        Else
            If GetProp(.hwnd, "hCBTHook") Then
                Call UnhookWindowsHookEx(GetProp(.hwnd, "hCBTHook"))
                Call RemoveProp(.hwnd, "hCBTHook")
            End If
        End If
    End With
End Sub

Private Function HookProc( _
    ByVal idHook As Long, _
    ByVal wParam As LongPtr, _
    ByVal lParam As LongPtr _
) As LongPtr

    Const HCBT_CREATEWND = 3&, HC_ACTION = 0&
    Dim sBuffer As String * 256&, lret As Long

    If idHook < HC_ACTION Then
        HookProc = CallNextHookEx(GetProp(ThisWorkbook.Application.hwnd, "hCBTHook"), _
                   idHook, wParam, lParam)
        Exit Function
    End If
    If idHook = HCBT_CREATEWND Then
        lret = GetClassName(wParam, sBuffer, 256&)
        If VBA.Left(sBuffer, lret) = "#32770" Then
            'Abort window creation.
            HookProc = -1
        End If
    End If
End Function

Private Function MuteSytemSounds(ByVal bMute As Boolean) As Boolean

    Const CLSID_MMDeviceEnumerator = "{BCDE0395-E52F-467C-8E3D-C4579291692E}"
    Const IID_IMMDeviceEnumerator = "{A95664D2-9614-4F35-A746-DE8DB63617E6}"
    Const IID_IAudioSessionManager = "{BFA971F1-4D5E-40BB-935E-967039BFBEE4}"
    Const IID_IAudioSessionControl2 = "{bfb7ff88-7239-4fc9-8fa2-07c950be9c6d}"
    Const IID_ISimpleAudioVolume = "{87CE5498-68D6-44E5-9215-6DA47EF883D8}"
    Const IID_NULL = "{00000000-0000-0000-0000-000000000000}"
    Const S_OK = 0&, CLSCTX_ALL = 7&

    Dim tClsID As GUID, tIID As GUID
    Dim pDeviceEnumerator As LongPtr, pdefaultDevice As LongPtr
    Dim eRender As Long, eMultimedia As Long
    Dim pIAudioSessionManager As LongPtr, pSessionEnumerator As LongPtr
    Dim pAudioSessionControl As LongPtr, pSessionControl2 As LongPtr, pAudioVolume As LongPtr
    Dim lSessionsCount As Long, i As Long, lret As Long
    Dim pDispName As LongPtr, sDispName As String

    lret = CLSIDFromString(StrPtr(CLSID_MMDeviceEnumerator), tClsID)
    lret = IIDFromString(StrPtr(IID_IMMDeviceEnumerator), tIID)

    'Create an enumerator for the audio endpoint devices
    lret = CoCreateInstance(tClsID, NULL_PTR, CLSCTX_ALL, tIID, pDeviceEnumerator)
    If lret Then Debug.Print "Failed to get IMMDeviceEnumerator.": GoTo Xit

    eRender = 0&: eMultimedia = 1&
    'IMMDeviceEnumerator::GetDefaultAudioEndpoint Method.
    lret = vtblStdCall(pDeviceEnumerator, 4& * PTR_LEN, vbLong, eRender, eMultimedia, VarPtr(pdefaultDevice))
    If lret Then Debug.Print "Failed to get IMMDevice.": GoTo Xit

    lret = IIDFromString(StrPtr(IID_IAudioSessionManager), tIID)
    'IMMDevice::Activate Method.
    lret = vtblStdCall(pdefaultDevice, 3& * PTR_LEN, vbLong, VarPtr(tIID), CLSCTX_ALL, NULL_PTR, VarPtr(pIAudioSessionManager))
    If lret Then Debug.Print "Failed to get IAudioSessionManager.": GoTo Xit

    'IAudioSessionManager2::GetSessionEnumerator Method.
    lret = vtblStdCall(pIAudioSessionManager, 5& * PTR_LEN, vbLong, VarPtr(pSessionEnumerator))
    If lret Then Debug.Print "Failed to get IAudioSessionEnumerator.": GoTo Xit

    'IAudioSessionEnumerator::GetCount
     lret = vtblStdCall(pSessionEnumerator, 3& * PTR_LEN, vbLong, VarPtr(lSessionsCount))

    If lSessionsCount >= 0& Then

        For i = 0& To lSessionsCount - 1&

            'IAudioSessionEnumerator::GetSession Method.
             lret = vtblStdCall(pSessionEnumerator, 4& * PTR_LEN, vbLong, i, VarPtr(pAudioSessionControl))
             If lret Then Debug.Print "Failed to get IAudioSessionControl.": GoTo Xit

            'IAudioSessionControl::QueryInterface(IAudioSessionControl2)
            lret = IIDFromString(StrPtr(IID_IAudioSessionControl2), tIID)
            lret = vtblStdCall(pAudioSessionControl, 0& * PTR_LEN, vbLong, VarPtr(tIID), VarPtr(pSessionControl2))
            If lret Then Debug.Print "Failed to get IAudioSessionControl2.": GoTo Xit

            'IAudioSessionControl::GetDisplayName Method.
            lret = vtblStdCall(pAudioSessionControl, 4& * PTR_LEN, vbLong, VarPtr(pDispName))
            sDispName = GetStrFromPtrW(pDispName)

            'IAudioSessionControl2::IsSystemSoundsSession Method.
            lret = vtblStdCall(pSessionControl2, 15& * PTR_LEN, vbLong)

            If lret = S_OK Or VBA.InStr(sDispName, "AudioSrv.Dll") Then

                'IAudioSessionControl::QueryInterface(ISimpleAudioVolume)
                lret = IIDFromString(StrPtr(IID_ISimpleAudioVolume), tIID)
                lret = vtblStdCall(pAudioSessionControl, 0& * PTR_LEN, vbLong, VarPtr(tIID), VarPtr(pAudioVolume))
                If lret Then Debug.Print "Failed to get ISimpleAudioVolume.": GoTo Xit

                'ISimpleAudioVolume::SetMute Method.
                lret = IIDFromString(StrPtr(IID_NULL), tIID)
                lret = vtblStdCall(pAudioVolume, 5& * PTR_LEN, vbLong, CLng(bMute), VarPtr(tIID))
                If lret = S_OK Then
                    MuteSytemSounds = True  'Success.
                End If

            End If

            'Release Interfaces.
            lret = vtblStdCall(pAudioVolume, 2& * PTR_LEN, vbLong)
            lret = vtblStdCall(pSessionControl2, 2& * PTR_LEN, vbLong)
            lret = vtblStdCall(pAudioSessionControl, 2& * PTR_LEN, vbLong)

        Next i

    End If

Xit:
    'Release Interfaces.
    If (pDeviceEnumerator And pdefaultDevice And pIAudioSessionManager And pSessionEnumerator) Then
        lret = vtblStdCall(pSessionEnumerator, 2& * PTR_LEN, vbLong)
        lret = vtblStdCall(pIAudioSessionManager, 2& * PTR_LEN, vbLong)
        lret = vtblStdCall(pdefaultDevice, 2& * PTR_LEN, vbLong)
        lret = vtblStdCall(pDeviceEnumerator, 2& * PTR_LEN, vbLong)
    End If

End Function

Private Function vtblStdCall( _
    ByVal InterfacePointer As LongPtr, _
    ByVal VTableOffset As Long, _
    ByVal FunctionReturnType As Long, _
    ParamArray FunctionParameters() As Variant _
) As Variant

    Const CC_STDCALL = 4&
    Dim vParamPtr() As LongPtr
    Dim pIndex As Long, pCount As Long
    Dim vParamType() As Integer
    Dim vRtn As Variant, vParams() As Variant

    If InterfacePointer = 0& Or VTableOffset < 0& Then Exit Function
    If Not (FunctionReturnType And &HFFFF0000) = 0& Then Exit Function

    vParams() = FunctionParameters()
    pCount = Abs(UBound(vParams) - LBound(vParams) + 1&)
    If pCount = 0& Then
        ReDim vParamPtr(0& To 0&)
        ReDim vParamType(0& To 0&)
    Else
        ReDim vParamPtr(0& To pCount - 1&)
        ReDim vParamType(0& To pCount - 1&)
        For pIndex = 0& To pCount - 1&
            vParamPtr(pIndex) = VarPtr(vParams(pIndex))
            vParamType(pIndex) = VarType(vParams(pIndex))
        Next
    End If

    pIndex = DispCallFunc(InterfacePointer, VTableOffset, CC_STDCALL, FunctionReturnType, pCount, _
    vParamType(0&), vParamPtr(0&), vRtn)
    If pIndex = 0& Then
        vtblStdCall = vRtn
    Else
        SetLastError pIndex
    End If

End Function

Private Function GetStrFromPtrW(ByVal lpString As LongPtr) As String
    Call SysReAllocString(VarPtr(GetStrFromPtrW), lpString)
    Call CoTaskMemFree(lpString)
End Function

Private Function GetClipFormats() As Object
    Dim lR As Long, iCount As Long
    Dim oDict As Object
    Set oDict = CreateObject("Scripting.Dictionary")
    If (OpenClipboard(NULL_PTR)) Then
        lR = EnumClipboardFormats(0&)
        If (lR <> 0&) Then
            Do
                iCount = iCount + 1&
                oDict.Add lR, FormatName(lR)
                lR = EnumClipboardFormats(lR)
            Loop While lR <> 0&
            Set GetClipFormats = oDict
        End If
    End If
    Call CloseClipboard
End Function

'http://www.vbaccelerator.com/home/VB/Tips/Determine_All_Formats_On_Clipboard/article.html
Private Property Get FormatName( _
        ByVal lFormatId As Long _
    ) As String

    Dim lSize As Long
    Dim sBuf As String
    Dim lR As Long

    If (lFormatId >= EPredefinedClipboardFormatConstants.[_First] _
        And lFormatId <= EPredefinedClipboardFormatConstants.[_Last]) Then
        Select Case lFormatId
            Case CF_TEXT
                FormatName = "Text"
            Case CF_BITMAP
                FormatName = "Bitmap Picture"
            Case CF_METAFILEPICT
                FormatName = "Meta-File Picture"
            Case CF_SYLK
                FormatName = "Microsoft Symbolic Link (SYLK) data."
            Case CF_DIF
                FormatName = "Software Arts' Data Interchange information."
            Case CF_TIFF = 6
                FormatName = "Tagged Image File Format (TIFF) Picture"
            Case CF_OEMTEXT
                FormatName = "Text (OEM)"
            Case CF_DIB
                FormatName = "DIB Bitmap Picture"
            Case CF_PALETTE
                FormatName = "Colour Palette"
            Case CF_PENDATA
                FormatName = "Pen Data"
            Case CF_RIFF
                FormatName = "RIFF Audio data"
            Case CF_WAVE
                FormatName = "Wave File"
            Case CF_UNICODETEXT
                FormatName = "Text (Unicode)"
            Case CF_ENHMETAFILE
                FormatName = "Enhanced Meta-File Picture"
            Case CF_HDROP
                FormatName = "File List"
            Case CF_LOCALE
                FormatName = "Text Locale Identifier"
        End Select
    Else
        lSize = 255&
        sBuf = String$(lSize, 0&)
        lR = GetClipboardFormatName(lFormatId, sBuf, lSize)
        If (lR <> 0&) Then
            FormatName = Left$(sBuf, lR)
        End If
    End If
End Property

Private Sub Auto_Close()
    Call StopEventSinking
End Sub



2- Code Usage Example in the ThisWorkbook Module:
VBA Code: 
Option Explicit

Public Sub Start()
    Call StartEventSinking(ThisWorkbook)
End Sub

Public Sub Finish()
    Call StopEventSinking
End Sub


'\ Pseudo-Event Handler must be declared Public so it can be seen by the bas_API module.
'\ Set Cancel argument to TRUE to abort the pasting operation.
'\ RunTime Errors are handled remotely in the bas_API module.
'\ Compile Errors inside the event handler will crash excel!!

Public Sub BeforePaste_Event( _
    ByVal Target As Range, _
    ByVal DataObject As Object, _
    ByVal CutCopyMode As XlCutCopyMode, _
    ByVal ClipBoardDataFromExcel As Boolean, _
    ByVal ClipBoardFormatsArray As Variant, _
    ByVal ClipBoardFormatsNamesArray As Variant, _
    ByRef Cancel As Boolean _
)
 
    Dim i As Long
 
    Debug.Print "Available ClipBoard Formats:"
    Debug.Print "============================"
    For i = LBound(ClipBoardFormatsArray) To UBound(ClipBoardFormatsArray)
        Debug.Print ClipBoardFormatsArray(i), ClipBoardFormatsNamesArray(i)
    Next i
 
    With DataObject
        .GetFromClipboard
        If .GetFormat(1&) Then
            If vbNo = MsgBox("Pasting data :  " & "[ " & WorksheetFunction.Clean(.GetText(1&)) & " ]" & _
                   vbLf & vbLf & "In Range:   " & Target.Address(External:=True) & vbLf & vbLf & _
                   "Go Ahead?", vbInformation + vbYesNo) Then
                Cancel = True  'Pasting aborted.
            End If
        End If
    End With
 
    Debug.Print "IsPastedDataComingFromExcel", ClipBoardDataFromExcel
 
    Debug.Print "CutCopyMode", CutCopyMode
 
    Debug.Print "============================"

End Sub

Regards.
 
Upvote 0
I would love to know what you think. Is the idea worthwhile? Is it stable enough when applied in a vba envirenement?
Click to expand...
It's a good question. My concern with these usually is the poor user experience when errors cause crashes. Been badly burnt by this in the past, especially when I was trying to use an array reference; Maybe given the short nature of handling such events you won't really run into these kinds of issues as often, so it might well be worth it. I'd love to see a Application class, which exposes new class events. In the past I made a shape events class for instance. I always felt there were too few events in VBA
 
Upvote 0
sancarn said:
Maybe given the short nature of handling such events you won't really run into these kinds of issues as often, so it might well be worth it.
Click to expand...
Yes. That's what I normally do when using win callbacks. Short lived hooks/timers are generally well tolerated.

. I'd love to see a Application class, which exposes new class events. In the past I made a shape events class for instance. I always felt there were too few events in VBA
Click to expand...
There are so many missing events in Excel/MsForms/Office object models that would certainely be very useful. Events such as when scrolling worksheets, activating-Deactivating-Resizing-Moving the main excel window, Copying-Pasting-Dragging, Formatting cells, Mouse hovering, etc just to name a few.

In the abscence of such events, the CommandBars OnUpdate event, although too slow, can sometimes come in handy, just like you did for creating shapes pseudo-events.

array reference
Click to expand...
Good stuff !
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

Jaafar Tribak
  • Question
Blurring images using Direct2D & Windows Imaging Component
Replies
3
Views
415
Dan_W
D
J
  • Solved
Get IAccessible of UserForm control without reference
2
Replies
10
Views
357
Jaafar Tribak
Jaafar Tribak
D
  • Solved
DispCallFunc - 64bit VBA
Replies
6
Views
641
Dan_W
D
H
  • Solved
Catching the Mouse Click Error in Modal User Form
Replies
4
Views
451
huiettcm
H
G
  • Solved
Getting code to work in 64 Bit Excel
Replies
5
Views
347
Gborden800
G

Forum statistics

Threads
1,217,394
Messages
6,136,341
Members
450,005
Latest member
BigPaws

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top