GFFont/GFFontmod.bas

Attribute VB_Name = "GFFontmod"
Option Explicit
'(c)2001 by Louis. For additional information view files in Developing Notes\.
'GFFont_InstallFont
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
Private Declare Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" (ByVal lpFileName As String) As Long
Private Declare Function WriteProfileString Lib "kernel32" Alias "WriteProfileStringA" (ByVal lpszSection As String, ByVal lpszKeyName As String, ByVal lpszString As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
'GFFont_InstallFont
Private Const HWND_BROADCAST = &HFFFF&
Private Const WM_FONTCHANGE = &H1D

'************************************INTERFACE SUBS*************************************
'NOTE: the GFFont code should be used to exchange TrueType font files between
'two or more computers.

Public Function GFFont_IsFontInstalled(ByVal FontName As String) As Boolean
    'on error resume next 'returns True if FontName appears in Screen.Fonts(), False if not
    Dim FontLoop As Integer
    Dim Temp As Long
    '
    'NOTE: this function works like ISFONTAVAILABLE(), which is included in some projects,
    'but GFFont_IsFontInstalled cuts extended font information that could have been read out of registry.
    'Example:
    'Name of 'Arial' in registry: Arial (TrueType)
    'Name of 'Arial' in Screen.Fonts(): Arial
    'This function will notice that the passed font 'Arial (TrueType)' is installed.
    '
    'preset
    For Temp = 1 To Len(FontName)
        If Mid$(FontName, Temp, 1) = "(" Then
            FontName = RTrim$(Left$(FontName, Temp ‑ 1))
            Exit For
        End If
    Next Temp
    'begin
    For FontLoop = 1 To Screen.FontCount
        If UCase$(Screen.Fonts(FontLoop)) = UCase$(FontName) Then
            GFFont_IsFontInstalled = True
            Exit Function
        End If
    Next FontLoop
    GFFont_IsFontInstalled = False
    Exit Function
End Function

Public Function GFFont_InstallFont(ByVal FontName As String, ByVal FontFile As String) As Boolean
    'on error resume next 'returns True for success, False for error
    Dim SystemFontDir As String
    Dim Temp As Long
    '
    'NOTE: this function will copy the font file into the OS's font file directory if necessary.
    '
    'preset
    SystemFontDir = GFGetSpecialFolderLocation(CSIDL_FONTS)
    If SystemFontDir = "" Then SystemFontDir = GFShellRegistration_GetWinDir + "FONTS\" 'verify
    If CopyFile(FontFile, SystemFontDir + GetFileName(FontFile), 1) = 0 Then GoTo Error: 'target font file will be locked if already existing
    FontFile = SystemFontDir + GetFileName(FontFile)
    'begin
    Temp = AddFontResource(FontFile)
    If Not (Temp = 0) Then 'verify
        Temp = WriteProfileString("Fonts", FontName, FontFile) 'change a setting in win.ini
        If Not (Temp = 0) Then 'verify
            Call SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0&)
            GFFont_InstallFont = True 'ok
            Exit Function
        Else
            GoTo Error:
        End If
    Else
        GoTo Error:
    End If
Error:
    GFFont_InstallFont = False 'error
    Exit Function
End Function

Public Function GFFont_FontNameToFontFileName(ByVal FontName As String) As String
    'on error resume next 'returns file name of passed font (full path) or nothing ("") for error
    Dim FontNumber As Integer
    Dim FontNameArray() As String
    Dim FontFileNameArray() As String
    Dim FontLoop As Integer
    'verify
    If FontName = "" Then GoTo Error:
    'begin
    If Rmod.RegGetKeyValueList(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Fonts", _
        FontNumber, FontNameArray(), FontFileNameArray()) = True Then GoTo Jump:
    'try NT version
    If Rmod.RegGetKeyValueList(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts", _
        FontNumber, FontNameArray(), FontFileNameArray()) = True Then GoTo Jump:
    GoTo Error:
Jump:
    For FontLoop = 1 To FontNumber
        If InStr(1, FontNameArray(FontLoop), FontName, vbTextCompare) = 1 Then
            GFFont_FontNameToFontFileName = FontFileNameArray(FontLoop) 'ok
            Exit Function
        End If
    Next FontLoop
    GFFont_FontNameToFontFileName = "" 'reset (error)
    Exit Function
Error:
    GFFont_FontNameToFontFileName = "" 'reset (error)
    Exit Function
End Function

Public Function GFFont_FontFileNameToFontName(ByVal FontFileName As String) As String
    'on error resume next 'returns name related to passed font file (full path or file name only) or nothing ("") for error
    Dim FontNumber As Integer
    Dim FontNameArray() As String
    Dim FontFileNameArray() As String
    Dim FontLoop As Integer
    'verify
    If FontFileName = "" Then GoTo Error:
    If Not (GetDirectoryName(FontFileName) = "") Then FontFileName = GetFileName(FontFileName)
    'begin
    If Rmod.RegGetKeyValueList(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Fonts", _
        FontNumber, FontNameArray(), FontFileNameArray()) = True Then GoTo Jump:
    'try NT version
    If Rmod.RegGetKeyValueList(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts", _
        FontNumber, FontNameArray(), FontFileNameArray()) = True Then GoTo Jump:
    GoTo Error:
