[RESOLVED] MsgBox font properties

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.

I took a moment and checked. The following is the only external (within the project) reference that module has:

Code:

---


Public Type RECT
    Left  As Long
    Top  As Long
    Right As Long ' This is +1 (right - left = width)
    Bottom As Long ' This is +1 (bottom - top = height)
End Type



---

Have you tried subclassing the MsgBox and intercepting the WM_CTLCOLORDLG, WM_CTLCOLORSTATIC, WM_CTLCOLORBTN messages ? You could select the font you want (with its attributes) onto the MsgBox DC upon receiving the above messages.

I'd be curious about how you'd subclass a MsgBox.

I can set a hook for one. In fact, I'm doing that in the above code. I've just been looking at it and here are the messages I see for a simple MsgBox with just an OK button on it:

HCBT_CREATEWND ... three times. Obviously one is to create the whole MsgBox window, and another is for the button. I'm not sure what the third one is for, maybe for some kind of label/textbox where the actual text goes.
HCBT_SETFOCUS ... just once.
HCBT_ACTIVATE ... just once.

There may be more but I remove the hook once I see the HCBT_ACTIVATE, and I'm not sure there's much reason to keep it after that.

And, nowhere in there do I see a way to get an hDC for the message box (at least not in time to do anything with it). The only time I've actually got an hWnd is on HCBT_ACTIVATE, and by then, it's too late ... I think.

I used WH_CALLWNDPROC hook and watch for the creation of the MsgBox in the WM_CREATE message that is stored in the CWPSTRUCT structure pointed to by the lParam.

Once you have the MsgBox hwnd (also stored in the lParam) , subclass it the normal way.

The MsgBox DC (or Child DCs -depending on uMsg WM_CTLCOLORDLG or WM_CTLCOLORSTATIC or WM_CTLCOLORBTN) is stored in the wParam in the callback Window Procedure.

There may be better ways to do this but I remember doing this for a vba MsgBox and it worked fine.

Hmmm, ok, I see where you're going.

I just figured out how to change the message text by monitoring the callback for HCBT_ACTIVATE, and then using GetDlgItem (with IDPROMPT) and then SetWindowText. Using the return (the item's hWnd) of GetDlgItem, I could probably get an hDC and then change the font properties. But now I'm thinking that this won't resize the textbox for larger fonts.

Everything needs to be done earlier than this. Maybe it's not possible because of the MsgBox system being so integrated with Windows.

I could certainly use some of that information to subclass the message box, or even any of the child windows on it.

Quote:

---

But now I'm thinking that this won't resize the textbox for larger fonts.

---

Yes, that is probably the hardest.

One workaround is to temporarly change the NONCLIENTMETRICS.lfMessageFont using SystemParametersInfo(SPI_SETNONCLIENTMETRICS...

Obviously, this has a system global effect so it is important to cache the initial system settings (SPI_GETNONCLIENTMETRICS) to be able to restore it when the MsgBox is closed.

Attachment 183305

Quote:

---

Originally Posted by Elroy

Hmmm, ok, I see where you're going.

I just figured out how to change the message text by monitoring the callback for HCBT_ACTIVATE, and then using GetDlgItem (with IDPROMPT) and then SetWindowText. Using the return (the item's hWnd) of GetDlgItem, I could probably get an hDC and then change the font properties. But now I'm thinking that this won't resize the textbox for larger fonts.

Everything needs to be done earlier than this. Maybe it's not possible because of the MsgBox system being so integrated with Windows.

I could certainly use some of that information to subclass the message box, or even any of the child windows on it.

---

Maybe here? https://www.vbforums.com/showthread....SIZE-and-STYLE

Add this module to your application:-

Code:

---

'This module allows us to set the font and text colour of a window
'Note that not every thing in here may be used as this is an on going experiment.
'There may be some fat to trim after settling on a final solution
'***********************************************
'Written By Niya (Dec, 16, 2021)
'***********************************************
Public Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal h As Long) As Long
Public Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal color As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal ho As Long) As Long
Public Declare Function GetCurrentObject Lib "gdi32" (ByVal hDC As Long, ByVal uObjectType As Long) As Long
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal index As Long) As Long
Public Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Public Declare Function GetObjectW Lib "gdi32" (ByVal hObject As Long, ByVal nCount As Long, ByVal lpObject As Long) As Long
Public Declare Function CreateFontIndirectW Lib "gdi32" (ByVal lplf As Long) As Long

