Customized msgbox

[Pipe2Path]

I would like to know if there's anyway to
have your own button in a msgbox() function.
Instead of the standard constants vbYes, vbNo,
vbCancel etc. I just want a button to be called
say "Do This" instead of the standard ones.

Any API or something else someone can point me to?

Thx

 

[Golom]

Here's a custom message box that allows you to invoke a message box but pass an array of captions that replace the captions on the standard message box buttons.
[tt]
Option Explicit

Dim But(1 To 7, 1 To 2) As Integer
Dim bn(1 To 3) As String


'VBnet-defined control ID for the message prompt
Private Const IDPROMPT = &HFFFF&

'misc constants
Private Const WH_CBT = 5
Private Const GWL_HINSTANCE = (-6)
Private Const HCBT_ACTIVATE = 5

Public Type HookParms
WindowOwner As Long
xPos As Long
yPos As Long
hHook As Long
End Type

'UDT for passing data through the hook
Private Type MSGBOX_HOOK_PARAMS
hwndOwner As Long
hHook As Long
End Type

'need this declared at module level as
'it is used in the call and the hook proc
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


Public Function MsgBoxCaption(ByVal sCaption As String, _
Optional ByVal lParms As VbMsgBoxStyle = vbInformation, _
Optional ByVal sTitle As Variant = " ", _
Optional ByVal ButtonCount As Integer = 2, _
Optional ByRef ButtonNames As Variant, _
Optional ByVal lOwner As Variant) As Long

'Wrapper function for the MessageBox API
Dim hInstance As Long
Dim hThreadId As Long
Dim rv As Long
Dim n As Integer
Dim ButSel As Integer
Dim TheOwner As Long

On Error GoTo ErrorProc

'Figure out who owns the message box
If IsMissing(lOwner) Then
TheOwner = "&h" & Hex(0) ' Owner zero is the desktop.
ElseIf VarType(lOwner) = vbLong Then
TheOwner = "&h" & Hex(lOwner) ' Got a window handle as the owner.
ElseIf TypeOf lOwner Is Form Then
TheOwner = lOwner.hwnd ' Got a form as the owner. Pick up the handle.
End If

hInstance = GetWindowLong(TheOwner, GWL_HINSTANCE)
hThreadId = GetCurrentThreadId()

' Initialize all buttons to 'False' (i.e. not displayed)
For n = 1 To 7
But(n, 1) = False
But(n, 2) = 0
Next

' Copy the button names to a public array.
' Raise Errors if its not an array or does not have enough names.
If (VarType(ButtonNames) And vbArray) <> vbArray Then
Err.Raise 1050, "modMsgBoxRev", "Button Names must be an array"
Else
If UBound(ButtonNames, 1) < ButtonCount Then
Err.Raise 1051, "modMsgBoxRev", "Not Enough Button Names Supplied"
End If
End If

For n = 1 To UBound(ButtonNames, 1)
bn = ButtonNames
Next

' Figure out which buttons are displayed
If (lParms And vbRetryCancel) = vbRetryCancel Then
ButSel = vbRetryCancel
ElseIf (lParms And vbYesNo) = vbYesNo Then
ButSel = vbYesNo
ElseIf (lParms And vbYesNoCancel) = vbYesNoCancel Then
ButSel = vbYesNoCancel
ElseIf (lParms And vbAbortRetryIgnore) = vbAbortRetryIgnore Then
ButSel = vbAbortRetryIgnore
ElseIf (lParms And vbOKCancel) = vbOKCancel Then
ButSel = vbOKCancel
Else
ButSel = vbOK
End If

' Reset the parameters by removing the one they specified and
' adding one that provides 1, 2 or 3 buttons. Keep track of
' the buttons by consecutively numbering them from left to right.
If ButtonCount <= 1 Then
lParms = lParms - ButSel + vbOKOnly
But(vbOK, 1) = True
But(vbOK, 2) = 1
ElseIf ButtonCount = 2 Then
lParms = lParms - ButSel + vbYesNo
But(vbYes, 1) = True
But(vbNo, 1) = True
But(vbYes, 2) = 1
But(vbNo, 2) = 2
Else
lParms = lParms - ButSel + vbAbortRetryIgnore
But(vbAbort, 1) = True
But(vbRetry, 1) = True
But(vbIgnore, 1) = True
But(vbAbort, 2) = 1
But(vbRetry, 2) = 2
But(vbIgnore, 2) = 3
End If

'set up the MSGBOX_HOOK_PARAMS values
'By specifying a Windows hook as one
'of the params, we can intercept messages
'sent by Windows and thereby manipulate
'the dialog
With MSGHOOK
.hwndOwner = TheOwner
.hHook = SetWindowsHookEx(WH_CBT, _
AddressOf MBHooker, _
hInstance, hThreadId)
End With

' Message box returns a button number that is one of vbOK, vbYes, vbNo, etc.
' We need to translate those to the button number as displayed
' across the screen (Left = 1, Centre = 2, Right = 3)
rv = MessageBox(TheOwner, sCaption, sTitle, lParms)
MsgBoxCaption = But(rv, 2)

' If you want to return the standard Message Box button numbers then use
' MsgBoxCaption = rv

Exit Function

ErrorProc:
If Err.Number = 1050 Then
MsgBox Err.Description, vbCritical + vbOKOnly, "Array Required"
ElseIf Err.Number = 1051 Then
MsgBox Err.Description, vbCritical + vbOKOnly, "Not Enough Names"
Else
MsgBox Err.Number & " - " & Err.Description
End If

End Function


Public Function MBHooker(ByVal uMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long

Dim n As Long
Dim nBut As Integer

If uMsg = HCBT_ACTIVATE Then

' Set the caption for each of the displayed buttons
nBut = 0
For n = LBound(But, 1) To UBound(But, 1)
If But(n, 1) Then
nBut = nBut + 1
SetDlgItemText wParam, n, bn(nBut)
' Alternatively, you could load these button values from a
' resource file with a statement like:
'
' SetDlgItemText wParam, n, LoadResString(n + OffSet)
'
' Where 'OffSet' positions to the language that you are using.
End If
Next

'we're done with the dialog, so release the hook
UnhookWindowsHookEx MSGHOOK.hHook

End If

'return False to let normal processing continue
MBHooker = False

End Function
'--end block--'
[/tt]

 

[BiggerBrother]

If you want a shorter version, simply create a public function, which makes a new form appear, force the form to be on top always, and ensure that it returns the user's chosen option to your routine.

BB

 

[strongm]

For the original, copyright code, see:

http://vbnet.mvps.org/index.html?code/hooks/messageboxhook.htm