Option Explicit
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As String * 1
lfUnderline As String * 1
lfStrikeOut As String * 1
lfCharSet As String * 1
lfOutPrecision As String * 1
lfClipPrecision As String * 1
lfQuality As String * 1
lfPitchAndFamily As String * 1
lfFaceName As String * 32
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
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL] VBA7 Then
Private Declare PtrSafe Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private hFont As LongPtr
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL]
Private Declare PtrSafe Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private hFont As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL] If
Private Const SPI_GETNONCLIENTMETRICS = 41
Private Const SPI_SETNONCLIENTMETRICS = 42
Private Const SPIF_UPDATEINIFILE = &H1
Sub Test_MsgBoxEx()
MsgBoxEx Prompt:="Hello World !", Buttons:=vbInformation + vbOKCancel, _
FontName:="Bradley Hand ITC", FontSize:=25, FontBold:=True, FontItalic:=True
End Sub
Sub Test_Standard_MsgBox()
MsgBox Prompt:="Hello World !", Buttons:=vbInformation + vbOKCancel
End Sub
Private Function MsgBoxEx( _
ByVal Prompt As String, _
Optional ByVal Buttons As VbMsgBoxStyle = vbOKOnly, _
Optional ByVal Title As String, _
Optional ByVal HelpFile As String, _
Optional ByVal Context As Long, _
Optional ByVal FontName As String, _
Optional ByVal FontSize As Single, _
Optional ByVal FontBold As Boolean, _
Optional ByVal FontItalic As Boolean, _
Optional ByVal FontUnderline As Boolean, _
Optional ByVal FontStrikeOut As Boolean _
) As VbMsgBoxResult
Dim tDefNCMetrics As NONCLIENTMETRICS, tNCMetrics As NONCLIENTMETRICS, tLogFont As LOGFONT
On Error GoTo ErrHandler
tNCMetrics.cbSize = Len(tNCMetrics)
Call SystemParametersInfo(SPI_GETNONCLIENTMETRICS, Len(tNCMetrics), tNCMetrics, 0)
tDefNCMetrics = tNCMetrics
[B][COLOR=#008000]'Safety step : Save to text file In case an error occurs and the default NONCLIENTMETRICS are lost.
'To recover the default NONCLIENTMETRICS, run the 'RestoreDefaultNCMetrics' routine located below.[/COLOR][/B]
Open ThisWorkbook.Path & Application.PathSeparator & "DefNCMetrics.txt" For Binary As [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1"]#1[/URL]
Put [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1"]#1[/URL] , , tDefNCMetrics
Close [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1"]#1[/URL]
With tLogFont
.lfFaceName = IIf(Len(FontName), FontName & Chr$(0), tDefNCMetrics.lfMessageFont.lfFaceName & Chr$(0))
.lfHeight = IIf(FontSize, -FontSize, tDefNCMetrics.lfMessageFont.lfHeight)
.lfWeight = IIf(FontBold, 900, tDefNCMetrics.lfMessageFont.lfWeight)
.lfItalic = IIf(FontItalic, True, tDefNCMetrics.lfMessageFont.lfItalic)
.lfUnderline = IIf(FontUnderline, True, tDefNCMetrics.lfMessageFont.lfUnderline)
.lfStrikeOut = IIf(FontStrikeOut, True, tDefNCMetrics.lfMessageFont.lfStrikeOut)
End With
hFont = CreateFontIndirect(tLogFont)
tNCMetrics.lfMessageFont = tLogFont
Call SystemParametersInfo(SPI_SETNONCLIENTMETRICS, Len(tNCMetrics), tNCMetrics, SPIF_UPDATEINIFILE)
MsgBox Prompt, Buttons, IIf(Len(Title), Title, Application.Name), HelpFile, Context
ErrHandler:
DeleteObject hFont
Call SystemParametersInfo(SPI_SETNONCLIENTMETRICS, Len(tDefNCMetrics), tDefNCMetrics, SPIF_UPDATEINIFILE)
If Err.Number = 75 Then
MsgBox "Oops!" & vbCr & vbCr & "This workbook must be saved to disk" & vbCr & "before running the code.", vbInformation
End If
End Function
[B][COLOR=#008000]'Run this macro only if the default NONCLIENTMETRICS are accidently lost !!![/COLOR][/B]
Private Sub RestoreDefaultNCMetrics()
Dim tDefNCMetrics As NONCLIENTMETRICS
Open ThisWorkbook.Path & Application.PathSeparator & "DefNCMetrics.txt" For Binary As [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1"]#1[/URL]
Get [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1"]#1[/URL] , , tDefNCMetrics
Close [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1"]#1[/URL]
Call SystemParametersInfo(SPI_SETNONCLIENTMETRICS, Len(tDefNCMetrics), tDefNCMetrics, SPIF_UPDATEINIFILE)
End Sub
ray: 