Public Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long
Public Declare Function GetDlgItem Lib "user32.dll" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
Public Declare Function SendMessageW Lib "user32.dll" (ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function GetClassNameW Lib "user32.dll" (ByVal hwnd As Long, ByVal lpClassName As Long, ByVal nMaxCount As Long) As Long
Public Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hDC As Long) As Long

Public Const LF_FACESIZE = 32
Public Const OBJ_FONT = 6
Public Const WM_SETFONT = &H30
Public Const LOGPIXELSY As Long = 90

Public Type LOGFONTW
        lfHeight As Long
        lfWidth As Long
        lfEscapement As Long
        lfOrientation As Long
        lfWeight As Long
        lfItalic As Byte
        lfUnderline As Byte
        lfStrikeOut As Byte
        lfCharSet As Byte
        lfOutPrecision As Byte
        lfClipPrecision As Byte
        lfQuality As Byte
        lfPitchAndFamily As Byte
        lfFaceName As String * LF_FACESIZE
End Type

Public Enum FontWeight
    Normal = 0
    Bold = 700
    Heavy = 900
End Enum

'Get the text control from a message box
Public Function GetDlgTextWindow(ByVal dlgHwnd As Long) As Long
    GetDlgTextWindow = GetDlgItem(dlgHwnd, &HFFFF&)
End Function

Public Function SetWindowFont(ByVal hwnd As Long, ByVal fontName As String, ByVal fontSize As Long, Optional ByVal FontWeight As FontWeight = Normal) As Long
   
    Dim hDC As Long
    Dim hFont As Long
    Dim fontData As LOGFONTW
    Dim hNewFont As Long
    Dim mbLblHwnd As Long
       
    hDC = GetDC(hwnd)
   
    If hDC <> 0 Then
        hFont = GetCurrentObject(hDC, OBJ_FONT)
       
      If CBool(GetObjectW(hFont, LenB(fontData), VarPtr(fontData))) Then
            'This is how we set a font size at the win32 level
            fontData.lfHeight = -(fontSize * (GetDeviceCaps(hDC, LOGPIXELSY) / 72))
           
            'Means we want our width to be adjusted based
            'on the height of the font set above
            fontData.lfWidth = 0
           
            fontData.lfWeight = FontWeight
           
            'Obvious?
            fontData.lfFaceName = fontName & vbNullChar
           
            'Create a new GDI font object
            hNewFont = CreateFontIndirectW(VarPtr(fontData))
            If hNewFont <> 0 Then
               
                SendMessageW hwnd, WM_SETFONT, hNewFont, 1
               
                SetWindowFont = hNewFont
            Else
                Err.Raise vbObjectError + 2022, , "Failed to create GDI Font object"
           
            End If
        Else
            Err.Raise vbObjectError + 2021, , "Failed to retrieve font data from device context"
        End If
   
   
    Else
        Err.Raise vbObjectError + 2020, , "Failed to get Window's device context"
   
    End If
   
    If Not CBool(ReleaseDC(hwnd, hDC)) Then
        Err.Raise vbObjectError + 2023, , "Failed to release device context"
    End If
   
End Function

Public Function GetWindowClass(ByVal hwnd As Long) As String
    Dim s As String
   
    s = Space(255)
   
  GetWindowClass = Left(s, GetClassNameW(hwnd, StrPtr(s), Len(s)))
End Function

---

Then add my modified version of one of your message box hooks:-

Code:

---

Public Function MsgHelpHookProc2(ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Static MouseWasDown As Boolean
    Static hWndMsg As Long
    Static hFont 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"
            hFont = SetWindowFont(GetDlgTextWindow(wParam), "MV Boli", 17, Normal)
        End If
       
        MouseWasDown = False
    Case HCBT_DESTROYWND
        UnhookWindowsHookEx MSGHOOKHELP.hHook
        MouseWasDown = False
        hWndMsg = 0
        DeleteObject hFont
    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
    '
    MsgHelpHookProc2 = False
End Function

---

Then modify your MsgBoxHelp function to use this modified hook:-

Code:

---

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 MsgHelpHookProc2, hInstance, hThreadId)
    '
    mReturn = MessageBox(hWndOwner, message, sTitle, mbOkOnly Or mbInformation)
