Goal: Get the font name from the source itself: TTF file
Good specifications source found here
Did not want to have to install a font to get the information. Wanted to know how to do this, so did some research & played around.
Some caveats first...
- This has not been extremely vetted. Only tested on a few hundred font files ;)
- Does not give you any other font information; parsing font files is kinda intense
- Will only return a font name if it has been included as a Microsoft format; common but not 100%
- May need some more playing, but it suits my needs & thought I'd share it
- Already found a malformatted file or two that MS allows to be installed. So, the routines below are a bit lenient also
I'm including two sample versions: 1) for files using VB file's Open; modify to use APIs for unicode paths/file names and 2) for arrays, should you have the font available that way
This function is common to both samples below
Arrays... A bit lazy, so I used CopyMemory to transfer bytes to Long
Sample call: MsgBox pvParseFontNameFromArray(theFontFilearray(), 0, UBound(theFontFilearray)+1)
Files...
Sample call: MsgBox pvParseFontNameFromFile(FontFileName)
Updated above routine to request read-only access, else routine will fail to read font name if system has font opened without write-sharing. VB's default Open statement wants write-sharing. Only sample code, so add error handling as needed -- i.e., passing an invalid file name or one that is opened exclusively & won't allow reading.
Good specifications source found here
Did not want to have to install a font to get the information. Wanted to know how to do this, so did some research & played around.
Some caveats first...
- This has not been extremely vetted. Only tested on a few hundred font files ;)
- Does not give you any other font information; parsing font files is kinda intense
- Will only return a font name if it has been included as a Microsoft format; common but not 100%
- May need some more playing, but it suits my needs & thought I'd share it
- Already found a malformatted file or two that MS allows to be installed. So, the routines below are a bit lenient also
I'm including two sample versions: 1) for files using VB file's Open; modify to use APIs for unicode paths/file names and 2) for arrays, should you have the font available that way
This function is common to both samples below
Code:
Private Function pvReverseLong(ByVal inLong As Long) As Long
' fast function to reverse a long value from big endian to little endian
' PNG files contain reversed longs, as do ID3 v3,4 tags, TTFs & more
pvReverseLong = _
(((inLong And &HFF000000) \ &H1000000) And &HFF&) Or _
((inLong And &HFF0000) \ &H100&) Or _
((inLong And &HFF00&) * &H100&) Or _
((inLong And &H7F&) * &H1000000)
If (inLong And &H80&) Then pvReverseLong = pvReverseLong Or &H80000000
End FunctionSample call: MsgBox pvParseFontNameFromArray(theFontFilearray(), 0, UBound(theFontFilearray)+1)
Code:
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal length As Long)
Private Function pvParseFontNameFromArray(fData() As Byte, ByVal offsetBegin As Long, ByVal dataLength As Long) As String
' fData() is a byte array, any LBound
' offsetBegin is where in the byte array the font file begins; not required to be @ LBound
' dataLength is total size of the font file; not required to be UBound(array)+1
' note: multi-byte values are stored in big endian (reverse order from Microsoft)
Dim lngValue As Long, tCount As Long
Dim lSize As Long, sName As String
Dim nOffset As Long, lPtr As Long
tCount = (dataLength - 12&) \ 16& - 1&
For tCount = 0& To tCount
lPtr = offsetBegin + tCount * 16& + 12&
CopyMemory lngValue, fData(lPtr), 4& ' include 12-byte header
If (lngValue And &HFF) > &H6E Then GoTo EH ' passed up the n's
If lngValue = 1701667182 Then ' each byte is a char & it spells: name
lPtr = lPtr + 8& ' skip checksum & add 4 bytes just read
CopyMemory lngValue, fData(lPtr), 4& ' get offset to table, reversed
nOffset = pvReverseLong(lngValue)
' minimum 12 bytes for the 'name' table
If nOffset + 12& > dataLength Then GoTo EH
lPtr = offsetBegin + nOffset
Exit For
End If
Next
If nOffset = 0& Then GoTo EH ' should not get here unless there is no 'name' table
lngValue = fData(lPtr) * &H100& Or fData(lPtr + 1&): lPtr = lPtr + 2&
If Not lngValue = 0& Then GoTo EH ' invalid font structure?
' get number of 'names' in the 'name' table
tCount = fData(lPtr) * &H100& Or fData(lPtr + 1&): lPtr = lPtr + 2&
' each 'names' entry is 12 bytes & we still have 2 bytes to read here
If tCount * 12& + nOffset + 2& > dataLength Then GoTo EH
' get offset to the strings from last cached offset
lngValue = fData(lPtr) * &H100& Or fData(lPtr + 1&): lPtr = lPtr + 2&
nOffset = nOffset + lngValue
If nOffset > dataLength Then GoTo EH
For tCount = 0& To tCount - 1& ' loop thru each 'names' entry
' we are specifically looking for Microsoft encoded names
' in the 12byte table...
' 1st set of 2-bytes will be 3 (Microsoft encoding)
' 4th set of 2-bytes will be 4 (Full name of the font)
lngValue = fData(lPtr) * &H100& Or fData(lPtr + 1&): lPtr = lPtr + 6&
lSize = fData(lPtr) * &H100& Or fData(lPtr + 1&): lPtr = lPtr + 2&
If (lngValue = 3&) And (lSize = 4&) Then
' found what we're looking for
' get the size of the string
lSize = fData(lPtr) * &H100& Or fData(lPtr + 1&): lPtr = lPtr + 2&
' get its additional offset
lngValue = fData(lPtr) * &H100& Or fData(lPtr + 1&)
nOffset = nOffset + lngValue + 1
If nOffset + lSize > dataLength Then GoTo EH
' size our string & seek to the beginning of the string
sName = String$(lSize \ 2, vbNullChar)
lPtr = nOffset + offsetBegin
CopyMemory ByVal StrPtr(sName), fData(lPtr), lSize
Exit For
Else
lPtr = lPtr + 4& ' skip next 4 bytes
End If
Next
pvParseFontNameFromArray = sName
EH:
End FunctionSample call: MsgBox pvParseFontNameFromFile(FontFileName)
Code:
Private Function pvParseFontNameFromFile(FileName As String) As String
' note: multi-byte values are stored in big endian (reverse order from Microsoft)
Dim lngValue As Long, intValue As Integer
Dim f As Integer, tCount As Long
Dim lSize As Long, sName As String
Dim lMax As Long, nOffset As Long
f = FreeFile
Open FileName For Binary Access Read As #f
lMax = LOF(f)
tCount = (lMax - 12&) \ 16& - 1&
For tCount = 0& To tCount
Get #f, tCount * 16& + 13&, lngValue ' 13 = 12-byte header + VB file start pos of 1
If (lngValue And &HFF) > &H6E Then GoTo EH ' passed up the n's
If lngValue = 1701667182 Then ' each byte is a char & it spells: name
Seek #f, Seek(f) + 4& ' skip checksum
Get #f, , lngValue ' get offset to table, reversed
nOffset = pvReverseLong(lngValue)
' minimum 12 bytes for the 'name' table
If nOffset + 12& > lMax Then GoTo EH
Seek #f, nOffset + 1&
Exit For
End If
Next
If nOffset = 0& Then GoTo EH ' should not get here unless there is no 'name' table
Get #f, , intValue ' specs dictate the be zero
If Not intValue = 0 Then GoTo EH ' invalid font structure?
Get #f, , intValue ' get number of 'names' in the 'name' table
tCount = (intValue And &HFF) * &H100 Or (intValue And &HFFFF&) \ &H100
' each 'names' entry is 12 bytes & we still have 2 bytes to read here
If tCount * 12& + nOffset + 2& > lMax Then GoTo EH
Get #f, , intValue ' get offset to the strings from last cached offset
nOffset = nOffset + ((intValue And &HFF) * &H100 Or (intValue And &HFFFF&) \ &H100)
If nOffset > lMax Then GoTo EH
For tCount = 0& To tCount - 1& ' loop thru each 'names' entry
' we are specifically looking for Microsoft encoded names
' in the 12byte table...
' 1st set of 2-bytes will be 3 (Microsoft encoding)
' 4th set of 2-bytes will be 4 (Full name of the font)
Get #f, , lngValue ' reading 4 instead of two to prevent seek
Get #f, , lSize ' reading 4 instead of two to prevent seek
If (lngValue And &HFFFF&) = &H300& And (lSize And &HFFFF0000) = &H4000000 Then
' found what we're looking for
Get #f, , intValue ' get the size of the string
lSize = (intValue And &HFF) * &H100 Or (intValue And &HFFFF&) \ &H100
Get #f, , intValue ' get its additional offset
nOffset = nOffset + ((intValue And &HFF) * &H100 Or (intValue And &HFFFF&) \ &H100) + 1
If nOffset + tCount > lMax Then GoTo EH
' size our string & seek to the beginning of the string
sName = String$(lSize \ 2, vbNullChar)
Seek #f, nOffset + 1&
For lSize = 1 To lSize \ 2 ' transfer content into our string
Get #f, , intValue
Mid$(sName, lSize, 1) = ChrW$(intValue)
Next
Exit For
Else
Seek #f, Seek(f) + 4& ' skip next 4 bytes
End If
Next
pvParseFontNameFromFile = sName
EH:
Close #f
End Function