Attribute VB_Name = "modSysFonts" Option Explicit '============================================================================================================= ' ' modSysFonts Module ' ------------------ ' ' Created By : Kevin Wilson ' http://www.TheVBZone.com ( The VB Zone ) ' http://www.TheVBZone.net ( The VB Zone .net ) ' ' Last Update : August 31, 2000 ' ' VB Versions : 5.0 / 6.0 ' ' Requires : NOTHING ' ' Description : This module is meant to make it easy to get or set the system-wide font styles of different ' aspects of windows... like the window captions, window menu systems, etc. ' ' Exaple Use : ' ' ' Dim PreviousFont As StdFont ' Dim NewFont As StdFont ' ' ' Get the previous font to be able to set it back to what it was before ' If GetSysFont(PreviousFont, Me.hDC, cf_Caption) = True Then ' ' Create a new font to set it to ' Set NewFont = New StdFont ' With NewFont ' .Bold = True ' .Italic = True ' .Name = "Arial" ' .Size = 16 ' .Strikethrough = True ' .Underline = True ' End With ' ' Set the font to the newly created one ' If SetSysFont(NewFont, Me.hDC, cf_Caption) = False Then ' MsgBox "ERROR" ' Else ' MsgBox "SUCESS!" ' End If ' ' Restore the font to what it was before ' SetSysFont PreviousFont, Me.hDC, cf_Caption, True ' End If ' '============================================================================================================= ' ' LEGAL: ' ' You are free to use this code as long as you keep the above heading information intact and unchanged. Credit ' given where credit is due. Also, it is not required, but it would be appreciated if you would mention ' somewhere in your compiled program that that your program makes use of code written and distributed by ' Kevin Wilson (www.TheVBZone.com). Feel free to link to this code via your web site or articles. ' ' You may NOT take this code and pass it off as your own. You may NOT distribute this code on your own server ' or web site. You may NOT take code created by Kevin Wilson (www.TheVBZone.com) and use it to create products, ' utilities, or applications that directly compete with products, utilities, and applications created by Kevin ' Wilson, TheVBZone.com, or Wilson Media. You may NOT take this code and sell it for profit without first ' obtaining the written consent of the author Kevin Wilson. ' ' These conditions are subject to change at the discretion of the owner Kevin Wilson at any time without ' warning or notice. Copyright© by Kevin Wilson. All rights reserved. ' '============================================================================================================= ' Type - SystemParametersInfo Private Type LOGFONT lfHeight As Long ' Specifies the height, in logical units, of the font's character cell or character. The character height value (also known as the em height) is the character cell height value minus the internal-leading value. (Fore more info on lfHeight, see the documentation for LOGFONT in the Win32 SDK) lfWidth As Long ' Specifies the average width, in logical units, of characters in the font. If lfWidth is zero, the aspect ratio of the device is matched against the digitization aspect ratio of the available fonts to find the closest match, determined by the absolute value of the difference. lfEscapement As Long ' Specifies the angle, in tenths of degrees, between the escapement vector and the x-axis of the device. The escapement vector is parallel to the base line of a row of text. ' Windows NT/2000 : When the graphics mode is set to GM_ADVANCED, you can specify the escapement angle of the string independently of the orientation angle of the string's characters. When the graphics mode is set to GM_COMPATIBLE, lfEscapement specifies both the escapement and orientation. You should set lfEscapement and lfOrientation to the same value. ' Windows 95 : The lfEscapement member specifies both the escapement and orientation. You should set lfEscapement and lfOrientation to the same value. lfOrientation As Long ' Specifies the angle, in tenths of degrees, between each character's base line and the x-axis of the device. lfWeight As Long ' Specifies the weight of the font in the range 0 through 1000. For example, 400 is normal and 700 is bold. If this value is zero, a default weight is used. lfItalic As Byte ' Specifies an italic font if set to TRUE. lfUnderline As Byte ' Specifies an underlined font if set to TRUE. lfStrikeOut As Byte ' Specifies a strikeout font if set to TRUE. lfCharSet As Byte ' Specifies the character set. (Fore more info on lfCharSet, see the documentation for LOGFONT in the Win32 SDK) lfOutPrecision As Byte ' Specifies the output precision. The output precision defines how closely the output must match the requested font's height, width, character orientation, escapement, pitch, and font type.(Fore more info on lfOutPrecision, see the documentation for LOGFONT in the Win32 SDK) lfClipPrecision As Byte ' Specifies the clipping precision. The clipping precision defines how to clip characters that are partially outside the clipping region. lfQuality As Byte ' Specifies the output quality. The output quality defines how carefully the graphics device interface (GDI) must attempt to match the logical-font attributes to those of an actual physical font. lfPitchAndFamily As Byte ' Specifies the pitch in the two low-order bits, and the family of the font in bits 4 through 7. lfFaceName As String * 32 ' A null-terminated string that specifies the typeface name of the font. The length of this string must not exceed 32 characters, including the null terminator. The EnumFontFamilies function can be used to enumerate the typeface names of all currently available fonts. If lfFaceName is an empty string, GDI uses the first font that matches the other specified attributes. End Type ' Type - SystemParametersInfo Private Type NONCLIENTMETRICS cbSize As Long ' Specifies the size of the structure, in bytes. iBorderWidth As Long ' Specifies the thickness, in pixels, of the sizing border. iScrollWidth As Long ' Specifies the width, in pixels, of a standard vertical scroll bar. iScrollHeight As Long ' Specifies the height, in pixels, of a standard horizontal scroll bar. iCaptionWidth As Long ' Specifies the width, in pixels, of caption buttons. iCaptionHeight As Long ' Specifies the height, in pixels, of caption buttons. lfCaptionFont As LOGFONT ' Contains information about the caption font. iSMCaptionWidth As Long ' Specifies the width, in pixels, of small caption buttons. iSMCaptionHeight As Long ' Specifies the height, in pixels, of small captions. lfSMCaptionFont As LOGFONT ' Contains information about the small caption font. iMenuWidth As Long ' Specifies the width, in pixels, of menu-bar buttons. iMenuHeight As Long ' Specifies the height, in pixels, of a menu bar. lfMenuFont As LOGFONT ' Contains information about the font used in menu bars. lfStatusFont As LOGFONT ' Contains information about the font used in status bars and tooltips. lfMessageFont As LOGFONT ' Contains information about the font used in message boxes. End Type ' Enumeration - GetSysFont/SetSysFont Public Enum ClientFonts cf_Caption = 0 cf_SmallCaption = 1 cf_Menu = 2 cf_Status = 3 cf_Message = 4 End Enum ' Constants - SystemParametersInfo Private Const LOGPIXELSY = 90 Private Const SPI_GETNONCLIENTMETRICS = 41 Private Const SPI_SETNONCLIENTMETRICS = 42 ' Constants - LOGFONT.lfWeight Private Const FW_DONTCARE = 0 Private Const FW_THIN = 100 Private Const FW_EXTRALIGHT = 200 Private Const FW_ULTRALIGHT = 200 Private Const FW_LIGHT = 300 Private Const FW_NORMAL = 400 Private Const FW_REGULAR = 400 Private Const FW_MEDIUM = 500 Private Const FW_SEMIBOLD = 600 Private Const FW_DEMIBOLD = 600 Private Const FW_BOLD = 700 Private Const FW_EXTRABOLD = 800 Private Const FW_ULTRABOLD = 800 Private Const FW_HEAVY = 900 Private Const FW_BLACK = 900 ' Constants - LOGFONT.lfCharSet Private Const ANSI_CHARSET = 0 Private Const DEFAULT_CHARSET = 1 Private Const SYMBOL_CHARSET = 2 Private Const MAC_CHARSET = 77 Private Const SHIFTJIS_CHARSET = 128 Private Const HANGUL_CHARSET = 129 Private Const GB2312_CHARSET = 134 Private Const CHINESEBIG5_CHARSET = 136 Private Const GREEK_CHARSET = 161 Private Const TURKISH_CHARSET = 162 Private Const BALTIC_CHARSET = 186 Private Const RUSSIAN_CHARSET = 204 Private Const EASTEUROPE_CHARSET = 238 Private Const OEM_CHARSET = 255 ' Constants - LOGFONT.lfOutPrecision Private Const OUT_DEFAULT_PRECIS = 0 ' Specifies the default font mapper behavior. Private Const OUT_STRING_PRECIS = 1 ' This value is not used by the font mapper, but it is returned when raster fonts are enumerated. Private Const OUT_CHARACTER_PRECIS = 2 ' Not used. Private Const OUT_STROKE_PRECIS = 3 ' Windows NT/2000 : This value is not used by the font mapper, but it is returned when TrueType, other outline-based fonts, and vector fonts are enumerated. ' Windows 95 : This value is used to map vector fonts, and is returned when TrueType or vector fonts are enumerated. Private Const OUT_TT_PRECIS = 4 ' Instructs the font mapper to choose a TrueType font when the system contains multiple fonts with the same name. Private Const OUT_DEVICE_PRECIS = 5 ' Instructs the font mapper to choose a Device font when the system contains multiple fonts with the same name. Private Const OUT_RASTER_PRECIS = 6 ' Instructs the font mapper to choose a raster font when the system contains multiple fonts with the same name. Private Const OUT_TT_ONLY_PRECIS = 7 ' Instructs the font mapper to choose from only TrueType fonts. If there are no TrueType fonts installed in the system, the font mapper returns to default behavior. Private Const OUT_OUTLINE_PRECIS = 8 ' Windows NT/2000 : This value instructs the font mapper to choose from TrueType and other outline-based fonts. Private Const OUT_SCREEN_OUTLINE_PRECIS = 9 ' Undocumented ' Constants - LOGFONT.lfClipPrecision Private Const CLIP_DEFAULT_PRECIS = 0 ' Specifies default clipping behavior. Private Const CLIP_CHARACTER_PRECIS = 1 ' Not used. Private Const CLIP_STROKE_PRECIS = 2 ' Not used by the font mapper, but is returned when raster, vector, or TrueType fonts are enumerated. ' Windows NT/2000 : For compatibility, this value is always returned when enumerating fonts. Private Const CLIP_MASK = &HF ' Not used. Private Const CLIP_EMBEDDED = 16 ' You must specify this flag to use an embedded read-only font. Private Const CLIP_LH_ANGLES = 32 ' When this value is used, the rotation for all fonts depends on whether the orientation of the coordinate system is left-handed or right-handed. If not used, device fonts always rotate counterclockwise, but the rotation of other fonts is dependent on the orientation of the coordinate system. For more information about the orientation of coordinate systems, see the description of the nOrientation parameter Private Const CLIP_TT_ALWAYS = 128 ' Not used. ' Constants - LOGFONT.lfQuality Private Const DEFAULT_QUALITY = 0 ' Appearance of the font does not matter. Private Const DRAFT_QUALITY = 1 ' Appearance of the font is less important than when PROOF_QUALITY is used. For GDI raster fonts, scaling is enabled, which means that more font sizes are available, but the quality may be lower. Bold, italic, underline, and strikeout fonts are synthesized if necessary. Private Const PROOF_QUALITY = 2 ' Character quality of the font is more important than exact matching of the logical-font attributes. For GDI raster fonts, scaling is disabled and the font closest in size is chosen. Although the chosen font size may not be mapped exactly when PROOF_QUALITY is used, the quality of the font is high and there is no distortion of appearance. Bold, italic, underline, and strikeout fonts are synthesized if necessary. Private Const NONANTIALIASED_QUALITY = 3 ' Windows 95, Windows NT 4.0, and Windows 2000: Font is never antialiased. Private Const ANTIALIASED_QUALITY = 4 ' Windows NT 4.0 and later: Font is always antialiased if the font supports it and the size of the font is not too small or too large. ' Windows 95 and later: In addition to the comments for Windows NT, the display must greater than 8-bit color, it must be a single plane device, it cannot be a palette display, and it cannot be in a multiple display monitor setup. In addition, you must select a TrueType font into a screen DC prior to using it in a DIBSection, otherwise antialiasing does not occur. ' Constants - LOGFONT.lfPitchAndFamily Private Const DEFAULT_PITCH = 0 Private Const FIXED_PITCH = 2 Private Const VARIABLE_PITCH = 2 Private Const MONO_FONT = 8 Private Const FF_DECORATIVE = 80 'Novelty fonts. Old English is an example. Private Const FF_DONTCARE = 0 'Don't care or don't know. Private Const FF_MODERN = 48 'Fonts with constant stroke width (monospace), with or without serifs. Monospace fonts are usually modern. Pica, Elite, and CourierNew® are examples. Private Const FF_ROMAN = 16 'Fonts with variable stroke width (proportional) and with serifs. MS® Serif is an example. Private Const FF_SCRIPT = 64 'Fonts designed to look like handwriting. Script and Cursive are examples. Private Const FF_SWISS = 32 'Fonts with variable stroke width (proportional) and without serifs. MS® Sans Serif is an example. Private PrevCaptionHeight As Long Private PrevMenuHeight As Long Private Declare Function GetDeviceCaps Lib "GDI32.DLL" (ByVal hDC As Long, ByVal nIndex 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 '============================================================================================================= ' GetSysFont ' ' Purpose: ' -------- ' Get the current font style from the specified window aspect. ' ' Param: Use: ' -------------------------------------------- ' Return_Font Variable that recieves the specifed font information ' hDC Handle to the Device Context (DC) to use to get ' information about the specified font style ' (This should be set to the calling form's hDC [Me.hDC]) ' FontToGet Specifies which window aspect to get the font from ' ' Return: ' ------- ' Returns TRUE if succeeds, FALSE if fails ' '============================================================================================================= Public Function GetSysFont(ByRef Return_Font As StdFont, ByVal hDC As Long, ByVal FontToGet As ClientFonts) As Boolean On Error GoTo ErrorTrap Dim NCInfo As NONCLIENTMETRICS Dim FontInfo As LOGFONT ' Clear the return variable Set Return_Font = Nothing ' Set the buffer size of the parameter to be passed NCInfo.cbSize = Len(NCInfo) ' Get the font information If SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, NCInfo, 0) = 0 Then Exit Function Else ' Check the result If NCInfo.iCaptionHeight = 0 Then FontInfo.lfHeight = 0 Else ' Store the previous caption/menu height. If you change the font's size UP, the ' caption/menu height will change. If you change the font DOWN, the caption/menu ' height does not automatically change smaller. PrevCaptionHeight = NCInfo.iCaptionHeight PrevMenuHeight = NCInfo.iMenuHeight ' Get the right font to return Select Case FontToGet Case cf_Caption FontInfo = NCInfo.lfCaptionFont Case cf_Menu FontInfo = NCInfo.lfMenuFont Case cf_Message FontInfo = NCInfo.lfMessageFont Case cf_SmallCaption FontInfo = NCInfo.lfSMCaptionFont Case cf_Status FontInfo = NCInfo.lfStatusFont End Select End If End If ' Set the return font according to the API results Set Return_Font = New StdFont With Return_Font .Charset = FontInfo.lfCharSet .Weight = FontInfo.lfWeight .Name = FontInfo.lfFaceName .Strikethrough = FontInfo.lfStrikeOut .Underline = FontInfo.lfUnderline .Italic = FontInfo.lfItalic .Bold = (FontInfo.lfWeight = 700) .Size = -(FontInfo.lfHeight * (72 / GetDeviceCaps(hDC, LOGPIXELSY))) End With GetSysFont = True Exit Function ErrorTrap: If Err.Number = 0 Then ' No Error Resume Next ElseIf Err.Number = 20 Then ' Resume Without Error Resume Next Else ' Unknown Error MsgBox Err.Source & " encountered the following error:" & Chr(13) & Chr(13) & "Error Number = " & CStr(Err.Number) & Chr(13) & "Error Description = " & Err.Description, vbOKOnly + vbExclamation, " Error - " & Err.Description Err.Clear GetSysFont = False Exit Function End If End Function '============================================================================================================= ' SetSysFont ' ' Purpose: ' -------- ' Sets a new font style for the specified window aspect. ' ' Param: Use: ' -------------------------------------------- ' NewFont Variable that contains the new font style to set ' hDC Handle to the Device Context (DC) to use to get ' information about the specified font style ' (This should be set to the calling form's hDC [Me.hDC]) ' FontToSet Specifies which window aspect to set the new font to ' RestorePrevHeight Optional. If this is TRUE, the Caption height and Menu ' height retrieved in the last call to the GetSysFont ' function will be restored. The reason this is important ' is when you set the Caption or Menu font to a font with ' a larger font size, the Caption or Menu resize up to ' accomidate the font size. If you size them back down, ' they don't automatically size back down. ' ' Return: ' ------- ' Returns TRUE if succeeds, FALSE if fails ' '============================================================================================================= Public Function SetSysFont(ByRef NewFont As StdFont, ByVal hDC As Long, ByVal FontToSet As ClientFonts, Optional ByVal RestorePrevHeight As Boolean = False) As Boolean On Error GoTo ErrorTrap Dim NCInfo As NONCLIENTMETRICS Dim FontInfo As LOGFONT Dim FItalic As Byte Dim FUnderline As Byte Dim FStrikeThru As Byte ' Make sure a valid font was passed If NewFont Is Nothing Then Exit Function End If ' Get all the current fonts so that just the one specified is changed. Otherwise, all ' the other fonts are changed to odd fonts that don't make sense. NCInfo.cbSize = Len(NCInfo) If SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, NCInfo, 0) = 0 Then Exit Function End If ' Set the font to it's current state so only the things specified are changed Select Case FontToSet Case cf_Caption FontInfo = NCInfo.lfCaptionFont Case cf_Menu FontInfo = NCInfo.lfMenuFont Case cf_Message FontInfo = NCInfo.lfMessageFont Case cf_SmallCaption FontInfo = NCInfo.lfSMCaptionFont Case cf_Status FontInfo = NCInfo.lfStatusFont End Select ' Set the LOGFONT information to specified font With NewFont If .Italic = True Then FItalic = 1 Else FItalic = 0 If .Strikethrough = True Then FStrikeThru = 1 Else FStrikeThru = 0 If .Underline = True Then FUnderline = 1 Else FUnderline = 0 End With With FontInfo .lfClipPrecision = CLIP_DEFAULT_PRECIS .lfOrientation = 0 .lfOutPrecision = OUT_DEFAULT_PRECIS .lfQuality = DEFAULT_QUALITY .lfCharSet = NewFont.Charset .lfFaceName = NewFont.Name & Chr(0) .lfStrikeOut = FStrikeThru .lfUnderline = FUnderline .lfItalic = FItalic .lfWeight = NewFont.Weight If NewFont.Bold = True Then .lfWeight = 700 End If .lfHeight = NewFont.Size / -(72 / GetDeviceCaps(hDC, LOGPIXELSY)) End With ' Set the specified font information With NCInfo .cbSize = Len(NCInfo) Select Case FontToSet Case cf_Caption NCInfo.lfCaptionFont = FontInfo Case cf_Menu NCInfo.lfMenuFont = FontInfo Case cf_Message NCInfo.lfMessageFont = FontInfo Case cf_SmallCaption NCInfo.lfSMCaptionFont = FontInfo Case cf_Status NCInfo.lfStatusFont = FontInfo End Select ' If the user specifies to do so... change the caption height back to it's original size. ' If you increase the font size If PrevCaptionHeight <> 0 And PrevMenuHeight <> 0 And RestorePrevHeight = True Then .iCaptionHeight = PrevCaptionHeight ' <-- This variable is set in the GetSysFont function .iMenuHeight = PrevMenuHeight ' <-- This variable is set in the GetSysFont function End If End With ' Set the font information If SystemParametersInfo(SPI_SETNONCLIENTMETRICS, 0, NCInfo, 0) = 0 Then Exit Function End If SetSysFont = True Exit Function ErrorTrap: If Err.Number = 0 Then ' No Error Resume Next ElseIf Err.Number = 20 Then ' Resume Without Error Resume Next Else ' Unknown Error MsgBox Err.Source & " encountered the following error:" & Chr(13) & Chr(13) & "Error Number = " & CStr(Err.Number) & Chr(13) & "Error Description = " & Err.Description, vbOKOnly + vbExclamation, " Error - " & Err.Description Err.Clear SetSysFont = False Exit Function End If End Function