wanted: program to process Windows Font files
#15
I found the code I had made for displaying the Windows font dialog and then displaying the font selected. It could use some cleanup but I did manage to quickly adjust the CHOOSEFONT type to work in 64 bit so the code does work in 32 or 64. Again, it can be made better. This is old code from before I developed better habits. Anyways, here ya go!

Code: (Select All)
$VersionInfo:Comments=Testing Font Dialogs
$If FONTDBI = UNDEFINED Then
    $Let FONTDBI = TRUE
    Const HKEY_CLASSES_ROOT = &H80000000~&
    Const HKEY_CURRENT_USER = &H80000001~&
    Const HKEY_LOCAL_MACHINE = &H80000002~&
    Const HKEY_USERS = &H80000003~&
    Const HKEY_PERFORMANCE_DATA = &H80000004~&
    Const HKEY_CURRENT_CONFIG = &H80000005~&
    Const HKEY_DYN_DATA = &H80000006~&
    Const REG_OPTION_VOLATILE = 1
    Const REG_OPTION_NON_VOLATILE = 0
    Const REG_CREATED_NEW_KEY = 1
    Const REG_OPENED_EXISTING_KEY = 2
    Const REG_NONE = 0
    Const REG_SZ = 1
    Const REG_EXPAND_SZ = 2
    Const REG_BINARY = 3
    Const REG_DWORD_LITTLE_ENDIAN = 4 '   value is defined REG_DWORD in Windows header files
    Const REG_DWORD = 4 '                  32-bit number
    Const REG_DWORD_BIG_ENDIAN = 5 '       some UNIX systems support big-endian architectures
    Const REG_LINK = 6
    Const REG_MULTI_SZ = 7
    Const REG_RESOURCE_LIST = 8
    Const REG_FULL_RESOURCE_DESCRIPTOR = 9
    Const REG_RESOURCE_REQUIREMENTS_LIST = 10
    Const REG_QWORD_LITTLE_ENDIAN = 11 '  64-bit number in little-endian format
    Const REG_QWORD = 11 '                 64-bit number
    Const REG_NOTIFY_CHANGE_NAME = 1
    Const REG_NOTIFY_CHANGE_ATTRIBUTES = 2
    Const REG_NOTIFY_CHANGE_LAST_SET = 4
    Const REG_NOTIFY_CHANGE_SECURITY = 8
    Const KEY_ALL_ACCESS = &HF003F&
    Const KEY_CREATE_LINK = &H0020&
    Const KEY_CREATE_SUB_KEY = &H0004&
    Const KEY_ENUMERATE_SUB_KEYS = &H0008&
    Const KEY_EXECUTE = &H20019&
    Const KEY_NOTIFY = &H0010&
    Const KEY_QUERY_VALUE = &H0001&
    Const KEY_READ = &H20019&
    Const KEY_SET_VALUE = &H0002&
    Const KEY_WOW64_32KEY = &H0200&
    Const KEY_WOW64_64KEY = &H0100&
    Const KEY_WRITE = &H20006&
    Const ERROR_SUCCESS = 0
    Const ERROR_FILE_NOT_FOUND = &H2&
    Const ERROR_INVALID_HANDLE = &H6&
    Const ERROR_MORE_DATA = &HEA&
    Const ERROR_NO_MORE_ITEMS = &H103&
    Declare Dynamic Library "advapi32"
        Function RegOpenKeyExA& (ByVal hKey As _Offset, Byval lpSubKey As _Offset, Byval ulOptions As _Unsigned Long, Byval samDesired As _Unsigned Long, Byval phkResult As _Offset)
        Function RegCloseKey& (ByVal hKey As _Offset)
        Function RegEnumValueA& (ByVal hKey As _Offset, Byval dwIndex As _Unsigned Long, Byval lpValueName As _Offset, Byval lpcchValueName As _Offset, Byval lpReserved As _Offset, Byval lpType As _Offset, Byval lpData As _Offset, Byval lpcbData As _Offset)
    End Declare
    Const CF_APPLY = &H200& '             Displays Apply button
    Const CF_ANSIONLY = &H400& '          list ANSI fonts only
    Const CF_BOTH = &H3& '                list both Screen and Printer fonts
    Const CF_EFFECTS = &H100& '          Display Underline and Strike Through boxes
    Const CF_ENABLEHOOK = &H8& '          set hook to custom template
    Const CF_ENABLETEMPLATE = &H10& '     enable custom template
    Const CF_ENABLETEMPLATEHANDLE = &H20&
    Const CF_FIXEDPITCHONLY = &H4000& '  list only fixed-pitch fonts
    Const CF_FORCEFONTEXIST = &H10000& '  indicate error when font not listed is chosen
    Const CF_INACTIVEFONTS = &H2000000& ' display hidden fonts in Win 7 only
    Const CF_INITTOLOGFONTSTRUCT = &H40& 'use the structure pointed to by the lpLogFont member
    Const CF_LIMITSIZE = &H2000& '        select font sizes only within nSizeMin and nSizeMax members
    Const CF_NOOEMFONTS = &H800& '        should not allow vector font selections
    Const CF_NOFACESEL = &H80000& '       prevent displaying initial selection in font name combo box.
    Const CF_NOSCRIPTSEL = &H800000& '    Disables the Script combo box
    Const CF_NOSIMULATIONS = &H1000& '    Disables selection of font simulations
    Const CF_NOSIZESEL = &H200000& '     Disables Point Size selection
    Const CF_NOSTYLESEL = &H100000& '     Disables Style selection
    Const CF_NOVECTORFONTS = &H800&
    Const CF_NOVERTFONTS = &H1000000&
    Const CF_OEMTEXT = &H7&
    Const CF_PRINTERFONTS = &H2& '        list fonts only supported by printer associated with the device
    Const CF_SCALABLEONLY = &H20000& '    select only vector fonts, scalable printer fonts, and TrueType fonts
    Const CF_SCREENFONTS = &H1& '        lists only the screen fonts supported by system
    Const CF_SCRIPTSONLY = &H400& '       lists all non-OEM, Symbol and ANSI sets only
    Const CF_SELECTSCRIPT = &H400000& '  can only use set specified in the Scripts combo box
    Const CF_SHOWHELP = &H4& '           displays Help button reference
    Const CF_TTONLY = &H40000& '         True Type only
    Const CF_USESTYLE = &H80& '           copies style data for the user's selection to lpszStyle buffer
    Const CF_WYSIWYG = &H8000& '          only list fonts available on both the printer and display
    Const BOLD_FONTTYPE = &H100&
    Const ITALIC_FONTTYPE = &H200&
    Const PRINTER_FONTTYPE = &H4000&
    Const REGULAR_FONTTYPE = &H400&
    Const SCREEN_FONTTYPE = &H2000&
    Const SIMULATED_FONTTYPE = &H8000&
    Const FW_DONTCARE = 0
    Const FW_THIN = 100
    Const FW_ULTRALIGHT = 200
    Const FW_LIGHT = 300
    Const FW_REGULAR = 400
    Const FW_MEDIUM = 500
    Const FW_SEMIBOLD = 600
    Const FW_BOLD = 700
    Const FW_ULTRABOLD = 800
    Const FW_HEAVY = 900
    Const DEFAULT_CHARSET = 1
    Const LF_DEFAULT = 0
    Const FF_ROMAN = 16
    Const LF_FACESIZE = 32
    Const GMEM_MOVEABLE = &H2
    Const GMEM_ZEROINIT = &H40
    Declare Dynamic Library "comdlg32"
        Function ChooseFont& Alias "ChooseFontA" (ByVal lpcf As _Offset)
        Function CommDlgExtendedError& () '                'dialog box error checking procedure
    End Declare
    Type CHOOSEFONT
        As _Unsigned Long lStructSize
        $If 64BIT Then
            As String * 4 alignment
        $End If
        As _Offset hwndOwner, hDC, lpLogFont
        As Long iPointSize
        As _Unsigned Long Flags, rgbColors
        $If 64BIT Then
            As String * 4 alignment2
        $End If
        As _Offset lCustData, lpfnHook, lpTemplateName, hInstance, lpszStyle
        As _Unsigned Integer nFontType
        As String * 2 alignment3
        As Long nSizeMin, nSizeMax
        $If 64BIT Then
            As String * 4 alignment4
        $End If
    End Type
    Type LOGFONT
        lfHeight As Long
        lfWidth As Long
        lfEscapement As Long
        lfOrientation As Long
        lfWeight As Long
        lfItalic As _Byte '    not 0 when user selected
        lfUnderline As _Byte ' not 0 when user selected
        lfStrikeOut As _Byte ' not 0 when user selected
        lfCharSet As _Byte
        lfOutPrecision As _Byte
        lfClipPrecision As _Byte
        lfQuality As _Byte
        lfPitchAndFamily As _Byte
        lfFaceName As String * 32 'contains name listed in dialog
    End Type
    Dim Shared FontType As String
    Dim Shared PointSize&
    Dim Shared FontColor&
    Dim Shared fontpath As String
    Dim Shared selectedfont As String
    Dim Shared FontName As String
    Dim Shared FontEff As String
