[RESOLVED] MsgBox font properties

**Elroy** · Dec 15th, 2021, 02:15 PM

Here's one I could possibly work out on my own, as I already have an entire module dedicated to message boxes ... custom button captions, timeout, etc.

But one thing I've never worked out is how to manipulate the font (size, typeface, bold, etc) on the message box text. I'll admit that I didn't search, so there might already be something out there, IDK.

Also, I'll post my message box module. It might have calls to procedures outside of that module though, I'm not sure, and didn't check.

The one I use ALL THE TIME is my MsgBoxEx function. I just love that thing.

Code:

Option Explicit
'
Public Enum Msg4DefaultButtonEnum
    mbDefaultButton1 = 0
    mbDefaultButton2 = 256
    mbDefaultButton3 = 512
    mbDefaultButton4 = 768
End Enum
#If False Then ' Intellisense fix.
    Public mbDefaultButton1, mbDefaultButton2, mbDefaultButton3, mbDefaultButton4
#End If
Private Type MSGBOXPARAMS
    cbSize As Long
    hWndOwner As Long
    hInstance As Long
    lpszText As String
    lpszCaption As String
    dwStyle As Long
    lpszIcon As String
    dwContextHelpId As Long
    lpfnMsgBoxCallback As Long
    dwLanguageId As Long
End Type
Private Type HELPINFO
  cbSize As Long
  iContextType As Long
  iCtrlId As Long
  hItemHandle As Long
  dwContextId As Long
  X As Long
  Y As Long
End Type
'
Public Enum ButtonsAndIconEnum
    mbOkOnly = &H0&
    mbOKCancel = &H1&
    mbAbortRetryIgnore = &H2&
    mbYesNoCancel = &H3&
    mbYesNo = &H4&
    mbRetryCancel = &H5&
    '
    mbCritical = 16&
    mbQuestion = 32&
    mbExclamation = 48&
    mbInformation = 64&
End Enum
#If False Then ' Intellisense fix.
    Public mbYesNoCancel, mbYesNo, mbRetryCancel, mbOKCancel, mbOkOnly, mbAbortRetryIgnore
    Public mbCritical, mbExclamation, mbInformation, mbQuestion
#End If
'
Private Type MSGBOX_HOOK_PARAMS
   hWndOwner   As Long
   hHook       As Long
