好的,下面将有很多代码。主要是因为 TTF 结构和 TTF 文件的字节顺序。该代码最初不是我的,它来自一些来源,我已将其移植到 VB.NET 并更改了一些内容。看这一页对于获取字体名称的 C++ 版本。
此代码读取已安装字体的注册表(无论是在 %windir%\fonts 还是其他地方),过滤以仅获取具有 .ttf 扩展名的字体(例如 .fon 和 .ttc 被忽略),然后将这些字体文件路径传递给例行公事,GetFontDetails
,读取并获取字体名称 (uNameID #1) 和字体子系列(又名样式,uNameID #2)。如果您有兴趣获得更多房产,请访问name - 命名表在 Microsoft 的 Typography 网站上并在浏览器中搜索Name IDs。然后它将字体名称、字体子系列和字体路径踢出到控制台窗口。
Create a new VB.NET Console app and paste the below in over Module1 code and press F5.
无需再费周折:
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