Private Const SPI_GETNONCLIENTMETRICS = 41
Private Const SPI_SETNONCLIENTMETRICS = 42
Private Const WM_SETTEXT = &HC
Private Const WM_SETTINGCHANGE As Long = &H1A
Private Const HWND_BROADCAST As Long = &HFFFF&
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 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
#If VBA7 Then
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function DefWindowProcW Lib "user32" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
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
#Else
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function DefWindowProcW Lib "user32" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SystemParametersInfo Lib "user32.dll" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
#End If
Dim fontmenu As String, fontcaption As String, ncm As NONCLIENTMETRICS
Public Sub SetSysFont(fontname As String)
ncm.cbSize = Len(ncm)
SystemParametersInfo SPI_GETNONCLIENTMETRICS, Len(ncm), ncm, 0
fontmenu = ncm.lfMenuFont.lfFaceName
fontcaption = ncm.lfCaptionFont.lfFaceName
ncm.lfMenuFont.lfFaceName = fontname & vbNullChar
ncm.lfCaptionFont.lfFaceName = fontname & vbNullChar
SystemParametersInfo SPI_SETNONCLIENTMETRICS, Len(ncm), ncm, 0
SendMessage HWND_BROADCAST, WM_SETTINGCHANGE, 0, 0
End Sub
Public Sub RestoreSysFont()
ncm.lfMenuFont.lfFaceName = fontmenu
ncm.lfCaptionFont.lfFaceName = fontcaption
SystemParametersInfo SPI_SETNONCLIENTMETRICS, Len(ncm), ncm, 0
SendMessage HWND_BROADCAST, WM_SETTINGCHANGE, 0, 0
End Sub
Public Sub setTitle(ByVal ufCaption As String, ByVal windowText As String)
#If VBA7 Then
Dim hwnd As LongPtr
#Else
Dim hwnd As Long
#End If
hwnd = FindWindow("ThunderDFrame", ufCaption)
If hwnd > 0 Then DefWindowProcW hwnd, WM_SETTEXT, 0, StrPtr(windowText)
End Sub
