Option Explicit
Private Declare PtrSafe Function SetDlgItemText Lib "user32" Alias "SetDlgItemTextA" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal lpString As String) As Long
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As LongPtr) As Long
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
#Else
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadID As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function SetDlgItemText Lib "user32" Alias "SetDlgItemTextA" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal lpString As String) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
Public Enum eButton
[Ok] = 1
[Cancel] = 2
[abort] = 3
[RETRY] = 4
[Ignore] = 5
[Yes] = 6
[No] = 7
End Enum
Private m_Button1 As Long
Private m_Button2 As Long
Private m_Button3 As Long
Private m_Text_Button1 As String
Private m_Text_Button2 As String
Private m_Text_Button3 As String
Private Id_Hook As LongPtr
#Else
Private Id_Hook As Long
Private Sub TestMsgBox()
Call fMsgBox("Just a test", vbOKOnly + vbInformation , , , , "Opt1", "Opt2", "Opt3")
End Sub
Public Function fMsgBox(ByVal prompt As String, _
Optional ByVal Buttons As VbMsgBoxStyle = vbYesNo, _
Optional ByVal Title As String = "W A R N I N G", _
Optional ByVal HelpFile As Variant, _
Optional ByVal Context As Variant, _
Optional ByVal TextButton1 As String = vbNullString, _
Optional ByVal TextButton2 As String = vbNullString, _
Optional ByVal TextButton3 As String = vbNullString) As VbMsgBoxResult
Dim retValue As VbMsgBoxResult
Dim lgCustom As Long
Dim lgIcon As Long
Dim bInformation As Boolean, bExclamation As Boolean, bCritical As Boolean
If TextButton1 & TextButton2 & TextButton3 = vbNullString Then
If Buttons >= vbCritical Then
If Buttons >= vbCritical And Buttons < 2 * vbCritical Then
Buttons = Buttons - vbCritical
bCritical = True
If Title = vbNullString Then Title = "W A R N I N G"
End If
If Buttons >= vbExclamation And Buttons < (vbCritical + vbExclamation) Then
Buttons = Buttons - vbExclamation
bExclamation = True
If Title = vbNullString Then Title = "W A R N I N G"
End If
If Buttons >= vbInformation And Buttons < (vbCritical + vbInformation) Then
Buttons = Buttons - vbInformation
bInformation = True
If Title = vbNullString Then Title = "I N F O"
End If
End If
If Buttons = vbOKOnly Then
Buttons = vbOKCancel: lgCustom = -1
ElseIf Buttons = vbYesNo Then
Buttons = vbOKCancel: lgCustom = 5
End If
If bCritical Then Buttons = Buttons + vbCritical
If bExclamation Then Buttons = Buttons + vbExclamation
If bInformation Then Buttons = Buttons + vbInformation
If bCritical And Buttons = vbCritical Then Buttons = Buttons + vbOKCancel
retValue = VBA.MsgBox(prompt, Buttons, Title, HelpFile, Context)
If retValue = vbCancel Then
Stop
ElseIf retValue = vbAbort Then
Stop
End If
fMsgBox = VBA.IIf(retValue + lgCustom < 1, 1, retValue + lgCustom)
Else
fMsgBox = MsgBoxCustom(prompt, Buttons, Title, _
TextButton1, TextButton2, TextButton3)
End If
End Function
Public Function MsgBoxCustom(ByVal prompt As String, _
ByVal lgMsgBoxIconStyle As VbMsgBoxStyle, _
ByVal Title As String, _
ByVal TextButton1 As String, _
Optional ByVal TextButton2 As String = vbNullString, _
Optional ByVal TextButton3 As String = vbNullString) As VbMsgBoxResult
Dim retValue As VbMsgBoxResult
Dim lgMsgBoxStyle As VbMsgBoxStyle
m_Text_Button1 = TextButton1
m_Text_Button2 = TextButton2
m_Text_Button3 = TextButton3
sHook
If VBA.Trim$(TextButton3) = vbNullString Then
If VBA.Trim$(TextButton2) = vbNullString Then
lgMsgBoxStyle = lgMsgBoxIconStyle + vbOKOnly
m_Button1 = 1
Else
lgMsgBoxStyle = lgMsgBoxIconStyle + vbYesNo
m_Button1 = 6
m_Button2 = 7
End If
Else
lgMsgBoxStyle = lgMsgBoxIconStyle + vbYesNoCancel
m_Button1 = 6
m_Button2 = 7
m_Button3 = 2
End If
retValue = VBA.MsgBox(prompt, lgMsgBoxStyle, Title)
If retValue = vbOK Then
MsgBoxCustom = 1
ElseIf retValue = vbYes Then
MsgBoxCustom = 1
ElseIf retValue = vbNo Then
MsgBoxCustom = 2
ElseIf retValue = vbCancel Then
MsgBoxCustom = 3
End If
retValue = UnhookWindowsHookEx(Id_Hook)
m_Text_Button1 = vbNullString
m_Text_Button2 = vbNullString
m_Text_Button3 = vbNullString
End Function
Private Sub sHook()
Id_Hook = SetWindowsHookEx(WH_CBT, AddressOf winProc, 0, GetCurrentThreadId)
End Sub
Public Function winProc(ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim retValue As VbMsgBoxResult
If uMsg = HCBT_ACTIVATE Then
retValue = SetDlgItemText(wParam, m_Button1, m_Text_Button1)
If m_Button2 > 0 Then
retValue = SetDlgItemText(wParam, m_Button2, m_Text_Button2)
End If
If m_Button3 > 0 Then
retValue = SetDlgItemText(wParam, m_Button3, m_Text_Button3)
End If
End If
On Error GoTo 0
winProc = 0
End Function