Attribute VB_Name = "modTTF" Option Explicit '============================================================================================================= ' ' modTTF Module ' ------------- ' ' Created By : Kevin Wilson ' http://www.TheVBZone.com ( The VB Zone ) ' http://www.TheVBZone.net ( The VB Zone .net ) ' ' Last Update : September 2, 2000 ' ' VB Versions : 5.0 / 6.0 ' ' Requires : NOTHING ' ' Description : This module makes it easy to list the current system's fonts and tell which ones are True Type ' Fonts (TTF) and which are not. See the functions below for more detail. ' '============================================================================================================= ' ' 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. ' '============================================================================================================= ' The LOGFONT structure defines the attributes of a font. Public 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. 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: 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. 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. 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 and family of the font. lfFaceName As String * 31 ' 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 ' The ENUMLOGFONT structure defines the attributes of a font, the complete name of a font, and the style of a font. Public Type ENUMLOGFONT elfLogFont As LOGFONT ' Specifies a LOGFONT structure that defines the attributes of a font. elfFullName As String * 63 ' Specifies a unique name for the font. For example, “ABCD Font Company TrueType Bold Italic Sans Serif”. elfStyle As String * 31 ' Specifies the style of the font. For example, “Bold Italic”. End Type ' Constants - EnumFontsProc(dwType) / EnumFontFamProc(FontType) Public Const DEVICE_FONTTYPE = &H2 Public Const RASTER_FONTTYPE = &H1 Public Const TRUETYPE_FONTTYPE = &H4 ' Constants - TEXTMETRIC.tmPitchAndFamily Public Const TMPF_FIXED_PITCH = &H1 Public Const TMPF_VECTOR = &H2 Public Const TMPF_TRUETYPE = &H4 Public Const TMPF_DEVICE = &H8 ' Variable Declarations Private Fonts_Count As Long Private Fonts_Name() As String Private Fonts_TTF() As Boolean ' Windows API Declarations Public Declare Function EnumFonts Lib "gdi32" Alias "EnumFontsA" (ByVal hDC As Long, ByVal lpsz As String, ByVal lpFontEnumProc As Long, ByVal lParam As Long) As Long Public Declare Function EnumFontFamilies Lib "gdi32" Alias "EnumFontFamiliesA" (ByVal hDC As Long, ByVal lpszFamily As String, ByVal lpEnumFontFamProc As Long, ByVal lParam As Long) As Long Public Declare Function GetDC Lib "USER32" (ByVal hWnd As Long) As Long Public Declare Function ReleaseDC Lib "USER32" (ByVal hWnd As Long, ByVal hDC As Long) As Long ' Callback Function Parameters: '-------------------------------------------------------- ' lplf = Pointer to logical-font data (LOGFONT Structure) ' lptm = Pointer to physical-font data (TEXTMETRIC Structure) ' dwType = Font type (DEVICE_FONTTYPE, RASTER_FONTTYPE, or TRUETYPE_FONTTYPE) ' lpData = Pointer to application-defined data (Custom) Public Function EnumFontsProc(ByRef lplf As LOGFONT, ByVal lptm As Long, ByVal dwType As Long, ByVal lpData As Long) As Long On Error Resume Next Dim TheFont As String ' Reallocate the variables to hold the information Fonts_Count = Fonts_Count + 1 ReDim Preserve Fonts_Name(Fonts_Count) As String ReDim Preserve Fonts_TTF(Fonts_Count) As Boolean ' Put the information into the variables TheFont = StrConv(lplf.lfFaceName, vbUnicode) Fonts_Name(Fonts_Count) = Left(TheFont, InStr(TheFont, Chr(0)) - 1) If (dwType And TRUETYPE_FONTTYPE) <> 0 Then Fonts_TTF(Fonts_Count) = True End If ' Tell the enumeration to continue (if set to 0, it stops) EnumFontsProc = 1 End Function ' Callback Function Parameters: '----------------------------------------------------------------- ' lpelf = Pointer to logical-font data (ENUMLOGFONT Structure) ' lpntm = Pointer to physical-font data (NEWTEXTMETRIC Structure if font is TTF, else TEXTMETRIC Structure) ' FontType = Type of font (DEVICE_FONTTYPE, RASTER_FONTTYPE, or TRUETYPE_FONTTYPE) ' lParam = Address of application-defined data (Custom) Public Function EnumFontFamProc(ByRef lpelf As ENUMLOGFONT, ByRef lpntm As Long, ByVal FontType As Long, ByVal lParam As Long) As Long On Error Resume Next Dim TheFont As String ' Reallocate the variables to hold the information Fonts_Count = Fonts_Count + 1 ReDim Preserve Fonts_Name(Fonts_Count) As String ReDim Preserve Fonts_TTF(Fonts_Count) As Boolean ' Put the information into the variables TheFont = StrConv(lpelf.elfLogFont.lfFaceName, vbUnicode) Fonts_Name(Fonts_Count) = Left(TheFont, InStr(TheFont, Chr(0)) - 1) If (FontType And TRUETYPE_FONTTYPE) <> 0 Then Fonts_TTF(Fonts_Count) = True End If ' Tell the enumeration to continue (if set to 0, it stops) EnumFontFamProc = 1 End Function ' Function that when called fills the specified ListBox control with the ' system's fonts and indicates if they are True Type Fonts (TTF) or not Public Function GetFonts_LstBox(ByRef ListBox_ToFill As ListBox, Optional ByVal EnumFontFam As Boolean = True) As Boolean On Error Resume Next Dim TheDC As Long Dim MyCounter As Long Dim ReturnValue As Long ' Clear the ListBox control passed to this function ListBox_ToFill.Clear ' Clear the variables to hold the information Fonts_Count = 0 Erase Fonts_Name Erase Fonts_TTF ' Get the Device Context of the Windows Desktop TheDC = GetDC(0) If TheDC = 0 Then Exit Function End If ' Start looking through the fonts If EnumFontFam = True Then ReturnValue = EnumFontFamilies(TheDC, vbNullString, AddressOf EnumFontFamProc, 0) Else ReturnValue = EnumFonts(TheDC, vbNullString, AddressOf EnumFontsProc, 0) End If ' Fill the ListBox control passed to this function with the font information found If ReturnValue = 0 Then MsgBox "Failed to get font info" Else If Fonts_Count > 0 Then For MyCounter = 0 To Fonts_Count If Fonts_Name(MyCounter) <> "" Then If Fonts_TTF(MyCounter) = True Then ListBox_ToFill.AddItem " TTF - " & Fonts_Name(MyCounter) Else ListBox_ToFill.AddItem " ___ - " & Fonts_Name(MyCounter) End If End If Next ListBox_ToFill.Selected(0) = True End If GetFonts_LstBox = True End If ReleaseDC 0, TheDC End Function ' Function that when called fills the specified ComboBox control with the ' system's fonts and indicates if they are True Type Fonts (TTF) or not Public Function GetFonts_CboBox(ByRef ComboBox_ToFill As ComboBox, Optional ByVal EnumFontFam As Boolean = True) As Boolean On Error Resume Next Dim TheDC As Long Dim MyCounter As Long Dim ReturnValue As Long ' Clear the ListBox control passed to this function ComboBox_ToFill.Clear ' Clear the variables to hold the information Fonts_Count = 0 Erase Fonts_Name Erase Fonts_TTF ' Get the Device Context of the Windows Desktop TheDC = GetDC(0) If TheDC = 0 Then Exit Function End If ' Start looking through the fonts If EnumFontFam = True Then ReturnValue = EnumFontFamilies(TheDC, vbNullString, AddressOf EnumFontFamProc, 0) Else ReturnValue = EnumFonts(TheDC, vbNullString, AddressOf EnumFontsProc, 0) End If ' Fill the ListBox control passed to this function with the font information found If ReturnValue = 0 Then MsgBox "Failed to get font info" Else If Fonts_Count > 0 Then For MyCounter = 0 To Fonts_Count If Fonts_Name(MyCounter) <> "" Then If Fonts_TTF(MyCounter) = True Then ComboBox_ToFill.AddItem " TTF - " & Fonts_Name(MyCounter) Else ComboBox_ToFill.AddItem " ___ - " & Fonts_Name(MyCounter) End If End If Next ComboBox_ToFill.Text = ComboBox_ToFill.List(0) End If GetFonts_CboBox = True End If ReleaseDC 0, TheDC End Function ' Function that when called fills the specified multi-lined TextBox control ' with the system's fonts and indicates if they are True Type Fonts (TTF) or not Public Function GetFonts_TxtBox(ByRef TextBox_ToFill As TextBox, Optional ByVal EnumFontFam As Boolean = True) As Boolean On Error Resume Next Dim TheDC As Long Dim MyCounter As Long Dim ReturnValue As Long ' Check if the TextBox control passed is has the MultiLine property set to TRUE If TextBox_ToFill.MultiLine = False Then MsgBox "The TextBox '" & TextBox_ToFill.Name & "' does not have the MultiLine property set to TRUE." & Chr(13) & "Can not fill this TextBox with the system's fonts.", vbOKOnly + vbExclamation, " Error - TextBox Not MultiLine" Exit Function End If ' Clear the ListBox control passed to this function TextBox_ToFill.Text = "" ' Clear the variables to hold the information Fonts_Count = 0 Erase Fonts_Name Erase Fonts_TTF ' Get the Device Context of the Windows Desktop TheDC = GetDC(0) If TheDC = 0 Then Exit Function End If ' Start looking through the fonts If EnumFontFam = True Then ReturnValue = EnumFontFamilies(TheDC, vbNullString, AddressOf EnumFontFamProc, 0) Else ReturnValue = EnumFonts(TheDC, vbNullString, AddressOf EnumFontsProc, 0) End If ' Fill the ListBox control passed to this function with the font information found If ReturnValue = 0 Then MsgBox "Failed to get font info" Else If Fonts_Count > 0 Then For MyCounter = 0 To Fonts_Count If Fonts_Name(MyCounter) <> "" Then If Fonts_TTF(MyCounter) = True Then TextBox_ToFill.Text = TextBox_ToFill.Text & " TTF - " & Fonts_Name(MyCounter) & vbCrLf Else TextBox_ToFill.Text = TextBox_ToFill.Text & " ___ - " & Fonts_Name(MyCounter) & vbCrLf End If End If Next End If GetFonts_TxtBox = True End If ReleaseDC 0, TheDC End Function