Code: (Select All)
Screen _NewImage(800, 600, 32)
'$Console:Only
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
System
Sub GetFontList
Shell _Hide "Powershell -command " + Chr$(34) + "$Host.UI.RawUI.BufferSize = New-Object Management.Automation.Host.Size (200, 50); Get-ItemProperty 'HKLM:\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts'|Out-File -Encoding Ascii 'temp_fontlist.txt'" + Chr$(34)
If _FileExists("temp_fontlist.txt") Then
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
Else 'very poor error handling here
Print "Powershell failed to create font list."
Beep
Sleep
Exit Sub
End If
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
The above will generate, sort, and display a list of all the fonts which is installed on an user's Windows PC. This gives you both the font name and style (such as "Courier New Bold"), as well as the filename ("courbd.ttf", in this case).
(Code updated to the latest version in this thread, which should have fixes for terminal vs console, and also for too small of a console/terminal size.)