Okay, this is going to be a lot of code below. Primarily, it is because of the TTF structures and Endianess of TTF files. The code is not originally mine, it's come from a few sources that I've ported to VB.NET and changed a few things around. See this page for a C++ version that gets the font name.
This code reads through the registry for installed fonts (whether in %windir%\fonts or elsewhere), filters to only get ones with the .ttf extension (e.g. .fon and .ttc are ignored) and then it passes these font file paths to a routine, GetFontDetails, that reads through and gets the Font Name (uNameID #1) and Font Sub Family (aka Style, uNameID #2). If you are interested in getting more properties than those, go to name - Naming Table on Microsoft's Typography website and search in your browser for Name IDs. It then kicks out the Font Name, Font SubFamily and Font Path to the Console window.
Create a new VB.NET Console app and paste the below in over Module1 code and press F5.
Without further ado:
Imports System.Linq
Imports System.IO
Imports System.Text
Module Module1
Sub Main()
Dim allInstalledFonts = From e In My.Computer.Registry.LocalMachine.OpenSubKey("Software\\Microsoft\\Windows NT\\CurrentVersion\\Fonts").GetValueNames
Select My.Computer.Registry.LocalMachine.OpenSubKey("Software\\Microsoft\\Windows NT\\CurrentVersion\\Fonts").GetValue(e)
Dim ttfFonts = From e In allInstalledFonts.Where(Function(e) e.ToString.EndsWith(".ttf") Or e.ToString.EndsWith(".otf"))
Dim ttfFontsPaths = From e In ttfFonts.Select(Function(e) If(Path.GetPathRoot(e.ToString) = "", Environment.GetFolderPath(Environment.SpecialFolder.Fonts) & "\" & e.ToString, e.ToString))
Dim fonts = From e As String In ttfFontsPaths Select GetFontDetails(e.ToString)
For Each f As InstalledFont In fonts
Console.WriteLine("Name: " & f.FontName & ", SubFamily: " & f.FontSubFamily & ", Path: " & f.FontPath)
Next
Console.ReadLine()
End Sub
Public Class InstalledFont
Property FontName As String
Property FontSubFamily As String
Property FontPath As String
Sub New(ByVal name As String, ByVal subfamily As String, ByVal path As String)
FontName = name
FontSubFamily = subfamily
FontPath = path
End Sub
End Class
Public Function GetFontDetails(ByVal fontFilePath As String) As InstalledFont
Dim FontName As String = String.Empty
Dim FontSubFamily As String = String.Empty
Dim encStr = "UTF-8"
Dim strRet As String = String.Empty
Using fs As New FileStream(fontFilePath, FileMode.Open, FileAccess.Read)
Dim ttOffsetTable As New TT_OFFSET_TABLE
With ttOffsetTable
.uMajorVersion = ReadUShort(fs)
.uMinorVersion = ReadUShort(fs)
.uNumOfTables = ReadUShort(fs)
.uSearchRange = ReadUShort(fs)
.uEntrySelector = ReadUShort(fs)
.uRangeShift = ReadUShort(fs)
End With
If ttOffsetTable.uMajorVersion <> 1 Or ttOffsetTable.uMinorVersion <> 0 Then
Return Nothing
End If
Dim tblDir As New TT_TABLE_DIRECTORY
Dim found As Boolean = False
For i As Integer = 0 To ttOffsetTable.uNumOfTables
With tblDir
.Initialize()
fs.Read(.szTag, 0, .szTag.Length)
.uCheckSum = ReadULong(fs)
.uOffset = ReadULong(fs)
.uLength = ReadULong(fs)
End With
Dim enc As Encoding = Encoding.GetEncoding(encStr)
Dim s As String = enc.GetString(tblDir.szTag)
If StrComp(s, "name") = 0 Then
found = True
Exit For
End If
Next
If Not found Then Return Nothing
fs.Seek(tblDir.uOffset, SeekOrigin.Begin)
Dim ttNTHeader As New TT_NAME_TABLE_HEADER
With ttNTHeader
.uFSelector = ReadUShort(fs)
.uNRCount = ReadUShort(fs)
.uStorageOffset = ReadUShort(fs)
End With
Dim ttRecord As New TT_NAME_RECORD
For j As Integer = 0 To ttNTHeader.uNRCount
With ttRecord
.uPlatformID = ReadUShort(fs)
.uEncodingID = ReadUShort(fs)
.uLanguageID = ReadUShort(fs)
.uNameID = ReadUShort(fs)
.uStringLength = ReadUShort(fs)
.uStringOffset = ReadUShort(fs)
End With
If ttRecord.uNameID > 2 Then Exit For
Dim nPos As Integer = fs.Position
fs.Seek(tblDir.uOffset + ttRecord.uStringOffset + ttNTHeader.uStorageOffset, SeekOrigin.Begin)
Dim buf(ttRecord.uStringLength - 1) As Byte
fs.Read(buf, 0, ttRecord.uStringLength)
Dim enc As Encoding
If ttRecord.uEncodingID = 3 Or ttRecord.uEncodingID = 1 Then
enc = Encoding.BigEndianUnicode
Else
enc = Encoding.UTF8
End If
strRet = enc.GetString(buf)
If ttRecord.uNameID = 1 Then FontName = strRet
If ttRecord.uNameID = 2 Then FontSubFamily = strRet
fs.Seek(nPos, SeekOrigin.Begin)
Next
Return New InstalledFont(FontName, FontSubFamily, fontFilePath)
End Using
End Function
Public Structure TT_OFFSET_TABLE
Public uMajorVersion As UShort
Public uMinorVersion As UShort
Public uNumOfTables As UShort
Public uSearchRange As UShort
Public uEntrySelector As UShort
Public uRangeShift As UShort
End Structure
Public Structure TT_TABLE_DIRECTORY
Public szTag() As Byte
Public uCheckSum As UInt32
Public uOffset As UInt32
Public uLength As UInt32
Public Sub Initialize()
ReDim szTag(3)
End Sub
End Structure
Public Structure TT_NAME_TABLE_HEADER
Public uFSelector As UShort
Public uNRCount As UShort
Public uStorageOffset As UShort
End Structure
Public Structure TT_NAME_RECORD
Public uPlatformID As UShort
Public uEncodingID As UShort
Public uLanguageID As UShort
Public uNameID As UShort
Public uStringLength As UShort
Public uStringOffset As UShort
End Structure
Private Function ReadChar(ByRef fs As FileStream, ByVal characters As Integer) As UInt16
Dim s(characters) As String
Dim buf(CByte(s.Length)) As Byte
buf = ReadAndSwap(fs, buf.Length)
Return BitConverter.ToUInt16(buf, 0)
End Function
Private Function ReadByte(ByRef fs As FileStream) As UInt16
Dim buf(10) As Byte
buf = ReadAndSwap(fs, buf.Length)
Return BitConverter.ToUInt16(buf, 0)
End Function
Private Function ReadUShort(ByRef fs As FileStream) As UInt16
Dim buf(1) As Byte
buf = ReadAndSwap(fs, buf.Length)
Return BitConverter.ToUInt16(buf, 0)
End Function
Private Function ReadULong(ByRef fs As FileStream) As UInt32
Dim buf(3) As Byte
buf = ReadAndSwap(fs, buf.Length)
Return BitConverter.ToUInt32(buf, 0)
End Function
Private Function ReadAndSwap(ByRef fs As FileStream, ByVal size As Integer) As Byte()
Dim buf(size - 1) As Byte
fs.Read(buf, 0, buf.Length)
Array.Reverse(buf)
Return buf
End Function
End Module