End Type
'
Private Declare Function MessageBoxIndirect Lib "user32" Alias "MessageBoxIndirectA" (lpMsgBoxParams As MSGBOXPARAMS) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function GetDesktopWindow Lib "user32" () 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 MessageBoxEx Lib "user32" Alias "MessageBoxExA" (ByVal hWnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal uType As Long, ByVal wLanguageId 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 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 IsWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Declare Function GetCapture Lib "user32" () As Long
'
Dim miStyle As Long
Dim msTitle As String
'
Dim TimerID As Long
Dim TimedOut As Boolean
'
Dim msBut1 As String
Dim msBut2 As String
Dim msBut3 As String
Dim msBut4 As String
'
Dim mhWndMsgBox As Long
Dim MSGHOOK4 As MSGBOX_HOOK_PARAMS
Dim MSGHOOK As MSGBOX_HOOK_PARAMS
Dim MSGHOOKHELP As MSGBOX_HOOK_PARAMS
'
Dim mbClicked4thButton As Boolean
Dim mbClickedX As Boolean
Dim mbAllowClose As Boolean
'

Public Function MsgBox4(hWndOwner As Long, message As String, _
                        sBut1 As String, sBut2 As String, sBut3 As String, sBut4 As String, _
                        Optional Icon As ButtonsAndIconEnum, Optional Default As Msg4DefaultButtonEnum, _
                        Optional AllowClose As Boolean, Optional Title As String) As String
    Dim mReturn As Long
    Dim MB As MSGBOXPARAMS
    Dim sTitle As String
    '
    Const WH_CBT = 5
    Const IDCANCEL = 2
    Const IDYES = 6
    Const IDNO = 7
    '
    Const VK_ESCAPE = &H1B
    '
    msBut1 = sBut1
    msBut2 = sBut2
    msBut3 = sBut3
    msBut4 = sBut4
    mbClicked4thButton = False
    mbClickedX = False
    mbAllowClose = AllowClose
    If Len(Title) Then sTitle = Title Else sTitle = App.Title
    '
    MB.cbSize = LenB(MB)
    MB.hWndOwner = hWndOwner
    MB.hInstance = App.hInstance
    MB.lpszText = message
    MB.lpszCaption = sTitle
    Icon = Icon And &H70&        ' This clears out any button specifications.
    MB.lpszIcon = Icon
    MB.dwContextHelpId = &H0
    MB.lpfnMsgBoxCallback = PtrToFn(AddressOf MsgBox4CallBack)
    MB.dwLanguageId = &H0
    MB.dwStyle = &H4003& Or Default  ' mbYesNoCancel And mbHelp = &H4003&
    '
    ' Trap until reasonable response.
    Do
        MSGHOOK4.hWndOwner = GetDesktopWindow()
        MSGHOOK4.hHook = SetWindowsHookEx(WH_CBT, AddressOf MsgBox4Hook, App.hInstance, GetCurrentThreadId())
        mReturn = MessageBoxIndirect(MB)
        If (GetKeyState(VK_ESCAPE) >= 0) Then ' We can't get out if they're on the ESC key.
            If mbClickedX Then
                If mbAllowClose Then Exit Do
            Else
                Exit Do
            End If
        End If
        mbClickedX = False
    Loop
    '
    ' Figure out return.
    Select Case True
    Case mbClicked4thButton:    MsgBox4 = msBut4
    Case mbClickedX:            MsgBox4 = "ClosedMsgBox"
    Case mReturn = IDYES:       MsgBox4 = msBut1
    Case mReturn = IDNO:        MsgBox4 = msBut2
    Case mReturn = IDCANCEL:    MsgBox4 = msBut3
    End Select
End Function

Public Sub MsgBoxHelp(hWndOwner As Long, message As String, Optional Title As String)
    ' This is used for quick-help.  It allows the user to "click off" the message box and have it auto-close.
    ' Also, just clicking anywhere on it also auto-closes it.
    ' It's limited to the "Information" icon, and just a "Close" button.
    
    '
    ' Need to explore using the following, as it's non-modal.
    ' MessageBoxEx 0&, "Here is my MessageBox test" & vbNewLine & "Go ahead and click else where I dare Ya!", "Look I don't hold things up", 0&, 0
    
    
    Dim mReturn As Long
    Dim hInstance As Long
    Dim hThreadId As Long
    Dim sTitle As String
    '
    Const WH_CBT = 5
    '
    hInstance = App.hInstance
    hThreadId = GetCurrentThreadId()
    If Len(Title) Then sTitle = Title Else sTitle = App.Title
    MSGHOOKHELP.hWndOwner = hWndOwner
    MSGHOOKHELP.hHook = SetWindowsHookEx(WH_CBT, AddressOf MsgHelpHookProc, hInstance, hThreadId)
    '
    mReturn = MessageBox(hWndOwner, message, sTitle, mbOkOnly Or mbInformation)
End Sub

Public Function MsgBoxEx(hWndOwner As Long, ButtonsAndIcon As ButtonsAndIconEnum, message As String, _
                         ButA As String, Optional ButB As String, Optional ButC As String, _
                         Optional MilliSeconds As Long, Optional Title As String) As String
    ' This function sets your custom parameters and returns which button was pressed as a string.
    ' If a message box is a style with a "Cancel" button, the "X" on the form will be enabled.
    ' If the "X" of the form is pressed, the text of the last button (corresponding to cancel) will be returned.
    ' On an mbOkOnly textbox, the "X" will return the OK button.
    ' MilliSeconds is a timer.  If it times out, the function returns "TimedOut" string.  Can't be used with (mbAbortRetryIgnore and mbYesNo styles).
    '
    Dim mReturn As Long
    Dim hInstance As Long
    Dim hThreadId As Long
    '
    Const WH_CBT = 5
    Const GWL_HINSTANCE = -6
    '
    Const IDOK = 1
    Const IDCANCEL = 2
    Const IDAbort = 3
    Const IDRETRY = 4
    Const IDIGNORE = 5
    Const IDYES = 6
    Const IDNO = 7
    '
    miStyle = ButtonsAndIcon And &H7&       ' This isolates the buttons.
    If Len(Title) Then msTitle = Title Else msTitle = App.Title
    msBut1 = ButA
    msBut2 = ButB
    msBut3 = ButC
    '
    hInstance = App.hInstance
    hThreadId = GetCurrentThreadId()
    MSGHOOK.hWndOwner = GetDesktopWindow()
    MSGHOOK.hHook = SetWindowsHookEx(WH_CBT, AddressOf MsgBoxHookProc, hInstance, hThreadId)
    '
    ' No default value is defined for mbAbortRetryIgnore and mbYesNo message box styles.
    ' In other words, the close (x) button is disabled, and the timer can NOT close the box.
    ' Therefore, timer can't be used.
    If miStyle = mbAbortRetryIgnore Or miStyle = mbYesNo Then MilliSeconds = 0
    If MilliSeconds <> 0 Then TimerID = SetTimer(0&, 0&, MilliSeconds, AddressOf MsgBoxTimerProc)
    '
    mReturn = MessageBox(hWndOwner, message, Space$(120), ButtonsAndIcon)
    '
    If TimerID <> 0 Then KillTimer 0&, TimerID: TimerID = 0
    If TimedOut Then
        MsgBoxEx = "TimedOut"
        TimedOut = False
    Else
        Select Case mReturn
        Case IDOK:            MsgBoxEx = msBut1
        Case IDAbort:         MsgBoxEx = msBut1
        Case IDRETRY:         MsgBoxEx = msBut2
        Case IDIGNORE:        MsgBoxEx = msBut3
        Case IDYES:           MsgBoxEx = msBut1
        Case IDNO:            MsgBoxEx = msBut2
        Case IDCANCEL ' This may be the second or third button.
            If miStyle = mbYesNoCancel Then
                MsgBoxEx = msBut3
            Else
                MsgBoxEx = msBut2
            End If
        End Select
    End If
End Function

Public 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.
    Dim r As RECT
    '
    Const IDPROMPT = &HFFFF&
    Const IDOK = 1
    Const IDCANCEL = 2
    Const IDAbort = 3
    Const IDRETRY = 4
    Const IDIGNORE = 5
    Const IDYES = 6
    Const IDNO = 7
    Const HCBT_ACTIVATE = 5
    '
    If uMsg = HCBT_ACTIVATE Then
        mhWndMsgBox = wParam
        '
        SetWindowText wParam, msTitle
        'SetDlgItemText wParam, IDPROMPT, mPrompt
        Select Case miStyle
        Case vbAbortRetryIgnore
            SetDlgItemText wParam, IDAbort, msBut1
            SetDlgItemText wParam, IDRETRY, msBut2
            SetDlgItemText wParam, IDIGNORE, msBut3
        Case vbYesNoCancel
            SetDlgItemText wParam, IDYES, msBut1
            SetDlgItemText wParam, IDNO, msBut2
            SetDlgItemText wParam, IDCANCEL, msBut3
        Case vbOKOnly
            SetDlgItemText wParam, IDOK, msBut1
        Case vbRetryCancel
            SetDlgItemText wParam, IDRETRY, msBut1
            SetDlgItemText wParam, IDCANCEL, msBut2
        Case vbYesNo
            SetDlgItemText wParam, IDYES, msBut1
            SetDlgItemText wParam, IDNO, msBut2
        Case vbOKCancel
            SetDlgItemText wParam, IDOK, msBut1
            SetDlgItemText wParam, IDCANCEL, msBut2
        End Select
        UnhookWindowsHookEx MSGHOOK.hHook
    End If
    MsgBoxHookProc = False
End Function

Public Function MsgBoxTimerProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long) As Long
    Const WM_CLOSE = &H10
    If IsWindow(mhWndMsgBox) Then
        PostMessage mhWndMsgBox, WM_CLOSE, 0, ByVal 0&
        TimedOut = True
    End If