End Sub

---

And finally you can test it like this:-

Code:

---

MsgBoxHelp Me.hwnd, "The big brown fox jumped over the lazy dog" & Space(500), "My title"

---

You should see this:-
https://www.vbforums.com/images/ieimages/2021/12/8.png

I highlighted in red the changes I made to the hook function and the MsgBoxHelp function in case you have any trouble identifying the changes otherwise.

Note that I have been unable to find a way to automatically resize the message box to accommodate the change in the font. However, it can be done manually by measuring the string and applying a bit of math. I'm certain you're skillful enough to do this on your own.

Quote:

---

Originally Posted by Elroy

I just figured out how to change the message text by monitoring the callback for HCBT_ACTIVATE, and then using GetDlgItem (with IDPROMPT) and then SetWindowText. Using the return (the item's hWnd) of GetDlgItem, I could probably get an hDC and then change the font properties.

---

This won't work. The message box creates two child windows with the class name Static. One is for the text and the other is most likely for the icon. You have to use SendMessage with a WM_SETFONT message to change the font of these controls. This is what I did in the code posted above.

Hi Niya. Yeah, I had already figured out the locked Textbox (or whatever it is) of the class "Static". And I was pursuing the path that you took. It's pretty cool what you did, no doubt. And thank you! :)

Just adding a couple more arguments to the MsgBoxHelp call (such as TypeFace and Size, and maybe others), saving them at the module level, and then picking them up in the callback, and we could specify any font we wanted.

There's just one problem. We're still not getting that "Static" control nor the MsgBox window auto-resized for us...

Attachment 183312

Part of what I was hoping was that the internal MsgBox functions would take care of that as well. If I get motivated, I'll try "getting to things" a bit earlier. With Jaafar's pointers, I can see how to just subclass everything (especially the MsgBox window and the "Static" control) by monitoring the callback for HCBT_CREATEWND messages, and then using the wParam (which is the hWnd to the new window, after hWnd has been created but before the window has actually been all setup) to subclass things.

And then, in the subclass procedure, see if I can "catch" something to change the font early enough such that the resizing will still be automatic. I've got other things going on today, so I'm not sure when I'll get to it though. But I eventually will.

Again Niya, nice work to get this piece together.

p.s. To produce that picture of a MsgBox, I just changed your font size from 17 to 27. But just adding a longer message with 17 also has the same problem. Also, I attached a complete project with your code in case anyone wants to play with it. It's a bit piecemeal though as I just quickly threw it together to get it running.

Quote:

---

Originally Posted by Elroy

It's pretty cool what you did, no doubt. And thank you! :)

---

No problem. ;)

Quote:

---

Originally Posted by Elroy

There's just one problem. We're still not getting that "Static" control nor the MsgBox window auto-resized for us...

---

Actually, before you think about sub-classing, there might be a much simpler solution. I had actually intended to solve this too but I ran out of steam last night and had to go to bed. This actually took a couple hours of my time, but I don't mind. I like tackling problems like this in my spare time.

Anyways. What I wanted to do next was to see if changing the font of the Static control on the message box changes it's dimensions. Because if it does, all you would have to do is then is use these new dimensions to calculate a new bounding box for the message box itself and the you can use something like SetWindowPos to manually resize the message box and voila!

However, if changing the font of the Static controls doesn't change it's dimensions, then you may have to roll up your sleeves and measure the text yourself. This would be a little more involved depending on your approach but not impossible.

I strongly suspect that changing the font changes the Static control's dimensions though. I don't have time at this very moment but I can look into it if you want.

Quote:

---

Originally Posted by Elroy

Hi Niya. Yeah, I had already figured out the locked Textbox (or whatever it is) of the class "Static". And I was pursuing the path that you took. It's pretty cool what you did, no doubt. And thank you! :)

---

FWIW, a "Static"-Control (probably in C++) is what we usually call a "Label"-Control in vb6

Quote:

---

Originally Posted by Niya

I strongly suspect that changing the font changes the Static control's dimensions though.

---

That's a good point, and not difficult to check. I'll take a look at it.

Quote:

---

Originally Posted by Zvoni

FWIW, a "Static"-Control (probably in C++) is what we usually call a "Label"-Control in vb6

---

Zvoni, I don't think that's quite right. Labels are "light-weight" controls that really aren't controls at all, but rather just stuff drawn onto their parent. They don't even have a hWnd.