$End If

'MAIN MODULE
_Title "LoadFont Test with Accurate Search"
Screen _NewImage(1280, 720, 32)
AGAIN:
Cls
_Font 16
y = CsrLin
x = Pos(0)
f& = LoadFont
If f& > 0 Then
    _Font f&
    Locate 20, x
    Print "This is "; FontName; ", loaded from "; selectedfont; " in"; PointSize&; "points"
    Print "Go again? (Y/N)"
Else
    System
End If
Do
    k$ = InKey$
    If UCase$(k$) = "Y" Then
        GoTo AGAIN
    ElseIf UCase$(k$) = "N" Then
        System
    End If
Loop Until UCase$(k$) = "Y" Or UCase$(k$) = "N"
'END MAIN MODULE

$If FONTDBM = UNDEFINED Then
    $Let FONTDBM = TRUE
    Sub GetFonts
        Dim hKey As _Offset
        Dim Ky As _Offset
        Dim SubKey As String
        Dim Value As String
        Dim bData As String
        Dim t As String
        Dim dwType As _Unsigned Long
        Dim numBytes As _Unsigned Long
        Dim numTchars As _Unsigned Long
        Dim l As Long
        Dim dwIndex As _Unsigned Long
        FONTFILE = FreeFile
        Open "F0NTList.INF" For Output As #FONTFILE 'create a new file for font data
        Ky = HKEY_LOCAL_MACHINE
        SubKey = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts" + Chr$(0)
        Value = Space$(261) 'ANSI Value name limit 260 chars + 1 null
        bData = Space$(&H7FFF) 'arbitrary
        l = RegOpenKeyExA(Ky, _Offset(SubKey), 0, KEY_READ, _Offset(hKey))
        If l Then
        Else
            dwIndex = 0
            Do
                numBytes = Len(bData)
                numTchars = Len(Value)
                l = RegEnumValueA(hKey, dwIndex, _Offset(Value), _Offset(numTchars), 0, _Offset(dwType), _Offset(bData), _Offset(numBytes))
                If l Then
                    Exit Do
                Else
                    Print #FONTFILE, Left$(Value, numTchars) + "=" + formatData(dwType, numBytes, bData)
                End If
                dwIndex = dwIndex + 1
            Loop
            Close #FONTFILE
            l = RegCloseKey(hKey)
        End If
    End Sub
    Function whatType$ (dwType As _Unsigned Long)
        Select Case dwType
            Case REG_SZ: whatType = "REG_SZ"
            Case REG_EXPAND_SZ: whatType = "REG_EXPAND_SZ"
            Case REG_BINARY: whatType = "REG_BINARY"
            Case REG_DWORD: whatType = "REG_DWORD"
            Case REG_DWORD_BIG_ENDIAN: whatType = "REG_DWORD_BIG_ENDIAN"
            Case REG_LINK: whatType = "REG_LINK"
            Case REG_MULTI_SZ: whatType = "REG_MULTI_SZ"
            Case REG_RESOURCE_LIST: whatType = "REG_RESOURCE_LIST"
            Case REG_FULL_RESOURCE_DESCRIPTOR: whatType = "REG_FULL_RESOURCE_DESCRIPTOR"
            Case REG_RESOURCE_REQUIREMENTS_LIST: whatType = "REG_RESOURCE_REQUIREMENTS_LIST"
            Case REG_QWORD: whatType = "REG_QWORD"
            Case Else: whatType = "unknown"
        End Select
    End Function
    Function whatKey$ (hKey As _Offset)
        Select Case hKey
            Case HKEY_CLASSES_ROOT: whatKey = "HKEY_CLASSES_ROOT"
            Case HKEY_CURRENT_USER: whatKey = "HKEY_CURRENT_USER"
            Case HKEY_LOCAL_MACHINE: whatKey = "HKEY_LOCAL_MACHINE"
            Case HKEY_USERS: whatKey = "HKEY_USERS"
            Case HKEY_PERFORMANCE_DATA: whatKey = "HKEY_PERFORMANCE_DATA"
            Case HKEY_CURRENT_CONFIG: whatKey = "HKEY_CURRENT_CONFIG"
            Case HKEY_DYN_DATA: whatKey = "HKEY_DYN_DATA"
        End Select
    End Function
    Function formatData$ (dwType As _Unsigned Long, numBytes As _Unsigned Long, bData As String)
        Dim t As String
        Dim ul As _Unsigned Long
        Dim b As _Unsigned _Byte
        Select Case dwType
            Case REG_SZ, REG_EXPAND_SZ, REG_MULTI_SZ
                formatData = Left$(bData, numBytes - 1)
            Case REG_DWORD
                t = LCase$(Hex$(CVL(Left$(bData, 4))))
                formatData = "0x" + String$(8 - Len(t), &H30) + t
            Case Else
                If numBytes Then
                    b = Asc(Left$(bData, 1))
                    If b < &H10 Then
                        t = t + "0" + LCase$(Hex$(b))
                    Else
                        t = t + LCase$(Hex$(b))
                    End If
                End If
                For ul = 2 To numBytes
                    b = Asc(Mid$(bData, ul, 1))
                    If b < &H10 Then
                        t = t + " 0" + LCase$(Hex$(b))
                    Else
                        t = t + " " + LCase$(Hex$(b))
                    End If
                Next
                formatData = t
        End Select
    End Function
    Function ShowFont$ (hWnd As _Offset)
        Dim cf As CHOOSEFONT
        Dim lfont As LOGFONT
        Shared FontColor&, FontType$, FontEff$, PointSize As Long 'shared with main program
        lfont.lfHeight = LF_DEFAULT ' determine default height '       set dailog box defaults
        lfont.lfWidth = LF_DEFAULT ' determine default width
        lfont.lfEscapement = LF_DEFAULT ' angle between baseline and escapement vector
        lfont.lfOrientation = LF_DEFAULT ' angle between baseline and orientation vector
        lfont.lfWeight = FW_REGULAR ' normal weight i.e. not bold
        lfont.lfCharSet = DEFAULT_CHARSET ' use default character set
        lfont.lfOutPrecision = LF_DEFAULT ' default precision mapping
        lfont.lfClipPrecision = LF_DEFAULT ' default clipping precision
        lfont.lfQuality = LF_DEFAULT ' default quality setting
        lfont.lfPitchAndFamily = LF_DEFAULT Or FF_ROMAN ' default pitch, proportional with serifs
        lfont.lfFaceName = "Calibri" + Chr$(0) ' string must be null-terminated
        cf.lStructSize = Len(cf) ' size of structure
        cf.hwndOwner = hWnd ' window opening the dialog box
        cf.lpLogFont = _Offset(lfont)
        cf.iPointSize = 120 ' 12 point font (in units of 1/10 point)
        cf.Flags = CF_BOTH Or CF_EFFECTS Or CF_FORCEFONTEXIST Or CF_INITTOLOGFONTSTRUCT Or CF_LIMITSIZE
        cf.rgbColors = _RGB(238, 161, 50)
        cf.nFontType = REGULAR_FONTTYPE ' regular font type i.e. not bold or anything
        cf.nSizeMin = 10 ' minimum point size
        cf.nSizeMax = 72 ' maximum point size
        If ChooseFont&(_Offset(cf)) <> 0 Then '    'Initiate Dialog and Read user selections
            ShowFont = Left$(lfont.lfFaceName, InStr(lfont.lfFaceName, Chr$(0)) - 1)
            FontColor& = _RGB(_Blue32(cf.rgbColors), _Green32(cf.rgbColors), _Red32(cf.rgbColors))
            If cf.nFontType And BOLD_FONTTYPE Then FontType$ = "Bold"
            If cf.nFontType And ITALIC_FONTTYPE Then FontType$ = FontType$ + " Italic"
            If cf.nFontType And REGULAR_FONTTYPE Then FontType$ = "Regular"
            If lfont.lfUnderline Then FontEff$ = "Underline"
            If lfont.lfStrikeOut Then FontEff$ = FontEff$ + "Strikeout"
            PointSize = cf.iPointSize \ 10
        Else
            ShowFont = ""
        End If
    End Function
    Function LoadFont&
        Font$ = ShowFont(_WindowHandle) '           call Dialog Box and get the font selection
        If Font$ <> "" Then
            F = FreeFile
            Dim fontlist(n) As String
            Open "F0NTList.INF" For Binary As #F
            If LOF(F) = 0 Then GetFonts
            Do
                If Not EOF(F) Then
                    Line Input #F, regfont$
                    i = i + 1
                    ReDim _Preserve fontlist(i) As String
                    fontlist(i) = regfont$
                End If
            Loop Until EOF(F)
            Close #F
            ReDim Results(0) As Results
            FFont$ = Font$
            a = Array_String.FindAny(fontlist(), String.Trim(Font$ + " " + FontType$), Results(), 1) 'test1
            Print "="; Font$; " "; FontType$
            If a > 1 Or a = 0 Then
                Print "Couldn't find it with first search, broadening"
                a = Array_String.FindAny(fontlist(), String.Trim(Font$ + " " + FontType$), Results(), 0) 'test2
                Print "%"; Font$; " "; FontType$
                If a = 0 Then
                    Print "Couldn't find it with second search, broadening"
                    If Left$(Font$, InStr(Font$, " ")) = "" Then
                        a = Array_String.FindAny(fontlist(), String.Trim(Font$ + " " + FontType$), Results(), 1) 'test3
                        Print "="; String.Trim(Font$ + " " + FontType$)
                    Else
                        a = Array_String.FindAny(fontlist(), Left$(Font$, InStr(Font$, " ")) + FontType$, Results(), 1) 'test3
                        Print "="; Left$(Font$, InStr(Font$, " ")) + FontType$
                    End If
                    If a = 0 Then
                        Print "Couldn't find it with third search, broadening"
                        If Left$(Font$, InStr(Font$, " ")) = "" Then
                            a = Array_String.FindAny(fontlist(), String.Trim(Font$ + " " + FontType$), Results(), 0) 'test4
                            Print "%"; String.Trim(Font$ + " " + FontType$)
                        Else
                            a = Array_String.FindAny(fontlist(), Left$(Font$, InStr(Font$, " ")) + FontType$, Results(), 0) 'test4
                            Print "%"; Left$(Font$, InStr(Font$, " ")) + FontType$
                        End If
                        If a = 0 Then
                            Print "Couldn't find it with fourth search, broadening"
                            a = Array_String.FindAny(fontlist(), Font$, Results(), 1) 'test5
                            Print "="; Font$
                            If a = 0 Then
                                Print "Couldn't find it with fifth search, broadening"
                                a = Array_String.FindAny(fontlist(), Font$, Results(), 0) 'test6
                                Print "%"; Font$
                                If a = 0 Then
                                    Print "Couldn't find it with sixth search, broadening"
                                    If Left$(Font$, InStr(Font$, " ")) = "" Then
                                        a = Array_String.FindAny(fontlist(), String.Trim(Font$), Results(), 1) 'test7
                                        Print "="; String.Trim(Font$)
                                    Else
                                        a = Array_String.FindAny(fontlist(), Left$(Font$, InStr(Font$, " ")), Results(), 1) 'test7
                                        Print "="; Left$(Font$, InStr(Font$, " "))
                                    End If
                                    If a = 0 Then
                                        Print "Couldn't find it with seventh search, broadening"
                                        If Left$(Font$, InStr(Font$, " ")) = "" Then
                                            a = Array_String.FindAny(fontlist(), String.Trim(Font$), Results(), 0) 'test8
                                            Print "%"; String.Trim(Font$)
                                        Else
                                            a = Array_String.FindAny(fontlist(), Left$(Font$, InStr(Font$, " ")), Results(), 0) 'test8
                                            Print "%"; Left$(Font$, InStr(Font$, " "))
                                        End If
                                        If a = 0 Then
                                            Print "Couldn't find a suitable font matching that search term in all 8 searches"
                                            Print "Last ditch effort to find font"
                                            If Left$(Font$, InStr(Font$, " ")) = "" Then
                                                LastDitchEffort$ = LastDitch(fontlist(), String.Trim(Font$)) 'test9
                                            Else
                                                LastDitchEffort$ = LastDitch(fontlist(), Left$(Font$, InStr(Font$, " "))) 'test9
                                            End If
                                            If LastDitchEffort$ = "" Then
                                                Print "Cannot find the font."
                                                Print "Ending"
                                                End
                                            Else
                                                Print LastDitchEffort$
                                            End If
                                        End If
                                    End If
                                End If
                            End If
                        End If
                    End If
                End If
            End If
            If LastDitchEffort$ = "" Then
                For y = LBound(Results) To UBound(Results)
                    If InStr(Results(y).Result, Left$(Font$, _InStrRev(Font$, " "))) And InStr(UCase$(FontType$), "ITALIC") = 0 And InStr(UCase$(FontType$), "BOLD") = 0 Then
                        Print Results(y).Result
                        'PRINT "TRUE1"
                        Exit For
                    ElseIf InStr(Results(y).Result, Font$ + " " + FontType$) Then
                        Print Results(y).Result
                        'PRINT "TRUE2"
                        Exit For
                    ElseIf InStr(UCase$(FontType$), "ITALIC") And InStr(UCase$(FontType$), "BOLD") = 0 And InStr(UCase$(Results(y).Result), "ITALIC") And InStr(UCase$(Results(y).Result), "BOLD") = 0 Then
                        Print Results(y).Result
                        'PRINT "TRUE3"
                        Exit For
                    ElseIf InStr(UCase$(FontType$), "ITALIC") And InStr(UCase$(FontType$), "BOLD") And InStr(UCase$(Results(y).Result), "ITALIC") And InStr(UCase$(Results(y).Result), "BOLD") Then
                        Print Results(y).Result
                        'PRINT "TRUE4"
                        Exit For
                    ElseIf InStr(Results(y).Result, Left$(Font$, _InStrRev(Font$, " "))) Then
                        Print Results(y).Result
                        'PRINT "TRUE5"
                        Exit For
                    ElseIf InStr(Results(y).Result, Left$(Font$, _InStrRev(Font$, " "))) And InStr(Results(y).Result, FontType$) Then
                        Print Results(y).Result
                        'PRINT "TRUE5"
                        Exit For
                    End If
                Next
            End If
            If LastDitchEffort$ <> "" Then
                selectedfont$ = fontlist(Array_String.FirstOrDefault(fontlist(), LastDitchEffort$, 1))
            Else
                selectedfont$ = fontlist(Array_String.FirstOrDefault(fontlist(), Results(y).Result, 1))
            End If
            FontName$ = Left$(selectedfont$, InStr(selectedfont$, "=") - 1)
            selectedfont$ = Right$(selectedfont$, Len(selectedfont$) - InStr(selectedfont$, "="))
            If selectedfont$ <> "" Then
                fontpath$ = Environ$("SYSTEMROOT") + "\Fonts\"
                font& = _LoadFont(fontpath$ + selectedfont$, PointSize&)
                If InStr(UCase$(FontType$), "BOLD") And InStr(UCase$(FontType$), "ITALIC") And InStr(UCase$(FontType$), "EXTRA") = 0 And InStr(UCase$(FontType$), "ULTRA") = 0 Then ' AND INSTR(UCASE$(FontType$), "DEMI") = 0
                    font& = _LoadFont(fontpath$ + selectedfont$, PointSize&, "BOLD,ITALIC")
                ElseIf InStr(UCase$(FontType$), "BOLD") And InStr(UCase$(FontType$), "ITALIC") = 0 And InStr(UCase$(FontType$), "EXTRA") = 0 And InStr(UCase$(FontType$), "ULTRA") = 0 Then ' AND INSTR(UCASE$(FontType$), "DEMI") = 0 THEN
                    font& = _LoadFont(fontpath$ + selectedfont$, PointSize&, "BOLD")
                ElseIf InStr(UCase$(FontType$), "ITALIC") And InStr(UCase$(FontType$), "BOLD") = 0 Then
                    font& = _LoadFont(fontpath$ + selectedfont$, PointSize&, "ITALIC")
                Else
                    font& = _LoadFont(fontpath$ + selectedfont$, PointSize&)
                End If
                If font& > 0 Then
                    Color FontColor&
                    LoadFont = font&
                Else
                    LoadFont = 0
                End If
            End If
        End If
    End Function
    Function LastDitch$ (fontlist() As String, Font As String)
        Dim searchFont As String
        For i = 1 To Len(Font$)
            searchFont = Font
            searchFont = String.Insert(searchFont, " ", i)
            a = Array_String.FirstOrDefault(fontlist(), searchFont, 1)
            If a > 0 Then
                Exit For
            End If
        Next
        LastDitch$ = fontlist(a)
    End Function
    $If STRINGMETH = UNDEFINED Then
        $Let STRINGMETH = TRUE
        Type Results
            SearchArrayPosition As Long
            Result As String
        End Type
        Function String.Trim$ (trimString As String)
            trimString = LTrim$(RTrim$(trimString))
            String.Trim = trimString
        End Function
        Function String.Insert$ (toChange As String, insert As String, position As Integer)
            newchange$ = toChange
            newchange$ = Mid$(newchange$, 1, position - 1) + insert + Mid$(newchange$, position, Len(newchange$) - position + 1)
            String.Insert = newchange$
        End Function
        Function Array_String.FindAny (SearchArray() As String, SearchString As String, Results() As Results, explicit As Integer)
            For i = LBound(SearchArray) To UBound(SearchArray)
                If explicit = 0 Then
                    If InStr(SearchArray(i), SearchString) Then
                        ReDim _Preserve Results(x) As Results
                        Results(x).Result = SearchArray(i)
                        Results(x).SearchArrayPosition = i
                        x = x + 1
                    End If
                ElseIf explicit = 1 Then
                    If SearchArray(i) = SearchString Then
                        ReDim _Preserve Results(x) As Results
                        Results(x).Result = SearchArray(i)
                        Results(x).SearchArrayPosition = i
                        x = x + 1
                    End If
                End If
            Next
            Array_String.FindAny = x
        End Function
        Function Array_String.FirstOrDefault (SearchArray() As String, SearchString As String, contains As Integer)
            For i = LBound(SearchArray) To UBound(SearchArray)
                If contains = 1 Then
                    If InStr(SearchArray(i), SearchString) Then
                        Array_String.FirstOrDefault = i
                        Exit Function
                    End If
                ElseIf contains = 0 Then
                    If SearchArray(i) = SearchString Then
                        Array_String.FirstOrDefault = i
                        Exit Function
                    End If
                End If
            Next
        End Function
    $End If
$End If

[Image: image.png][Image: image.png]
Ask me about Windows API and maybe some Linux stuff
Reply


Messages In This Thread
RE: wanted: program to process Windows Font files - by SpriggsySpriggs - 10-26-2022, 07:29 PM



Users browsing this thread: 11 Guest(s)