End Function

Public Function PtrToFn(ByVal param As Long) As Long
    PtrToFn = param
End Function

Public Sub MsgBox4CallBack(lpHelpInfo As HELPINFO)
    Const VK_F1 = &H70
    Const WM_CLOSE = &H10
    '
    If GetKeyState(VK_F1) < 0 Then Exit Sub ' Ignore F1 key.
    mbClicked4thButton = True
    PostMessage mhWndMsgBox, WM_CLOSE, 0, ByVal 0&
End Sub

Public Function MsgBox4Hook(ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Const IDCANCEL = 2
    Const IDYES = 6
    Const IDNO = 7
    Const IDHELP = 9
    Const HCBT_ACTIVATE = 5
    Const HCBT_DESTROYWND = 4
    Const HCBT_SYSCOMMAND = 8
    Const VK_LBUTTON = &H1
    '
    If Not mbClicked4thButton Then
        If uMsg = HCBT_SYSCOMMAND Then
            ' If we're dragging the message box, don't set mbClickedX.
            If GetKeyState(VK_LBUTTON) >= 0 Then mbClickedX = True
        End If
    End If
    '
    Select Case uMsg
    Case HCBT_ACTIVATE
        mhWndMsgBox = wParam
        SetDlgItemText wParam, IDYES, msBut1
        SetDlgItemText wParam, IDNO, msBut2
        SetDlgItemText wParam, IDCANCEL, msBut3
        SetDlgItemText wParam, IDHELP, msBut4
    Case HCBT_DESTROYWND
        UnhookWindowsHookEx MSGHOOK4.hHook
    End Select
End Function

Public Function MsgHelpHookProc(ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Static MouseWasDown As Boolean
    Static hWndMsg As Long
    '
    Const IDOK = 1
    Const HCBT_ACTIVATE = 5
    Const HCBT_DESTROYWND = 4
    Const HCBT_CLICKSKIPPED = 6
    Const WM_CLOSE = &H10
    Const VK_LBUTTON = &H1
    '
    Select Case uMsg
    Case HCBT_ACTIVATE
        If hWndMsg = 0 Then
            hWndMsg = wParam
            SetDlgItemText wParam, IDOK, "Close"
        End If
        MouseWasDown = False
    Case HCBT_DESTROYWND
        UnhookWindowsHookEx MSGHOOKHELP.hHook
        MouseWasDown = False
        hWndMsg = 0
    Case HCBT_CLICKSKIPPED
        If MouseWasDown Then
            If GetKeyState(VK_LBUTTON) >= 0 Then ' Mouse is up.  (If not, we're dragging.)
                PostMessage hWndMsg, WM_CLOSE, 0, ByVal 0&
                MouseWasDown = False
            End If
        Else
            ' Let's only do it if we're clicking on some other window.
            If GetCapture <> hWndMsg Then MouseWasDown = GetKeyState(VK_LBUTTON) < 0
        End If
    Case Else
        MouseWasDown = False
    End Select
    '
    MsgHelpHookProc = False
End Function

But the option to change the message font would be really cool.

p.s. Heading out to dentist, so I'll see y'all in a few hours.

Thread: [RESOLVED] MsgBox font properties

Thread Tools

Display

Threaded View

[RESOLVED] MsgBox font properties

Posting Permissions