This MsgBox "static" control does have a hWnd. As such, it's more like a locked TextBox, but that's not quite true either because we can't copy-paste from it.

It's just some kind of special control for message boxes, sort of like a user control with a label on it.

Yea, Elroy is correct. The VB6 label control is a windowless control, not that different from controls in something like WPF where they don't actually exist at the OS level. However, the Static control does have a handle which means it was made by a call to CreateWindow which ultimately means that it's a real window that is maintained by the OS itself.

Ok I've been playing around with it and I was wrong. The Static control doesn't resize. It seems all of the layout logic is most likely done by the window procedure of the message box itself. I've also tested resizing the message box and the Static control manually which works but only partially. The close button on the message box doesn't move so you can end up with an awkward looking message box.

There are two solutions I can think of. The simpler one would be to measure the text and manually resize both the message box and the Static control and then manually move the button using SetWindowPos and some math.

The second solution would be to subclass the message box window and somehow make the necessary changes before all the layout operations are performed.

The first solution would be far easier to implement as it is very straightforward. The second solution however, would require a lot of guess work and experimentation and it's not even a guarantee it will succeed. The second solution would be way better though because we let Windows handle all the layout logic instead of having to do it ourselves.

Quote:

---

Originally Posted by Niya

The Static control doesn't resize.

---

Ahhh, that's disappointing to hear. I'm actually not home right now (just on my tablet), but I'll be thinking about this.

Niya, thanks for looking into this.

Ok, I managed to subclass the "Static" control (when I saw a HCBT_CREATEWND callback message), and then I monitored for WM_SETFONT in the subclass procedure. When I got it, I set that window's font and returned the subclass procedure as 0 for that one. It did manage to change the font, but it did precisely the same thing as it did in post #11. Maybe it's using the font to figure out the size even before it gets set for that control, IDK. I tried setting the font on several other WM_??? messages (prior to WM_SETFONT) and still short-circuited the actual WM_SETFONT message, but all that did was change the font to some "default" font and not the one I wanted. There weren't too many messages before the message box actually showed, and I basically tried them all.

Other than maybe temporarily changing the SYSTEM_FONT, which I'm not sure how to do, I'm not sure this one is doable.

Quote:

---

Originally Posted by Elroy

Other than maybe temporarily changing the SYSTEM_FONT, which I'm not sure how to do, I'm not sure this one is doable.

---

Easier would be, if you just concat an amount of Space-Chars (or non-breaking-space-chars) to the original message.

The right amount (the right ratio) could be calculated, by comparing:
1) TextWidth of your Msg with Fontsetting SegoeUI 9
2) TextWidth of your Msg with Fontsetting Whatever 22

Let's say #1) gives you 100 units and #2) gives you 300 units.
What you now calculate, is the amount of nbsp-chars, which have a textwidth (in Segoe 9pt),
that matches the difference of 200 Units.

And well, even easier than that would be a VB6-defined Msg-Form... ;)

Olaf

Quote:

---

Originally Posted by Schmidt

Easier would be, if you just concat an amount of Space-Chars (or non-breaking-space-chars) to the original message.

The right amount (the right ratio) could be calculated, by comparing:
1) TextWidth of your Msg with Fontsetting SegoeUI 9
2) TextWidth of your Msg with Fontsetting Whatever 22

Let's say #1) gives you 100 units and #2) gives you 300 units.
What you now calculate, is the amount of nbsp-chars, which have a textwidth (in Segoe 9pt),
that matches the difference of 200 Units.

And well, even easier than that would be a VB6-defined Msg-Form... ;)

Olaf

---

I absolutely cannot believe I didn't think of this! This is actually the most simple solution. And the thing is, I actually did it in an ad-hoc way when I did this in post #9:-

Code:

---

MsgBoxHelp Me.hwnd, "The big brown fox jumped over the lazy dog" & Space(500), "My title"

---

I just didn't continue thinking down that line. I like this solution and it's viable. Sometimes I wonder if you're some kind of alien from a super advanced race. I really have no idea why none of us thought of this.

Quote:

---

Originally Posted by Niya

I really have no idea why none of us thought of this.

---

Been there, done that, didn't work very quickly.

It's because there are always some horizontal pixels miscalculated with this "padding technique" or when the MsgBox finally decides to split a line (or two) with way to many spaces for its taste.

