Posts: 1,710
Threads: 63
Joined: Jul 2022
Reputation:
52
10-26-2022, 12:12 AM
(This post was last modified: 10-26-2022, 03:53 PM by mnrvovrfc.
Edit Reason: Provided a better program
)
WARNING: a better program is provided in a later post in this topic.
Code: (Select All) dim as long ff, i, l, x, y, siz
dim as _byte goon
redim sf$(1 to 100)
chr255$ = chr$(255)
afile$ = "/tmp/fontlist.txt"
adir$ = "/usr/share/fonts/TTF"
zomd$ = "ls -1 " + adir$ + " > " + afile$
shell zomd$
adir$ = adir$ + "/"
l = 0
ff = freefile
open afile$ for input as ff
do until eof(ff)
line input #ff, a$
a$ = adir$ + a$
if _fileexists(a$) then
l = l + 1
sf$(l) = a$
else
print a$; " NOT FOUND! Something is wrong."
end if
if l >= 100 then exit do
loop
close ff
screen _newimage(800, 600, 32)
_TITLE "Check font..."
redim _preserve sf$(1 to l)
do
for i = 1 to l
for siz = 8 to 72 step 4
if _keydown(27) then exit do
m$ = "M"
han = _loadfont(sf$(i), siz)
if han > 0 then
ON ERROR GOTO ancienterrmusic
if _fontwidth(han) = 0 then m$ = ""
'if _printwidth("W") <> _printwidth("l") then m$ = ""
goon = 1
_font han
if goon = 0 then _continue
x = int(rnd * 700 + 1)
y = int(rnd * 500 + 1)
a$ = chr$(int(rnd * 95 + 33))
_printstring(x, y), a$
_font 14
_freefont han
entr$ = entr$ + sf$(i) + str$(siz) + m$ + chr255$
ON ERROR GOTO 0
end if
next
next
loop while 0
if _keydown(27) then system
$CONSOLE
_DEST _CONSOLE
for i = 1 to len(entr$)
a$ = mid$(entr$, i, 1)
if a$ = chr255$ then print else print a$;
next
print
system
ancienterrmusic:
goon = 0
resume next
Quick and dirty on Linux, tested on Manjaro MATE.
Sadly, it doesn't report accurately which is "MONOSPACE". Either it says all of them or none of them. The commented line with "_printwidth()" should have substituted for "_fontwidth()", otherwise the latter requires "MONOSPACE" parameter passed to "_loadfont()".
This only checks "TTF" directory because it has more fonts than any other place within "/usr/share/fonts".
Posts: 3,543
Threads: 164
Joined: Apr 2022
Reputation:
169
10-26-2022, 12:36 AM
(This post was last modified: 10-26-2022, 12:40 AM by bplus.)
Here is a quicky using a number of useful keywords for font:
Code: (Select All) DefLng A-Z
Screen _NewImage(800, 600, 32)
s$ = "Hello World!"
h = 10
y = 10
While h < 400
f = _LoadFont("arial.ttf", h)
_Font f
w = _PrintWidth(s$)
_PrintString ((800 - w) / 2, y), s$
h = 2 * h
y = y + _FontHeight(f) + 5
Wend
Sleep
b = b + ...
Posts: 1,710
Threads: 63
Joined: Jul 2022
Reputation:
52
Just discovered Fedora arranges font directory completely differently, there isn't even a "TTF" directory. :facepalm:
Also kept going back between "cyberbit.ttf" and another monospaced font found on the system but there was inconsistency with displaying some Unicode graphic characters. There are certain categories shown by "gucharmap" that cannot be displayed at all by the font handler of this programming system.
Posts: 1,710
Threads: 63
Joined: Jul 2022
Reputation:
52
Press [ESC] if you are afraid this goes on too long LOL.
Code: (Select All) dim as long ff, i, l, x, y, siz
dim as _byte goon
redim sf$(1 to 500)
chr255$ = chr$(255)
afile$ = "/tmp/fontlist.txt"
adir$ = "/usr/share/fonts"
zomd$ = "ls -1R " + adir$ + " > " + afile$
shell zomd$
l = 0
cudi$ = ""
ff = freefile
open afile$ for input as ff
do until eof(ff)
line input #ff, a$
if a$ = "" then _continue
if right$(a$, 1) = ":" then
cudi$ = left$(a$, len(a$) - 1) + "/"
else
a$ = cudi$ + a$
print a$
if _fileexists(a$) then
l = l + 1
sf$(l) = a$
else
print a$; " NOT FOUND! Something is wrong."
end if
end if
if l >= 500 then exit do
loop
close ff
if l = 0 then
print "I'm sorry, I couldn't find any fonts installed in the system!"
print "It must be the programmer's fault!"
end
end if
screen _newimage(800, 600, 32)
_TITLE "Check font..."
redim _preserve sf$(1 to l)
do
for i = 1 to l
for siz = 8 to 72 step 4
if _keydown(27) then exit do
m$ = "M"
han = _loadfont(sf$(i), siz)
if han > 0 then
ON ERROR GOTO ancienterrmusic
if _fontwidth(han) = 0 then m$ = ""
'if _printwidth("W") <> _printwidth("l") then m$ = ""
goon = 1
_font han
if goon = 0 then _continue
x = int(rnd * 700 + 1)
y = int(rnd * 500 + 1)
a$ = chr$(int(rnd * 95 + 33))
_printstring(x, y), a$
_font 14
_freefont han
entr$ = entr$ + sf$(i) + str$(siz) + m$ + chr255$
ON ERROR GOTO 0
end if
next
next
loop while 0
if _keydown(27) then system
$CONSOLE
_DEST _CONSOLE
for i = 1 to len(entr$)
a$ = mid$(entr$, i, 1)
if a$ = chr255$ then print else print a$;
next
print
system
ancienterrmusic:
goon = 0
resume next
This program recurses directories in "/usr/share/fonts". So Linux only.
I added the test for "L = 0" because the "out of memory" runtime error was making me haywire. Oh well I should have asked the compiler to enable range-checking...
I should have checked more extensively if the "ON ERROR GOTO" / "RESUME" amounted to anything.
Posts: 647
Threads: 24
Joined: Apr 2022
Reputation:
33
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]](https://i.ibb.co/fpXCbCX/image.png) ![[Image: image.png]](https://i.ibb.co/47V45sD/image.png)
Tread on those who tread on you
|