Jump:
    For FontLoop = 1 To FontNumber
        If UCase$(FontFileNameArray(FontLoop) = FontFileName) Then
            GFFont_FontFileNameToFontName = FontNameArray(FontLoop) 'ok
            Exit Function
        End If
    Next FontLoop
    GFFont_FontFileNameToFontName = "" 'reset (error)
    Exit Function
Error:
    GFFont_FontFileNameToFontName = "" 'reset (error)
    Exit Function
End Function

'
'NOTE: the following function creates a non‑TrueType font out of a TrueType font.
'The code's root is a Microsoft example, no idea what it is good for (though we want to install the TrueType font?).
'
'Private Declare Function CreateScalableFontResource Lib "gdi32" Alias "CreateScalableFontResourceA" (ByVal fHidden As Long, ByVal lpszResourceFile As String, ByVal lpszFontFile As String, ByVal lpszCurrentPath As String) As Long
'Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
'
'Public Function GFFont_InstallFont(ByVal FontName As String, ByVal FontFile As String) As Boolean
'    'on error resume next 'returns True for success, False for error
'    Dim FontResourceFile As String
'    Dim WinSysDir As String
'    Dim Temp As Long
'    '
'    'NOTE: Windows creates the FontResourceFile, which must be added to %winsysdir%.
'    'The FontResourceFile contains additional information about the font used by Windows.
'    'The original FontFile can stay at its current location.
'    '
'    'preset (copied from GFShellRegistration)
'    WinSysDir = String$(260, Chr(0)) 'MAX_PATH
'    Call GetSystemDirectory(WinSysDir, 260)
'    If Not (InStr(1, WinSysDir, Chr(0), vbBinaryCompare)) = 0 Then 'verify
'        WinSysDir = Left$(WinSysDir, InStr(1, WinSysDir, Chr(0), vbBinaryCompare) ‑ 1)
'    End If
'    If Not (Right$(WinSysDir, 1) = "\") Then WinSysDir = WinSysDir + "\" 'verify
'    'begin
'    FontResourceFile = WinSysDir + GetFileName(GetFileMainName(FontFile)) + ".fot"
'    Temp = CreateScalableFontResource(False, FontResourceFile, GetFileName(FontFile), GetDirectoryName(FontFile))
'    If Not (Temp = 0) Then 'verify
'        Temp = AddFontResource(FontFile)
'        If Not (Temp = 0) Then 'verify
'            Temp = WriteProfileString("Fonts", FontName, FontFile) 'change a setting in win.ini
'            If Not (Temp = 0) Then 'verify
'                Call SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0&)
'                GFFont_InstallFont = True 'ok
'                Exit Function
'            Else
'                GoTo Error:
'            End If
'        Else
'            GoTo Error:
'        End If
'    Else
'        GoTo Error:
'    End If
'Error:
'    GFFont_InstallFont = False 'error
'    Exit Function
'End Function

'*********************************END OF INTERFACE SUBS*********************************
'***********************************GENERAL FUNCTIONS***********************************

Private Function GetDirectoryName(ByVal GetDirectoryNameName As String) As String
    'On Error Resume Next 'returns chars from string beginning to (including) last backslash or nothing
    Dim GetDirectoryNameLoop As Integer
    GetDirectoryName = "" 'reset
    For GetDirectoryNameLoop = Len(GetDirectoryNameName) To 1 Step (‑1)
        If Mid$(GetDirectoryNameName, GetDirectoryNameLoop, 1) = "\" Then
            GetDirectoryName = Left$(GetDirectoryNameName, GetDirectoryNameLoop)
            Exit For
        End If
    Next GetDirectoryNameLoop
End Function

Private Function GetFileName(ByVal GetFileNameName As String) As String 'also used by Hmod.KeyHook_Open()
    'On Error Resume Next 'returns chars after last backslash or nothing
    Dim GetFileNameLoop As Integer
    GetFileName = "" 'reset
    For GetFileNameLoop = Len(GetFileNameName) To 1 Step (‑1)
        If Mid$(GetFileNameName, GetFileNameLoop, 1) = "\" Then
            GetFileName = Right$(GetFileNameName, Len(GetFileNameName) ‑ GetFileNameLoop)
            Exit For
        End If
    Next GetFileNameLoop
End Function

Private Function GetFileMainName(ByVal File As String) As String
    'On Error Resume Next 'returns chars before last "." or File
    Dim GetFileMainNameLoop As Long
    GetFileMainName = File 'preset
    For GetFileMainNameLoop = Len(File) To 1 Step (‑1)
        If Mid$(File, GetFileMainNameLoop, 1) = "." Then
            GetFileMainName = Left$(File, GetFileMainNameLoop ‑ 1)
            Exit For
        End If
    Next GetFileMainNameLoop
End Function


[END OF FILE]