Besides how do you pad vertically? Extra new-lines?

cheers,
</wqw>

Well it doesn't have to be exact. Once you can get a decent enough approximation such that you won't end up clipping your message. Also about vertical padding, you could probably do something with CRLF characters. But I do see your point. There is some problems here definitely but this might be the only solution outside of creating our own message box from scratch.

Quote:

---

Originally Posted by Schmidt

And well, even easier than that would be a VB6-defined Msg-Form... ;)

---

You could easily do that for a message box with a sub-set of functionality. However, it is actually a lot of work if you want the full functionality of the Windows User32 message box. Interestingly enough my research on this topic did reveal that a lot of people actually take this route of rolling their own. I've even ran into a couple libraries here and there that provided user-made fully functional message boxes.

Even I have done this. I wrote a message box class years ago in .Net made specifically for reporting untrapped run time errors. I did it so I could do some fancy UI tricks like coloured headers for each exception that was thrown in an exception chain. However, it is not even close to being a fully functional message box with all the flags for different buttons and icons etc. It could not be used as a general purpose message box. It would have taken too much time to re-invent all that.

Quote:

---

Originally Posted by Schmidt

even easier than that would be a VB6-defined Msg-Form

---

Truth be told, that's about where I'm at. If I have to mess with moving/resizing all the controls of the internal message box (and its form), it starts looking like more work than just making our own message box.

I just really like the Windows message box, but the older I get, the more I like bumping up my font sizes a bit.

I knew this wouldn't be easy, but I didn't think it'd be this much work. I'm about to mark this one as [ABANDONED].

I did learn one thing though (which I did during this discussion). I can fairly easily change the color of the message text if I wanted to, or, for that matter, the color of any of the button text.

I decided to do one final search on the problem and it seems that others were exactly where you are. They also echo what I say earlier when I said you would have to do a lot of manual layout work yourself to accomodate larger font sizes. This SO thread resembles this thread. So yea, you might be right. It might be time to roll up your sleeves and re-invent the wheel here.

I'll do one more pass at this with with Olaf's idea of using padding spaces in the message itself and see how that turns out. I never really know when to give up sometimes lol ;)

Have you considered changing the NONCLIENTMETRICS.lfMessageFont as I suggested in post#7 ?

If you do that, the system will take care of resizing the MsgBox and its controls to accomodate the larger (or smaller) Font.. therefore you won't need to do any complicated size adjustements yourself.

Hmmm, Jaafar, maybe the full meaning of that got by me the first time. Thanks for bumping that suggestion.

But, truth be told, I read "NONCLIENT..." and thought we'd just be talking about such things as a form's titlebar. Hmmm, but maybe that would include the text area of a control (like that "Static") control.

I'm also not sure of a couple of other things: 1) Where would I get/set that? In the callback's HCBT_CREATEWND for the message box?, in the callback's HCBT_CREATEWND for the "static" control?, possibly still subclass and wait for one of the WM_CREATE messages?

Also, you said it's a system-wide setting, but it doesn't seem that way in the MSDN:

Quote:

---

SPI_SETNONCLIENTMETRICS (0x002A)

Sets the metrics associated with the nonclient area of nonminimized windows. The pvParam parameter must point to a NONCLIENTMETRICS structure that contains the new parameters. Set the cbSize member of this structure and the uiParam parameter to sizeof(NONCLIENTMETRICS). Also, the lfHeight member of the LOGFONT structure must be a negative value.

---

Are you suggesting we set it for the desktop window, which will possibly be used as a template for the message box (and its "static" control)?

---

p.s. I'm certainly willing to keep poking at this thing if I've got some reasonable way to proceed.

p.p.s. I keep reading that MSDN paragraph over and over. "nonminimized windows". Hmmm, does that mean ALL nonminimized windows? If that's so, yeah, that'd be interesting.

hahaha, I've actually done something similar before. Ok, I've got something to play with ... not terribly sure about it though.

Yes the NONCLIENT is misleading but it works for all controls with text.

It is system wide so you must store the initial NONMETRICS of your system so you can restore it when done. It is very important.


This doesn't need any subclassing of the MsgBox.

The subclassing will only be needed for other things like Font Color, controls backcolor etc ...

If you have office installed, you can take a look at the following excel workbook... Try with diffrent font sizes and you will see that Msgbox + controls with text resize automatically

