Note that there are some explanatory texts on larger screens.

plurals
  1. PO
    primarykey
    data
    text
    <p>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 <a href="http://www.codeproject.com/KB/GDI/fontnamefromfile.aspx" rel="nofollow noreferrer">this page</a> for a C++ version that gets the font name.</p> <p>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, <code>GetFontDetails</code>, 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 <a href="http://www.microsoft.com/typography/otspec/name.htm" rel="nofollow noreferrer">name - Naming Table</a> on Microsoft's Typography website and search in your browser for <em>Name IDs</em>. It then kicks out the Font Name, Font SubFamily and Font Path to the Console window.</p> <p>Create a new VB.NET Console app and paste the below in over Module1 code and press <kbd>F5</kbd>.</p> <p>Without further ado:</p> <pre><code>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) &amp; "\" &amp; 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: " &amp; f.FontName &amp; ", SubFamily: " &amp; f.FontSubFamily &amp; ", Path: " &amp; 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 &lt;&gt; 1 Or ttOffsetTable.uMinorVersion &lt;&gt; 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 &gt; 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 </code></pre>
    singulars
    1. This table or related slice is empty.
    plurals
    1. This table or related slice is empty.
    1. This table or related slice is empty.
    1. This table or related slice is empty.
    1. VO
      singulars
      1. This table or related slice is empty.
    2. VO
      singulars
      1. This table or related slice is empty.
    3. VO
      singulars
      1. This table or related slice is empty.
 

Querying!

 
Guidance

SQuiL has stopped working due to an internal error.

If you are curious you may find further information in the browser console, which is accessible through the devtools (F12).

Reload