Windows Font List

[SMcNeill]

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. 

[SpriggsySpriggs]

Using the Win32 API, one can also access the registry to list all installed fonts:

Code: (Select All)

Option Explicit

$Console:Only

$NoPrefix



'$Include:'WinReg.BI'



Const STANDARD_RIGHTS_READ = &H00020000

Const KEY_QUERY_VALUE = &H0001

Const KEY_ENUMERATE_SUB_KEYS = &H0008

Const KEY_NOTIFY = &H0010

Const SYNCHRONIZE = &H00100000

Const ERROR_SUCCESS = 0

Const KEY_READ = (STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE)



Dim As _Offset hKey

Dim As String sRoot: sRoot = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts" + Chr$(0)

If RegOpenKeyEx(HKEY_LOCAL_MACHINE, _Offset(sRoot), 0, KEY_READ, _Offset(hKey)) = ERROR_SUCCESS Then

    QueryKey (hKey)

Else

    Print "OOPS"

End If

RegCloseKey (hKey)



Sub QueryKey (hKey As _Offset)

    Const MAX_VALUE_NAME = 16383

    Const ERROR_SUCCESS = 0



    Dim As _Unsigned Long cbName, cValues, cchMaxValue, cbMaxValueData

    Dim As _Unsigned Long i, retCode



    Dim As String achValue: achValue = Space$(MAX_VALUE_NAME)

    Dim As _Unsigned Long cchValue: cchValue = MAX_VALUE_NAME



    retCode = RegQueryInfoKey(hKey, 0, 0, 0, 0, 0, 0, _Offset(cValues), _Offset(cbMaxValueData), 0, 0, 0)

    Dim As String buffer: buffer = Space$(cbMaxValueData)

    If cValues Then

        'Print "Number of values: "; cValues

        For i = 0 To cValues

            cchValue = MAX_VALUE_NAME

            achValue = Space$(MAX_VALUE_NAME)

            retCode = RegEnumValue(hKey, i, _Offset(achValue), _Offset(cchValue), 0, 0, 0, 0)

            If retCode = ERROR_SUCCESS Then

                Dim As _Unsigned Long lpData: lpData = cbMaxValueData

                buffer = Space$(cbMaxValueData)

                Dim As _Unsigned Long dwRes: dwRes = RegQueryValueEx(hKey, _Offset(achValue), 0, 0, _Offset(buffer), _Offset(lpData))

                Print i; Mid$(achValue, 1, InStr(achValue, Chr$(0)) - 1), Mid$(buffer, 1, InStr(buffer, Chr$(0)) - 1)

            End If

        Next

    End If

End Sub



'$Include:'WinReg.BM'

   

[SMcNeill]

That's the same thing I did -- read the registry list.  I just used Powershell instead of theAPIs to do it.  

[SpriggsySpriggs]

That's the same thing I did -- read the registry list.  I just used Powershell instead of theAPIs to do it.  

Yes. I am aware, hence "also". I'm just using Win32. Since we can. And since it is faster.

[TerryRitchie]

@TerryRitchie I think I've got it sorted out -- you're shelling out to command prompt and not terminal.   Give this a run from the command line, like you did above, and see if you still get the error message:

Code: (Select All)

cmd "Powershell Get-ItemProperty 'HKLM:\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts'|Out-File -Encoding Ascii 'temp_fontlist.txt'"

---

(You can see the difference in the two methods above with command prompt.  The first tosses the error like you're experiencing.  The second runs with no issues.   )

---

so the change with the code I've been sharing should be just to make certain to add that "cmd" to the front of that shell statement, as we see above.

I tried the line in both command prompt (command) and terminal (cmd) and this time I did not get an error message but still no text file created.

[SpriggsySpriggs]

@TerryRitchie

Try using this as an alternative:

Code: (Select All)

Option Explicit
$Console:Only 'comment out if necessary
$NoPrefix

Shell "PowerShell -NoProfile Get-ItemProperty '" + Chr$(34) + "HKLM:\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts" + Chr$(34) + "' | Out-File -Encoding Ascii " + Chr$(34) + "temp_fontlist.txt" + Chr$(34)
If FileExists("temp_fontlist.txt") Then Print ReadFile$("temp_fontlist.txt")

[TerryRitchie]

@TerryRitchie

Try using this as an alternative:

Code: (Select All)

Option Explicit
$Console:Only 'comment out if necessary
$NoPrefix

Shell "PowerShell -NoProfile Get-ItemProperty '" + Chr$(34) + "HKLM:\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts" + Chr$(34) + "' | Out-File -Encoding Ascii " + Chr$(34) + "temp_fontlist.txt" + Chr$(34)
If FileExists("temp_fontlist.txt") Then Print ReadFile$("temp_fontlist.txt")

That made the text file, but it looks the same as before (see below).

I also had to comment the second line. V3.12.0 sees it as a syntax error.

[SpriggsySpriggs]

Terry, I'm on v3.12.0
I have no syntax error in my IDE. Are you sure you installed QB64 to a fresh folder?

For reference, here is my output running that same code in v3.12.0:

  temp_fontlist.txt (Size: 32.63 KB / Downloads: 14)

To be on the safe side, I ran it as $CONSOLE:ONLY and as a regular window. Both gave me the same results. Something is wack with your install.

[SMcNeill]

@TerryRitchie At this point, all I can determine is your version of Windows/QB64PE/PC is broke. 

Batang & BatangChe & Gungsuh & GungsuhChe (TrueType)                        : b
                                                                              a
                                                                              t
                                                                              a
                                                                              n
                                                                              g
                                                                              .
                                                                              t
                                                                              t
                                                                              c

If you look at the above, it's giving you the proper information.  To the left is the font name.  On the right, after the : is the font file name -- it's just interrupted by a crapload of CRLF characters.

batang.ttc

.ttc?  Why isn't that a .ttf?  What the heck is a .ttc?  LOL!

Bt what's odd here is the NAME is formatted properly, with proper encoding and spacing.  That's 100% ANSI/ASCII/UTF8 text.  (Whatever your system is set to default to.)  But what the heck is with the "one character, 100 spaces between characters??"

That's just a simple PRINT statement at work, correct??

Then that's NOT *just* a CRLF that you're dealing with -- if it was b (CRLF) a (CRLF) t (CRLF)..., then *those characters would all be printed at the start of the line!   

Instead, we're seeing something even stranger such as b (CRLF) (Space 50) a (CRLF) (Space 50) t (CRLF) (Space 50)...    WTH type of formatting produces output like that??!!

I'm lost as to what's glitching out on your PC with this one.  You've got me 100% stumped here!

[SMcNeill]

Code: (Select All)

Screen _NewImage(800, 600, 32)

Open "z:\temp_fontlist.txt" For Binary As #1

Do

    Line Input #1, junk$

    Print junk$, "("; Len(junk$); "chars)"

    If Len(junk$) Then

        For i = 1 To Len(junk$)

            Print Asc(junk$, i);

        Next

        Print

    End If

    Sleep

Loop Until EOF(1)

With output that looks like:

Code: (Select All)

( 0 chars)
( 0 chars)
PSPath                                                                      : M ( 79 chars)
80  83  80  97  116  104  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  58  32  77
                                                                              i ( 79 chars)
32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  105
                                                                              c ( 79 chars)
32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  99
                                                                              r ( 79 chars)
32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  114
                                                                              o ( 79 chars)
32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  32  111

78 spaces between each character??   WTH type of encoding is that?  That's definitely NOT unicode or wide-format text! 

How the heck can your system produce such output??