MsgBoxTextResize2.xls

Hi Jaafar, I've already got it working. And yeah, it's definitely system wide. I mis-read the MSDN blurb on that. I'll have to think about the full impact of that a bit more, but it might be OK.

I'm still playing with it, but I'll post a VB6 example as soon as I've got something cleaned up.

Yep, easy peasy once enough information is available.

EDIT: I originally had a bug in setting the font name, and that's now fixed. Also, I put in a check to only allow a font name change if a TrueType font is specified.

Concept code for a Form1:

Code:

---


Option Explicit
'
Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName(31) As Byte
End Type
'
Private Type NONCLIENTMETRICS
    cbSize As Long
    iBorderWidth As Long
    iScrollWidth As Long
    iScrollHeight As Long
    iCaptionWidth As Long
    iCaptionHeight As Long
    lfCaptionFont As LOGFONT
    iSMCaptionWidth As Long
    iSMCaptionHeight As Long
    lfSMCaptionFont As LOGFONT
    iMenuWidth As Long
    iMenuHeight As Long
    lfMenuFont As LOGFONT
    lfStatusFont As LOGFONT
    lfMessageFont As LOGFONT
End Type
'
Private Type TEXTMETRIC
    tmHeight As Long
    tmAscent As Long
    tmDescent As Long
    tmInternalLeading As Long
    tmExternalLeading As Long
    tmAveCharWidth As Long
    tmMaxCharWidth As Long
    tmWeight As Long
    tmOverhang As Long
    tmDigitizedAspectX As Long
    tmDigitizedAspectY As Long
    tmFirstChar As Byte
    tmLastChar As Byte
    tmDefaultChar As Byte
    tmBreakChar As Byte
    tmItalic As Byte
    tmUnderlined As Byte
    tmStruckOut As Byte
    tmPitchAndFamily As Byte
    tmCharSet As Byte
End Type
'
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Dest As Any, ByRef Source As Any, ByVal Bytes As Long)
Private Declare Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (ByRef Dest As Any, ByVal Bytes As Long, Optional ByVal Fill As Byte)
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As NONCLIENTMETRICS, ByVal fuWinIni As Long) As Long
Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetCurrentObject Lib "gdi32" (ByVal hDC As Long, ByVal uObjectType As Long) As Long
Private Declare Function GetObjectA Lib "gdi32" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function CreateFontIndirectA Lib "gdi32" (lpLogFont As LOGFONT) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" (ByVal hDC As Long, lpMetrics As TEXTMETRIC) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
'





Private Sub Form_Activate()
    MsgBoxWithFont "The big brown fox jumped over the lazy dog.", , , , , , 60&
End Sub

Private Sub Form_Click()
    MsgBoxWithFont "The big brown fox jumped over the lazy dog again and again and again and again and again.", , , , , , 60&
End Sub



