03-14-2024, 11:06 AM
Code: (Select All)
Type Font_Name_Type
Name As String
FileName As String
End Type
ReDim Shared Fonts(10000) As Font_Name_Type
ReDim Shared MonoFonts(10000) As Font_Name_Type
Screen _NewImage(1280, 720, 32)
GetFontList
GetMonoFontList
numbered = -1 'number our quick list
l = 20 'number of lines to print to the screen
w = 50 'width to print to the screen
Do
Cls
_Limit 30
k = _KeyHit
Select Case k
Case 20480: s = s + 1: If s > UBound(Fonts) Then s = UBound(Fonts)
Case 18432: s = s - 1: If s < 0 Then s = 0
End Select
Locate 3, 20: Print "FONT NAME"
Locate 3, 70: Print "FILE NAME"
Locate 5
start = s: finish = s + l - 1
For i = start To finish
If numbered Then counter$ = LTrim$(Str$(i)) + ") "
Locate , 10: Print counter$ + Left$(Fonts(i).Name, w);
Locate , 70: Print Left$(Fonts(i).FileName, w)
Next
Locate 28, 15: Print "MONOSPACE FONT NAME"
Locate 28, 70: Print "FILE NAME"
Locate 30
For i1 = 0 To UBound(MonoFonts)
If numbered Then counter$ = LTrim$(Str$(i1)) + ") "
Locate , 10: Print counter$ + Left$(MonoFonts(i1).Name, w);
Locate , 70: Print Left$(MonoFonts(i1).FileName, w)
Next
_Display
Loop Until k = 27
Sub GetFontList
Shell _Hide "Powershell -command " + Chr$(34) + "Get-ItemProperty 'HKLM:\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts'|Out-File -Encoding Ascii 'temp_fontlist.txt'" + Chr$(34)
f = FreeFile
Open "temp_fontlist.txt" For Binary As #f
Do Until EOF(1)
Line Input #1, temp$
sep = InStr(temp$, ":")
l$ = _Trim$(Left$(temp$, sep - 1))
r$ = _Trim$(Mid$(temp$, sep + 1))
If l$ <> "PSPath" Then
If l$ <> "" Then ' skip the blank space lines
Fonts(count).Name = l$
Fonts(count).FileName = r$
count = count + 1
End If
Else
Exit Do ' we can stop reading files at this point (according to my tests)
End If
Loop
Close f
Kill "temp_fontlist.txt" ' clean up the file after we're done with parsing it.
count = count - 1 ' adjust for that last count + 1, which we didn't use.
ReDim _Preserve Fonts(count) As Font_Name_Type
'a quick and simple combsort to make certain our list is in alphabetical order
gap = count
Do
gap = 10 * gap \ 13
If gap < 1 Then gap = 1
i = 0
swapped = 0
Do
If Fonts(i).Name > Fonts(i + gap).Name Then
Swap Fonts(i).Name, Fonts(i + gap).Name
Swap Fonts(i).FileName, Fonts(i + gap).FileName
swapped = -1
End If
i = i + 1
Loop Until i + gap > count
Loop Until gap = 1 And swapped = 0
End Sub
Sub GetMonoFontList
count = UBound(Fonts)
newcount = 0
f = _Font
For i = 0 To count
f$ = Fonts(i).FileName
If UCase$(Right$(f$, 4)) = ".FON" Then _Continue
temp = _LoadFont(f$, 12)
_Font temp
'no need to check all characters. I chose to just check the ones that tend to vary the greatest
pw = _PrintWidth("W"): pw1 = _PrintWidth("l")
If pw = pw1 Then
pw2 = _PrintWidth(" ")
If pw = pw2 Then
pw3 = _PrintWidth(".")
If pw = pw3 Then
MonoFonts(newcount).Name = Fonts(i).Name
MonoFonts(newcount).FileName = Fonts(i).FileName
newcount = newcount + 1
End If
End If
End If
_Font f
_FreeFont temp
Next
newcount = newcount - 1
If newcount >= 0 Then ReDim _Preserve MonoFonts(newcount) As Font_Name_Type
End Sub
A version which should give us a scrollable list of all font names (note that some of these are system fonts, if you don't filter them out -- such as those with the .fon extension), as well as tell us if the font in question is monospace or not.
Screenshot below:
I'm thinking this should work whether it's shelling out to CMD or Terminal either one. If not, then I'll just have to play around with it a bit more to try and see what the heck's wrong this time with it.
