Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,656
- Office Version
- 2016
- Platform
- 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:
2- Code Usage Example in the ThisWorkbook Module:
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