Public Function MsgBoxWithFont(Prompt As String, _
                              Optional Buttons As VbMsgBoxStyle = vbOKOnly, Optional Title As String = "use default", Optional HelpFile As String, Optional Context As Long, _
                              Optional FontName As String = "Segoe UI", Optional FontSize As Long) As VbMsgBoxResult
    ' Four caveats:
    '  One:    The font you use must be a TrueType font.  You can default the font and just use size if you like, and it'll use "Segoe UI" if it's on your system.
    '  Two:    If you break within this procedure, you should allow the last line to execute to make sure your system metrics get reset.
    '  Three:  You should make VERY sure you use a FontName that's on your system, or things may not work correctly, fouling up your system metrics.
    '  Four:  While displaying a message box this way, other programs with message boxes will also be changed for these font changes.
    '
    Dim OrigNCM    As NONCLIENTMETRICS
    Dim NewNCM      As NONCLIENTMETRICS
    Dim bChangeFont As Boolean
    '
    ' Validate font change.
    If FontSize > 0& Then bChangeFont = FontIsTrueType(FontName)
    '
    If bChangeFont Then
        ' Save original metrics.
        OrigNCM.cbSize = Len(OrigNCM)
        Const SPI_GETNONCLIENTMETRICS  As Long = 41&
        Call SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0&, OrigNCM, 0&) ' Get the system NONCLIENTMETRICS.
        ' Fix up our new metrics with our font face and size.
        Const LOGPIXELSY              As Long = 90&
        Const SPIF_UPDATEINIFILE      As Long = 1&
        NewNCM = OrigNCM
        FillMemory NewNCM.lfMessageFont.lfFaceName(0&), 32&
        Dim bb() As Byte
        bb = StrConv(FontName, vbFromUnicode)
        CopyMemory NewNCM.lfMessageFont.lfFaceName(0&), bb(0&), Len(FontName)
        NewNCM.lfMessageFont.lfHeight = -MulDiv(FontSize, GetDeviceCaps(Me.hDC, LOGPIXELSY), 72&)
        ' Set the new metrics.
        Const SPIF_SENDWININICHANGE    As Long = 2&
        Const SPI_SETNONCLIENTMETRICS  As Long = 42&
        Call SystemParametersInfo(SPI_SETNONCLIENTMETRICS, 0&, NewNCM, SPIF_SENDWININICHANGE)
    End If
    '
    ' Show the message box.
    If Title = "use default" Then ' Must do this because it'll be blank if that's the default.
        MsgBoxWithFont = MsgBox(Prompt, Buttons, , HelpFile, Context)
    Else
        MsgBoxWithFont = MsgBox(Prompt, Buttons, Title, HelpFile, Context)
    End If
    '
    ' Reset our metrics.
    If bChangeFont Then Call SystemParametersInfo(SPI_SETNONCLIENTMETRICS, 0&, OrigNCM, SPIF_SENDWININICHANGE)
End Function

Public Function FontIsTrueType(sFontName As String) As Boolean
    If Not FontExists(sFontName) Then Exit Function ' Just get out if the font doesn't exist.
    '
    ' Just use the screen DC.
    Dim hDC            As Long
    hDC = GetDC(0&)
    '
    ' Just an easy way to get a font to work with.
    Dim hOldFont      As Long
    Const OBJ_FONT    As Long = 6&
    hOldFont = GetCurrentObject(hDC, OBJ_FONT)
    '
    ' Now we'll get the font's structure.
    Dim lf              As LOGFONT
    GetObjectA hOldFont, Len(lf), lf
    '
    ' And change the name in that structure.
    FillMemory lf.lfFaceName(0&), 32&
    Dim bb() As Byte
    bb = StrConv(sFontName, vbFromUnicode)
    CopyMemory lf.lfFaceName(0&), bb(0), Len(sFontName)
    '
    ' And create a new font with that.
    Dim hNewFont      As Long
    hNewFont = CreateFontIndirectA(lf)
    '
    ' Now we set our new font into our DC.
    hOldFont = SelectObject(hDC, hNewFont)
    '
    ' And finally we're ready to get the font name's metrics.
    Dim tm As TEXTMETRIC
    GetTextMetrics hDC, tm
    '
    ' And check if it's TrueType.
    Const TMPF_TRUETYPE As Byte = 4
    FontIsTrueType = (tm.tmPitchAndFamily And TMPF_TRUETYPE) <> 0
    '
    ' Put everything back and do clean-up.
    SelectObject hDC, hOldFont
    DeleteObject hNewFont
    ReleaseDC 0&, hDC
End Function

Public Function FontExists(sFontName As String) As Boolean
    Dim i As Long
    For i = 0& To Screen.FontCount - 1&
        If Screen.Fonts(i) = sFontName Then
            Debug.Print Screen.Fonts(i)
            FontExists = True
            Exit Function
        End If
    Next
End Function



---

p.s. Be sure to read the "Caveat" comments.

Off topic, but can similar be done to an ordinary command button to change the font colour?

Quote:

---

Originally Posted by yereverluvinuncleber

Off topic, but can similar be done to an ordinary command button to change the font colour?

---

I use this RTB button I've got to do that, but I'm thinking there's probably some easy way to do that which wouldn't even require subclassing.

Here's the link to the RTF Button and Label in case you'd like to use those. I use them all the time. There's also a little overlay editor so you can edit the text right on top of the control.

p.s. I played with the regular command button a bit, and it does look like it'd take a bit of subclassing to get it done.

Quote:

---

Originally Posted by Elroy

Yep, easy peasy once enough information is available.

Concept code for a Form1:

Code:

---


