Attribute VB_Name = "FontMod" ' ____________________________________ ' / ____________________________ \ ' / / \ \ ' _____________________________________________/ / FONT SUPPORT \ \ ' / NOV-2004 \______________________________/ / '/ _________________________________________________________________________________ / '| | | | '| | SUPPORT FOR USING FONTS, EVEN IF NOT INSTALLED TO THE SYSTEM | | '| |_________________________________________________________________________________| | '| _________________________________________________________________________________ | '| | | | '| | Written by Mark 'Max' Hamner (maxhamner(at)hotmail.com) | | '| | Use however you want...there isn't much to it. | | '| |_________________________________________________________________________________| | '| _________________________________________________________________________________ | '| | | | '| | Use this if you want to use a font in your program, but do not want to have | | '| | to install it in the user's system font folder - which is tacky to do anyway. | | '| | | | '| | NOTE: DX7 *CAN* use fonts added using this method, so this is great for games | | '| | and other DX7 projects - can save you from making lots of bitmaps for menu | | '| | text, buttons, intro stories, etc. | | '| |_________________________________________________________________________________| | '| | '\____________________________________________________________________________________/ ' ' ___________________________________________________________________________________ ' / \ '| USER ENTRY POINTS TO KNOW | '| _________________________________________________________________________________ | '| | | | '| | FontMod.TestFont(fontname) | | '| | | | '| | This will test if the given font name can be found as an available font. | | '| | This is handy to determine if the font you want to use is already installed | | '| | on the system (meaning you don't have to do anything to use it) | | '| | returns full font namne if successful, empty string if failed. | | '| | | | '| | FontMod.CalcTextWidth(someform,textstring,fontname,fontsize) | | '| | | | '| | This will calculate the size in pixels for a string using a font/size. | | '| | The form is used because the font APIs need a form to reference to determine | | '| | the context (scalemode, whatever). | | '| | Textstring is whatever string you want the width for. | | '| | Fontname, fontsize = well, font name and font size (in points) | | '| | returns width in pixels if successful, -1 if failed | | '| | | | '| | FontMod.CalcTextHeight(someform,textstring,fontname,fontsize) | | '| | | | '| | Same as above but returns the height used by the given string. | | '| | Note that depending on the font design this can vary from one string | | '| | to the next depending on descenders (hanging letters) etc. | | '| | returns height in pixels if successful, -1 if failed | | '| | | | '| | FontMod.CalcFontHeight(someform,fontname,fontsize) | | '| | | | '| | This does a height test, but uses a string with virtuall all characters | | '| | to give an accurate height for the whole font | | '| | returns height in pixels if successful, -1 if failed | | '| | | | '| | FontMod.AddFont(fontpath) | | '| | | | '| | This will add the font file passed as a font available to the system. | | '| | It does not copy it to the font folder, just tells the system to use it | | '| | where it is. Be sure you remove it when done. | | '| | fontpath = a full path, or just the filename if in the app's directory. | | '| | returns TRUE if successful, false if failed. | | '| | | | '| | FontMod.RemoveFont(fontpath) | | '| | | | '| | This will remove a font added by the function above. | | '| | returns TRUE if successful, false if failed. | | '| |_________________________________________________________________________________| | '| | '\____________________________________________________________________________________/ ' Option Explicit Private AppRealPath As String Private FontRect As RECT '-------------------------------------------------------------------------------------- Public Const DT_CALCRECT = &H400 Private Declare Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" (ByVal lpFileName As String) As Long Private Declare Function RemoveFontResource Lib "gdi32" Alias "RemoveFontResourceA" (ByVal lpFileName As String) As Long Public Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long '====================================================================================== Public Function TestFont(fontname As String) As String '====================================================================================== 'This will test if a font is installed/supported Dim tempfont As New StdFont TestFont = "" 'On Error GoTo errorout 'attempt to set a temporary font object to this font tempfont.Name = fontname 'if it succeeded the temp font will have the name still If InStr(1, fontname, tempfont.Name, vbTextCompare) <> -1 Then TestFont = tempfont.Name Exit Function errorout: 'can post a message here if want, otherwise returns false for the font test End Function '====================================================================================== Public Function CalcTextWidth(someform, textstring, fontname As String, fontsize) As Long '====================================================================================== 'This function will calculate the width (in pixels) of a string using a given font & size Dim tempwidth As Long CalcTextWidth = -1 On Error GoTo errorout someform.Font.Name = fontname someform.Font.size = fontsize 'if font not installed/supported then error If Len(TestFont(fontname)) = 0 Then GoTo errorout 'do a 'false' draw to calc the rectangle size DrawText someform.hDC, textstring, -1&, FontRect, DT_CALCRECT 'get the returned width tempwidth = FontRect.Right 'leave pixels alone, adjust twips, or set to -1 if neither If someform.ScaleMode <> vbPixels Then If someform.ScaleMode = vbTwips Then tempwidth = tempwidth / Screen.TwipsPerPixelX Else tempwidth = -1 End If End If CalcTextWidth = tempwidth Exit Function errorout: End Function '====================================================================================== Public Function CalcTextHeight(someform As Form, textstring As String, fontname As String, fontsize As Long) As Long '====================================================================================== 'Same as calc length, but returns the HEIGHT used by the font/string CalcTextHeight = -1 Dim tempheight As Long On Error GoTo errorout someform.Font.Name = fontname someform.Font.size = fontsize 'if font not installed/supported then error If Len(TestFont(fontname)) = 0 Then GoTo errorout 'do a 'false' draw to calc the rectangle size DrawText someform.hDC, textstring, -1&, FontRect, DT_CALCRECT 'get the returned size tempheight = FontRect.Bottom 'adjust to pixels for twips, or error if not in pixels or twips If someform.ScaleMode <> vbPixels Then If someform.ScaleMode = vbTwips Then tempheight = tempheight / Screen.TwipsPerPixelY Else tempheight = -1 End If End If CalcTextHeight = tempheight Exit Function errorout: End Function '====================================================================================== Public Function CalcFontHeight(someform As Form, fontname As String, fontsize As Long) '====================================================================================== 'Calculates the size of the tallest normal character of a font/size by using a string with all characters CalcFontHeight = CalcTextHeight(someform, " ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789~!@#$%^&*()_+`={}[]\|;:'/?<>,.", fontname, fontsize) End Function '====================================================================================== Public Function AddFont(fontpath) As Boolean '====================================================================================== 'This allows the system to use the font, but does NOT copy it to the font folder Dim fullfontpath As String AddFont = False If InStr(1, fontpath, "\", vbTextCompare) < 1 Then 'if fontpath is not a full path, append app folder fullfontpath = IIf(Right(App.Path, 1) = "\", App.Path & fontpath, App.Path & "\" & fontpath) Else 'otherwise use passed path fullfontpath = fontpath End If On Error GoTo errorout AddFontResource fullfontpath AddFont = True Exit Function errorout: 'for now, just returning false so the error is silent 'msgbox "Could not load font: " & fontpath End Function '====================================================================================== Public Function RemoveFont(fontpath) As Boolean '====================================================================================== 'This removes an installed font reference Dim fullfontpath As String RemoveFont = False If InStr(1, fontpath, "\", vbTextCompare) < 1 Then 'if fontpath is not a full path, append app folder fullfontpath = IIf(Right(App.Path, 1) = "\", App.Path & fontpath, App.Path & "\" & fontpath) Else 'otherwise use passed path fullfontpath = fontpath End If On Error GoTo errorout RemoveFontResource fullfontpath RemoveFont = True Exit Function errorout: 'for now, just returning false so the error is silent 'msgbox "Could not unload font: " & fontpath End Function