R
RB Smissaert
As I wanted to alter the captions of the standard Msgbox I had a look at the
Messagebox API and
after altering some code I found it seems this is working nicely. I know I
could use a Userform for
this, but I want to keep resources down and wasn't keen to add yet another
Userform to the project.
The only thing that is a slight problem is that the buttons don't resize
with the caption, but I can keep
the caption lenghth down.
The other thing is that this msgbox is modeless and that would seem a good
thing, but I am just wondering
if anybody is aware of any problems that could arise from this code:
Option Explicit
Private Const MB_YESNOCANCEL = &H3&
Private Const MB_YESNO = &H4&
Private Const MB_RETRYCANCEL = &H5&
Private Const MB_OKCANCEL = &H1&
Private Const MB_OK = &H0&
Private Const MB_ABORTRETRYIGNORE = &H2&
Private Const MB_ICONEXCLAMATION = &H30&
Private Const MB_ICONQUESTION = &H20&
Private Const MB_ICONASTERISK = &H40&
Private Const MB_ICONINFORMATION = MB_ICONASTERISK
Private Const IDOK = 1
Private Const IDCANCEL = 2
Private Const IDABORT = 3
Private Const IDRETRY = 4
Private Const IDIGNORE = 5
Private Const IDYES = 6
Private Const IDNO = 7
Private Const IDPROMPT = &HFFFF&
Private Const WH_CBT = 5
Private Const GWL_HINSTANCE = (-6)
Private Const HCBT_ACTIVATE = 5
Private Type MSGBOX_HOOK_PARAMS
hwndOwner As Long
hHook As Long
End Type
Private MSGHOOK As MSGBOX_HOOK_PARAMS
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Public Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetWindowLong Lib "user32" Alias _
"GetWindowLongA" (ByVal hwnd As Long,
_
ByVal nIndex As
Long) As Long
Private Declare Function MessageBox Lib "user32" _
Alias "MessageBoxA" (ByVal hwnd As Long,
_
ByVal lpText As
String, _
ByVal lpCaption As
String, _
ByVal wType 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 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 SetWindowText _
Lib "user32" _
Alias "SetWindowTextA" (ByVal hwnd As Long, _
ByVal lpString As
String) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) As Long
Private mbFlags As VbMsgBoxStyle
Private mbFlags2 As VbMsgBoxStyle
Private mTitle As String
Private mPrompt As String
Private But1 As String
Private But2 As String
Private But3 As String
Function FARPROC(ByVal pfn As Long) As Long
'Procedure that receives and returns
'the passed value of the AddressOf operator.
'This workaround is needed as you can't assign
'AddressOf directly to a member of a user-
'defined type, but you can assign it to another
'long and use that (as returned here)
FARPROC = pfn
End Function
Function MessageBoxH(hwndThreadOwner As Long, _
hwndOwner As Long, _
mbFlags As VbMsgBoxStyle, _
strTitle As String, _
strPrompt As String) As Long
'This function calls the hook
Dim hInstance As Long
Dim hThreadId As Long
hInstance = GetWindowLong(hwndThreadOwner, GWL_HINSTANCE)
hThreadId = GetCurrentThreadId()
With MSGHOOK
.hwndOwner = hwndOwner
.hHook = SetWindowsHookEx(WH_CBT, _
FARPROC(AddressOf MsgBoxHookProc), _
hInstance, _
hThreadId)
End With
MessageBoxH = MessageBox(hwndOwner, _
strPrompt, _
strTitle, _
mbFlags)
End Function
Function MsgBoxHookProc(ByVal uMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
'This function catches the messagebox before it opens
'and changes the text of the buttons - then removes the hook
If uMsg = HCBT_ACTIVATE Then
SetWindowText wParam, mTitle
SetDlgItemText wParam, IDPROMPT, mPrompt
Select Case mbFlags
Case vbAbortRetryIgnore, _
vbAbortRetryIgnore + vbDefaultButton1, _
vbAbortRetryIgnore + vbDefaultButton2, _
vbAbortRetryIgnore + vbDefaultButton3
SetDlgItemText wParam, IDABORT, But1
SetDlgItemText wParam, IDRETRY, But2
SetDlgItemText wParam, IDIGNORE, But3
Case vbYesNoCancel, _
vbYesNoCancel + vbDefaultButton1, _
vbYesNoCancel + vbDefaultButton2, _
vbYesNoCancel + vbDefaultButton3
SetDlgItemText wParam, IDYES, But1
SetDlgItemText wParam, IDNO, But2
SetDlgItemText wParam, IDCANCEL, But3
Case vbOKOnly
SetDlgItemText wParam, IDOK, But1
Case vbRetryCancel, _
vbRetryCancel + vbDefaultButton1, _
vbRetryCancel + vbDefaultButton2
SetDlgItemText wParam, IDRETRY, But1
SetDlgItemText wParam, IDCANCEL, But2
Case vbYesNo, _
vbYesNo + vbDefaultButton1, _
vbYesNo + vbDefaultButton2
SetDlgItemText wParam, IDYES, But1
SetDlgItemText wParam, IDNO, But2
Case vbOKCancel, _
vbOKCancel + vbDefaultButton1, _
vbOKCancel + vbDefaultButton2
SetDlgItemText wParam, IDOK, But1
SetDlgItemText wParam, IDCANCEL, But2
End Select
UnhookWindowsHookEx MSGHOOK.hHook
End If
MsgBoxHookProc = False
End Function
Function APIMsgBox(lHwnd As Long, _
mMsgbox As VbMsgBoxStyle, _
strTitle As String, _
strPrompt As String, _
Optional mMsgIcon As VbMsgBoxStyle, _
Optional strButA As String, _
Optional strButB As String, _
Optional strButC As String) As String
'This function sets your custom parameters and returns
'which button was pressed as a string
Dim mReturn As Long
mbFlags = mMsgbox
mbFlags2 = mMsgIcon
mTitle = strTitle
mPrompt = strPrompt
But1 = strButA
But2 = strButB
But3 = strButC
mReturn = MessageBoxH(lHwnd, _
GetDesktopWindow(), _
mbFlags Or mbFlags2, _
strTitle, _
strPrompt)
Select Case mReturn
Case IDABORT
APIMsgBox = But1
Case IDRETRY
APIMsgBox = But2
Case IDIGNORE
APIMsgBox = But3
Case IDYES
APIMsgBox = But1
Case IDNO
APIMsgBox = But2
Case IDCANCEL
APIMsgBox = But3
Case IDOK
APIMsgBox = But1
End Select
End Function
Sub Test()
Dim strReturn As String
strReturn = APIMsgBox(Application.hwnd, _
vbYesNoCancel + vbDefaultButton2, _
"Messagebox Title", _
"Messagebox Prompt", , _
"Button 1", _
"Button 2", _
"Button 3")
MsgBox "You pressed " & strReturn
End Sub
Messagebox API and
after altering some code I found it seems this is working nicely. I know I
could use a Userform for
this, but I want to keep resources down and wasn't keen to add yet another
Userform to the project.
The only thing that is a slight problem is that the buttons don't resize
with the caption, but I can keep
the caption lenghth down.
The other thing is that this msgbox is modeless and that would seem a good
thing, but I am just wondering
if anybody is aware of any problems that could arise from this code:
Option Explicit
Private Const MB_YESNOCANCEL = &H3&
Private Const MB_YESNO = &H4&
Private Const MB_RETRYCANCEL = &H5&
Private Const MB_OKCANCEL = &H1&
Private Const MB_OK = &H0&
Private Const MB_ABORTRETRYIGNORE = &H2&
Private Const MB_ICONEXCLAMATION = &H30&
Private Const MB_ICONQUESTION = &H20&
Private Const MB_ICONASTERISK = &H40&
Private Const MB_ICONINFORMATION = MB_ICONASTERISK
Private Const IDOK = 1
Private Const IDCANCEL = 2
Private Const IDABORT = 3
Private Const IDRETRY = 4
Private Const IDIGNORE = 5
Private Const IDYES = 6
Private Const IDNO = 7
Private Const IDPROMPT = &HFFFF&
Private Const WH_CBT = 5
Private Const GWL_HINSTANCE = (-6)
Private Const HCBT_ACTIVATE = 5
Private Type MSGBOX_HOOK_PARAMS
hwndOwner As Long
hHook As Long
End Type
Private MSGHOOK As MSGBOX_HOOK_PARAMS
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Public Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetWindowLong Lib "user32" Alias _
"GetWindowLongA" (ByVal hwnd As Long,
_
ByVal nIndex As
Long) As Long
Private Declare Function MessageBox Lib "user32" _
Alias "MessageBoxA" (ByVal hwnd As Long,
_
ByVal lpText As
String, _
ByVal lpCaption As
String, _
ByVal wType 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 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 SetWindowText _
Lib "user32" _
Alias "SetWindowTextA" (ByVal hwnd As Long, _
ByVal lpString As
String) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) As Long
Private mbFlags As VbMsgBoxStyle
Private mbFlags2 As VbMsgBoxStyle
Private mTitle As String
Private mPrompt As String
Private But1 As String
Private But2 As String
Private But3 As String
Function FARPROC(ByVal pfn As Long) As Long
'Procedure that receives and returns
'the passed value of the AddressOf operator.
'This workaround is needed as you can't assign
'AddressOf directly to a member of a user-
'defined type, but you can assign it to another
'long and use that (as returned here)
FARPROC = pfn
End Function
Function MessageBoxH(hwndThreadOwner As Long, _
hwndOwner As Long, _
mbFlags As VbMsgBoxStyle, _
strTitle As String, _
strPrompt As String) As Long
'This function calls the hook
Dim hInstance As Long
Dim hThreadId As Long
hInstance = GetWindowLong(hwndThreadOwner, GWL_HINSTANCE)
hThreadId = GetCurrentThreadId()
With MSGHOOK
.hwndOwner = hwndOwner
.hHook = SetWindowsHookEx(WH_CBT, _
FARPROC(AddressOf MsgBoxHookProc), _
hInstance, _
hThreadId)
End With
MessageBoxH = MessageBox(hwndOwner, _
strPrompt, _
strTitle, _
mbFlags)
End Function
Function MsgBoxHookProc(ByVal uMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
'This function catches the messagebox before it opens
'and changes the text of the buttons - then removes the hook
If uMsg = HCBT_ACTIVATE Then
SetWindowText wParam, mTitle
SetDlgItemText wParam, IDPROMPT, mPrompt
Select Case mbFlags
Case vbAbortRetryIgnore, _
vbAbortRetryIgnore + vbDefaultButton1, _
vbAbortRetryIgnore + vbDefaultButton2, _
vbAbortRetryIgnore + vbDefaultButton3
SetDlgItemText wParam, IDABORT, But1
SetDlgItemText wParam, IDRETRY, But2
SetDlgItemText wParam, IDIGNORE, But3
Case vbYesNoCancel, _
vbYesNoCancel + vbDefaultButton1, _
vbYesNoCancel + vbDefaultButton2, _
vbYesNoCancel + vbDefaultButton3
SetDlgItemText wParam, IDYES, But1
SetDlgItemText wParam, IDNO, But2
SetDlgItemText wParam, IDCANCEL, But3
Case vbOKOnly
SetDlgItemText wParam, IDOK, But1
Case vbRetryCancel, _
vbRetryCancel + vbDefaultButton1, _
vbRetryCancel + vbDefaultButton2
SetDlgItemText wParam, IDRETRY, But1
SetDlgItemText wParam, IDCANCEL, But2
Case vbYesNo, _
vbYesNo + vbDefaultButton1, _
vbYesNo + vbDefaultButton2
SetDlgItemText wParam, IDYES, But1
SetDlgItemText wParam, IDNO, But2
Case vbOKCancel, _
vbOKCancel + vbDefaultButton1, _
vbOKCancel + vbDefaultButton2
SetDlgItemText wParam, IDOK, But1
SetDlgItemText wParam, IDCANCEL, But2
End Select
UnhookWindowsHookEx MSGHOOK.hHook
End If
MsgBoxHookProc = False
End Function
Function APIMsgBox(lHwnd As Long, _
mMsgbox As VbMsgBoxStyle, _
strTitle As String, _
strPrompt As String, _
Optional mMsgIcon As VbMsgBoxStyle, _
Optional strButA As String, _
Optional strButB As String, _
Optional strButC As String) As String
'This function sets your custom parameters and returns
'which button was pressed as a string
Dim mReturn As Long
mbFlags = mMsgbox
mbFlags2 = mMsgIcon
mTitle = strTitle
mPrompt = strPrompt
But1 = strButA
But2 = strButB
But3 = strButC
mReturn = MessageBoxH(lHwnd, _
GetDesktopWindow(), _
mbFlags Or mbFlags2, _
strTitle, _
strPrompt)
Select Case mReturn
Case IDABORT
APIMsgBox = But1
Case IDRETRY
APIMsgBox = But2
Case IDIGNORE
APIMsgBox = But3
Case IDYES
APIMsgBox = But1
Case IDNO
APIMsgBox = But2
Case IDCANCEL
APIMsgBox = But3
Case IDOK
APIMsgBox = But1
End Select
End Function
Sub Test()
Dim strReturn As String
strReturn = APIMsgBox(Application.hwnd, _
vbYesNoCancel + vbDefaultButton2, _
"Messagebox Title", _
"Messagebox Prompt", , _
"Button 1", _
"Button 2", _
"Button 3")
MsgBox "You pressed " & strReturn
End Sub