Option Explicit
'
Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName(31) As Byte
End Type
'
Private Type NONCLIENTMETRICS
    cbSize As Long
    iBorderWidth As Long
    iScrollWidth As Long
    iScrollHeight As Long
    iCaptionWidth As Long
    iCaptionHeight As Long
    lfCaptionFont As LOGFONT
    iSMCaptionWidth As Long
    iSMCaptionHeight As Long
    lfSMCaptionFont As LOGFONT
    iMenuWidth As Long
    iMenuHeight As Long
    lfMenuFont As LOGFONT
    lfStatusFont As LOGFONT
    lfMessageFont As LOGFONT
End Type
'
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Dest As Any, ByRef Source As Any, ByVal Bytes As Long)
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As NONCLIENTMETRICS, ByVal fuWinIni As Long) As Long
Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
'



Private Sub Form_Activate()
    MsgBoxWithFont "The big brown fox jumped over the lazy dog", , , , , "Segoe UI", 60&
End Sub

Private Sub Form_Click()
    MsgBoxWithFont "The big brown fox jumped over the lazy dog again", , , , , "Segoe UI", 60&
End Sub



Public Function MsgBoxWithFont(Prompt As String, _
                              Optional Buttons As VbMsgBoxStyle = vbOKOnly, Optional Title As String, Optional HelpFile As String, Optional Context As Long, _
                              Optional FontName As String, Optional FontSize As Long) As VbMsgBoxResult
    ' Three caveats:
    '  One:    If you break within this procedure, you should allow the last line to execute to make sure your system metrics get reset.
    '  Two:    You should make VERY sure you use a FontName that's on your system, or things may not work correctly, fouling up your system metrics.
    '  Three:  While displaying a message box this way, other programs with message boxes will also be changed for these font changes.
    '
    Dim OrigNCM As NONCLIENTMETRICS
    Dim NewNCM  As NONCLIENTMETRICS
    '
    ' Save original metrics.
    OrigNCM.cbSize = Len(OrigNCM)
    Const SPI_GETNONCLIENTMETRICS  As Long = 41&
    Call SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0&, OrigNCM, 0&) ' Get the system NONCLIENTMETRICS.
    '
    ' Fix up our new metrics with our font face and size.
    Const LOGPIXELSY              As Long = 90&
    Const SPIF_UPDATEINIFILE      As Long = 1&
    NewNCM = OrigNCM
    CopyMemory NewNCM.lfMessageFont.lfFaceName(0&), StrConv(FontName, vbFromUnicode), Len(FontName)
    NewNCM.lfMessageFont.lfHeight = -MulDiv(FontSize, GetDeviceCaps(Me.hdc, LOGPIXELSY), 72&)
    '
    ' Set the new metrics.
    Const SPIF_SENDWININICHANGE    As Long = 2&
    Const SPI_SETNONCLIENTMETRICS  As Long = 42&
    Call SystemParametersInfo(SPI_SETNONCLIENTMETRICS, 0&, NewNCM, SPIF_SENDWININICHANGE)
    '
    ' Show the message box.
    MsgBoxWithFont = MsgBox(Prompt, Buttons, Title, HelpFile, Context)
    '
    ' Reset our metrics.
    Call SystemParametersInfo(SPI_SETNONCLIENTMETRICS, 0&, OrigNCM, SPIF_SENDWININICHANGE)
End Function



---

p.s. Be sure to read the "Caveat" comments.

---

Did this actually work? I tried to run it and it crashed the IDE. Going to try running VB6 elevated....

EDIT:

Doesn't work when elevated either. It still crashes for me.

Wow, that's weird. Yeah, it works perfectly for me. Now I'm wondering why it didn't work for you.

Attachment 183336

That's shrunk by about 50% because the message box was so big. Look at it's titlebar to get an idea.

I compiled it and that worked fine too.

Its working here, IDE elevated.

The way it happens is similar to what happens when you screw up a RtlMoveMemory call end up writing or reading memory you're not supposed to. I'll have to go over the code in detail to see if there is not something like an off-by-one error or something.

Gosh, all we need now is to add a red rubber nose, floppy shoes, and steam calliope music.

Quote:

---

Originally Posted by dilettante

Gosh, all we need now is to add a red rubber nose, floppy shoes, and steam calliope music.

---

Turns out there is enormous demand for such customized MsgBox and now we have requests on how to use runtime's rtcMsgBox API from C/C++ in the next forum thread :-))

cheers,
</wqw>