Option Explicit
#If VBA7 Then
#If Win64 Then
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongLong, ByVal nIndex As Long) As LongLong
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongLong, ByVal nIndex As Long, ByVal dwNewLong As LongLong) As LongLong
#Else
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
#End If
Private Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongPtr, ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) 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 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 DispCallFunc Lib "OleAut32.dll" (ByVal pvInstance As LongPtr, ByVal oVft As LongPtr, ByVal cc As Long, ByVal vtReturn As Integer, ByVal cActuals As Long, ByVal prgvt As Long, ByVal prgpvarg As LongPtr, ByVal pvargResult As LongPtr) As Long
Private Declare PtrSafe Function EnableWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal fEnable As Long) As Long
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Private lPrevDVErrorBoxProc As LongPtr
#Else
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
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, ByVal prgvt As Long, ByVal prgpvarg As Long, ByVal pvargResult As Long) As Long
Private Declare Function EnableWindow Lib "user32" (ByVal hwnd As Long, ByVal fEnable As Long) As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private lPrevDVErrorBoxProc As Long
#End If
Private bStateOk As Boolean, bDVErrShowing As Boolean
'__________________________________________ PUBLIC CALLBACK ROUTINES _______________________________________________
Public Sub Macro1()
' Callback routines are unforgiving - No unhandled errors are allowed here.
' Propper error handling is necessary to avoid potential crashings.
With UserForm1
.Caption = "Custom Data Validation Help... Cell: " & ActiveCell.Address
.Label1.Caption = "UserForm called from DV [Help] Button."
.Show
End With
End Sub
Public Sub Macro2()
' Callback routines are unforgiving - No unhandled errors are allowed here.
' Propper error handling is necessary to avoid potential crashings.
Shell "calc.exe"
End Sub
'__________________________________________ PUBLIC ROUTINES _______________________________________________
#If Win64 Then
Public Sub Customize_DataValidation_Help_Button( _
ByVal ValidationCell As Range, _
ByVal lpMacro As LongLong _
)
#Else
Public Sub Customize_DataValidation_Help_Button( _
ByVal ValidationCell As Range, _
ByVal lpMacro As Long _
)
#End If
If ValidationCell.Count = 1 Then
If IsShowValidationError(ValidationCell) Then
ValidationCell.ID = lpMacro
If ValidationCell.Address = ActiveCell.Address Then
bDVErrShowing = False
Call StartDelayedHook(0)
End If
End If
End If
End Sub
Public Sub SetWatcher(Optional ByVal bHook As Boolean = True)
If bHook Then
bStateOk = True
Call SetTimer(Application.hwnd, 0, 0, AddressOf TimerProc)
Else
Call KillTimer(Application.hwnd, 0)
Debug.Print "unhooked."
End If
End Sub
Public Function Is_DataValidation_Help_Button_Customized(ByVal Cell As Range) As Boolean
If Cell.Count > 1 Then Call SetWatcher(False): Exit Function
Is_DataValidation_Help_Button_Customized = Len(Cell.ID)
End Function
'__________________________________________ PRIVATE ROUTINES _______________________________________________
Private Sub StartDelayedHook(ByVal lMsecDelay As Long)
Call KillTimer(Application.hwnd, 0)
Call SetTimer(Application.hwnd, 0, lMsecDelay, AddressOf DelayedSetHook)
End Sub
Private Sub DelayedSetHook()
If GetActiveWindow = Application.hwnd Then
Call KillTimer(Application.hwnd, 0)
Call SetWatcher
End If
End Sub
Private Sub TimerProc()
Dim sClassName As String * 256, lRet As Long
lRet = GetClassName(GetActiveWindow, sClassName, 256)
If Left$(sClassName, lRet) = "#32770" And GetUserData(GetActiveWindow) = 0 Then
If lPrevDVErrorBoxProc = 0 Then
If bDVErrShowing = False Then
bDVErrShowing = True
Call Subclass(GetActiveWindow)
End If
End If
Else
bDVErrShowing = False
End If
If bStateOk = False Then
Debug.Print "loss of state !"
Call Subclass(GetActiveWindow, False)
Call KillTimer(Application.hwnd, 0)
End If
End Sub
#If Win64 Then
Private Sub Subclass(ByVal hwnd As LongLong, Optional ByVal bSubclass As Boolean = True)
#Else
Private Sub Subclass(ByVal hwnd As Long, Optional ByVal bSubclass As Boolean = True)
#End If
Const GWL_WNDPROC = -4
If bSubclass Then
lPrevDVErrorBoxProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf SubclassProc)
Else
Call SetWindowLong(hwnd, GWL_WNDPROC, lPrevDVErrorBoxProc)
lPrevDVErrorBoxProc = 0
Debug.Print "unsubclassed."
End If
End Sub
#If Win64 Then
Private Function SubclassProc( _
ByVal hwnd As LongLong, _
ByVal Msg As Long, _
ByVal wParam As LongLong, _
ByVal lParam As LongLong _
) As LongLong
#Else
Private Function SubclassProc( _
ByVal hwnd As Long, _
ByVal Msg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long _
) As Long
#End If
Const GWL_WNDPROC = -4
Const WM_COMMAND = &H111
Const WM_DESTROY = &H2
Const BN_CLICKED = &H0
Const CC_STDCALL = 4
Dim vFuncRet As Variant
'
Select Case Msg
Case WM_COMMAND
If hiword(CLng(wParam)) = BN_CLICKED Then
If loword(CLng(wParam)) = &H9& Then 'DV Help button clicked.
#If Win64 Then
Dim FuncAddress As LongLong
FuncAddress = VBA.CLngLng(ActiveCell.ID)
#Else
Dim FuncAddress As Long
FuncAddress = VBA.CLng(ActiveCell.ID)
#End If
If FuncAddress Then
Call EnableWindow(lParam, False)
'Call our alternative Help macro.
Call DispCallFunc(0, FuncAddress, CC_STDCALL, vbEmpty, 0, 0, 0, VarPtr(vFuncRet))
Call EnableWindow(lParam, True)
End If
Call SetWatcher(False)
Call SetTimer(Application.hwnd, 0, 0, AddressOf ReHook)
'Abort default action of help button.
Exit Function
End If
End If
Case WM_DESTROY
Call Subclass(hwnd, False)
Call KillTimer(Application.hwnd, 0)
End Select
SubclassProc = CallWindowProc(lPrevDVErrorBoxProc, hwnd, Msg, wParam, ByVal lParam)
End Function
Private Sub ReHook()
Call KillTimer(Application.hwnd, 0)
Call SetWatcher
End Sub
Private Function IsShowValidationError(ByVal Cell As Range) As Boolean
On Error Resume Next
IsShowValidationError = Cell.Validation.ShowError
End Function
#If Win64 Then
Private Function GetUserData(ByVal hwnd As LongLong) As LongLong
#Else
Private Function GetUserData(ByVal hwnd As Long) As Long
#End If
Const GWL_USERDATA = (-21)
GetUserData = GetWindowLong(hwnd, GWL_USERDATA)
End Function
Private Function hiword(DWord As Long) As Long
hiword = (DWord And &HFFFF0000) \ &H10000
End Function
Private Function loword(DWord As Long) As Integer
If DWord And &H8000& Then
loword = DWord Or &HFFFF0000
Else
loword = DWord And &HFFFF&
End If
End Function
Private Sub auto_close()
Call SetWatcher(False)
Call KillTimer(Application.hwnd, 0)
End Sub
