Windows Font List

[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'