Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,797
- Office Version
- 2016
- Platform
- Windows
Hi all,
I have written a C++ dll that can be used from VBA to abort\change the default worksheet protected warning message.
XLProtectWarning32.dll
XLProtectWarning64.dll
The dll exports one function (AbortProtectWarning) which installs/Removes a WH_CBT hook that swallows the built-in message and calls an alternative user defined Procedure.
The reason I installed the hook in a dll is so that excel doesn't crash should the VBE get reset accidently.
USAGE:
Note that the dll doesn't require prior registration as it is a standard windows dll.
For portability reasons, I decided to store the dll bytes in a hidden worksheet of the workbook (like a resource) and then have the vba code save the dll file to disk from the bytes on the fly.
The only issue is the size of the dll (779 kb for the 32.dll) - (981 kb for the 64.dll) which can bloat the workbook... If I manage to reduce the dll size, I'll post the result here later.
If you don't want to deal with this sizing problem, just remove the bytes from the hidden worksheet , have the dll as a seperate file and call the dll function (AbortProtectWarning) as normal.
Anyways, here are 2 workbook examples for 32Bits and 64Bits:
A32.xlsm
A64.xlsm
32Bit code:
64Bit code:
</windows.h></windows.h>
I have written a C++ dll that can be used from VBA to abort\change the default worksheet protected warning message.
XLProtectWarning32.dll
XLProtectWarning64.dll
Code:
#include "Header.h"
#include windows.h<windows.h><windows.h>
#define DLL_EXPORTS
HHOOK hookHandle = NULL;
HMODULE hInstance = NULL;
WNDPROC callback = NULL;
BOOL HookSet = NULL;
LRESULT CALLBACK CBTProc(int nCode, WPARAM wParam, LPARAM lParam) {
WCHAR clsName_v[MAX_PATH];
CHAR buffer[MAX_PATH];
static INT i;
if (nCode == HCBT_ACTIVATE) {
GetClassName(HWND(wParam), clsName_v, MAX_PATH);
if (0 == lstrcmp(clsName_v, TEXT("#32770"))) {
HWND msgHwnd = 0;
msgHwnd = GetDlgItem(HWND(wParam), 0x0000000000000FA1);
if (!IsWindow(msgHwnd)) { msgHwnd = GetDlgItem(HWND(wParam), 0x000000000000FFFF); }
GetWindowTextA(msgHwnd, buffer, MAX_PATH);
if ((strncmp(buffer, "La cellule ou le graphique", 26) == 0) || (strncmp(buffer, "The cell or chart", 17) == 0)) {
if (callback != NULL) {
if (i % 3 == 0) { CallWindowProc(callback, 0, 0, 0, 0); }
i = i + 1;
}
DestroyWindow((HWND)wParam);
return -1;
}
}
}
return CallNextHookEx(hookHandle, nCode, wParam, lParam);
}
void __stdcall AbortProtectWarning(BOOL Enable, WNDPROC CallBackFunc = NULL)
{
callback = CallBackFunc;
if ((Enable) && (!HookSet)) {
hInstance = GetModuleHandle(L"XLProtectWarning32.dll");
hookHandle = SetWindowsHookEx(WH_CBT, (HOOKPROC)CBTProc, hInstance, 0);
HookSet = TRUE;
}
if ((!Enable) && (HookSet)) { UnhookWindowsHookEx(hookHandle); HookSet = FALSE; }
}The dll exports one function (AbortProtectWarning) which installs/Removes a WH_CBT hook that swallows the built-in message and calls an alternative user defined Procedure.
The reason I installed the hook in a dll is so that excel doesn't crash should the VBE get reset accidently.
USAGE:
Note that the dll doesn't require prior registration as it is a standard windows dll.
For portability reasons, I decided to store the dll bytes in a hidden worksheet of the workbook (like a resource) and then have the vba code save the dll file to disk from the bytes on the fly.
The only issue is the size of the dll (779 kb for the 32.dll) - (981 kb for the 64.dll) which can bloat the workbook... If I manage to reduce the dll size, I'll post the result here later.
If you don't want to deal with this sizing problem, just remove the bytes from the hidden worksheet , have the dll as a seperate file and call the dll function (AbortProtectWarning) as normal.
Anyways, here are 2 workbook examples for 32Bits and 64Bits:
A32.xlsm
A64.xlsm
32Bit code:
Code:
Option Explicit
Private Declare Function DispCallFunc Lib "OleAut32.dll" (ByVal pvInstance As Long, ByVal oVft As Long, ByVal cc_ As Long, ByVal vtReturn As Integer, ByVal cActuals As Long, ByRef prgvt As Integer, ByRef prgpvarg As Long, ByRef pvargResult As Long) As Long
Private Declare Function LoadLibraryEx Lib "kernel32" Alias "LoadLibraryExA" (ByVal lpLibFileName As String, ByVal hFile As Long, ByVal dwFlags As Long) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName 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 GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Const LOAD_IGNORE_CODE_AUTHZ_LEVEL = &H10
Private Const CC_STDCALL = 4
Sub StartTest()
Dim hLib As Long, pProcAddr As Long
Dim sFilePathName As String
sFilePathName = ThisWorkbook.Path & "\XLProtectWarning32.dll"
If Len(Dir(sFilePathName)) = 0 Then
Call CreateDllFromBytes(sFilePathName)
End If
hLib = GetProp(Application.hwnd, "hLib")
pProcAddr = GetProp(Application.hwnd, "pProcAddr")
If hLib = 0 Then
hLib = LoadLibraryEx(sFilePathName, 0, LOAD_IGNORE_CODE_AUTHZ_LEVEL)
If hLib Then
pProcAddr = GetProcAddress(hLib, "AbortProtectWarning")
SetProp Application.hwnd, "hLib", hLib
If pProcAddr Then
CallDllProc pProcAddr, True, AddressOf MyCustomWarningFunc
SetProp Application.hwnd, "pProcAddr", pProcAddr
End If
End If
End If
End Sub
Sub StopTest()
Dim hLib As Long, pProcAddr As Long
hLib = GetProp(Application.hwnd, "hLib")
pProcAddr = GetProp(Application.hwnd, "pProcAddr")
If hLib Then
If pProcAddr Then
CallDllProc pProcAddr, False, AddressOf MyCustomWarningFunc
FreeLibrary hLib
RemoveProp Application.hwnd, "hLib"
RemoveProp Application.hwnd, "pProcAddr"
End If
End If
End Sub
Private Sub MyCustomWarningFunc()
MsgBox "STOP !!" & vbLf & vbLf & "'" & ActiveSheet.Name & "' is protected." & vbLf & _
"This is a user defined warning message.", vbCritical, "XLProtectWarning64 dll (test)."
End Sub
Private Sub CreateDllFromBytes(ByVal PathFileName As String)
Dim arBytes() As Byte, arTemp() As Variant
Dim lFileNum As Integer, i As Long
arTemp = DllBytes.UsedRange.SpecialCells(xlCellTypeConstants).Value
ReDim arBytes(LBound(arTemp) To UBound(arTemp))
For i = LBound(arTemp) To UBound(arTemp)
arBytes(i) = CByte(arTemp(i, 1))
Next
Erase arTemp
lFileNum = FreeFile
Open PathFileName For Binary As #lFileNum
Put #lFileNum, 1, arBytes
Close lFileNum
Erase arBytes
End Sub
Private Sub CallDllProc(ByVal pProcAddr As Long, ByVal Param1 As Boolean, ByVal Param2 As Long)
Dim varTypes(0 To 1) As Integer
Dim varPointers(0 To 1) As Long
Dim vX As Variant, vY As Variant
vX = CVar(Param1): vY = CVar(Param2)
varTypes(0) = VBA.vbBoolean
varTypes(1) = VBA.vbLong
varPointers(0) = VarPtr(vX)
varPointers(1) = VarPtr(vY)
Call DispCallFunc( _
0, _
pProcAddr, _
CC_STDCALL, _
VbVarType.vbEmpty, _
2, _
varTypes(0), _
varPointers(0), _
0)
End Sub64Bit code:
Code:
Option Explicit
Private Declare PtrSafe Function DispCallFunc Lib "OleAut32.dll" (ByVal pvInstance As LongPtr, ByVal oVft As LongPtr, ByVal cc_ As Long, ByVal vtReturn As Integer, ByVal cActuals As Long, ByRef prgvt As Integer, ByRef prgpvarg As LongPtr, ByRef pvargResult As LongPtr) As Long
Private Declare PtrSafe Function LoadLibraryEx Lib "kernel32" Alias "LoadLibraryExA" (ByVal lpLibFileName As String, ByVal hFile As LongPtr, ByVal dwFlags As Long) As LongPtr
Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
Private Declare PtrSafe Function GetProcAddress Lib "kernel32" (ByVal hModule As LongPtr, ByVal lpProcName As String) As LongPtr
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 Const LOAD_IGNORE_CODE_AUTHZ_LEVEL = &H10
Private Const CC_STDCALL = 4
Sub StartTest()
Dim hLib As LongPtr, pProcAddr As LongPtr
Dim sFilePathName As String
sFilePathName = ThisWorkbook.Path & "\XLProtectWarning64.dll"
If Len(Dir(sFilePathName)) = 0 Then
Call CreateDllFromBytes(sFilePathName)
End If
hLib = GetProp(Application.hwnd, "hLib")
pProcAddr = GetProp(Application.hwnd, "pProcAddr")
If hLib = 0 Then
hLib = LoadLibraryEx(sFilePathName, 0, LOAD_IGNORE_CODE_AUTHZ_LEVEL)
If hLib Then
pProcAddr = GetProcAddress(hLib, "AbortProtectWarning")
SetProp Application.hwnd, "hLib", hLib
If pProcAddr Then
CallDllProc pProcAddr, True, AddressOf MyCustomWarningFunc
SetProp Application.hwnd, "pProcAddr", pProcAddr
End If
End If
End If
End Sub
Sub StopTest()
Dim hLib As LongPtr, pProcAddr As LongPtr
hLib = GetProp(Application.hwnd, "hLib")
pProcAddr = GetProp(Application.hwnd, "pProcAddr")
If hLib Then
If pProcAddr Then
CallDllProc pProcAddr, False, AddressOf MyCustomWarningFunc
FreeLibrary hLib
RemoveProp Application.hwnd, "hLib"
RemoveProp Application.hwnd, "pProcAddr"
End If
End If
End Sub
Private Sub MyCustomWarningFunc()
MsgBox "STOP !!" & vbLf & vbLf & "'" & ActiveSheet.Name & "' is protected." & vbLf & _
"This is a user defined warning message.", vbCritical, "XLProtectWarning64 dll (test)."
End Sub
Private Sub CreateDllFromBytes(ByVal PathFileName As String)
Dim arBytes() As Byte, arTemp() As Variant
Dim lFileNum As Integer, i As Long
arTemp = DllBytes.UsedRange.SpecialCells(xlCellTypeConstants).Value
ReDim arBytes(LBound(arTemp) To UBound(arTemp))
For i = LBound(arTemp) To UBound(arTemp)
arBytes(i) = CByte(arTemp(i, 1))
Next
Erase arTemp
lFileNum = FreeFile
Open PathFileName For Binary As #lFileNum
Put #lFileNum, 1, arBytes
Close lFileNum
Erase arBytes
End Sub
Private Sub CallDllProc(ByVal pProcAddr As LongPtr, ByVal Param1 As Boolean, ByVal Param2 As LongLong)
Dim varTypes(0 To 1) As Integer
Dim varPointers(0 To 1) As LongPtr
Dim vX As Variant, vY As Variant
vX = CVar(Param1): vY = CVar(Param2)
varTypes(0) = VBA.vbBoolean
varTypes(1) = VBA.vbLongLong
varPointers(0) = VarPtr(vX)
varPointers(1) = VarPtr(vY)
Call DispCallFunc( _
0, _
pProcAddr, _
CC_STDCALL, _
VbVarType.vbEmpty, _
2, _
varTypes(0), _
varPointers(0), _
0)
End Sub
