Goal: Get the font name from the source itself: TTF file
Good specifications source found here
Updated to include parsing TTC font files
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
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
The functions provided offer an option to return the font name in the language you want, if it it exists in that language within the source file. The language requested is passed by LCID value, i.e., 1033 for English. The default is English if no LCID is passed or if the font name is not provided in the language requested.
Each version can be used to get the font names from both TrueType font files and TTC (font collection) files. The TTC files can contain 1 to several different fonts. When parsing a TTC file, the function should be called twice: once to get the 1st font name found and the total number of fonts in the file. And again, if the other font names are wanted, for each additional font, example, changing the path & file you want:
Code:
Dim sFontName As String, sFile As String, Index As Long, f As Long
sFile = "c:\windows\fonts\cambria.ttc"
sFontName = pvParseFontNameFromFile(sFile, Index)
Debug.Print sFile
Debug.Print vbTab; "Font: "; sFontName; " Nr Fonts: "; Index
For Index = 1 To Index - 1
sFontName = pvParseFontNameFromFile(sFile, Index)
If Index = 0 Then Exit For
Debug.Print vbTab; "Additional Font: "; sFontName
Next
Last edited by LaVolpe; May 23rd, 2017 at 05:55 PM.
Reason: changed file routine to request read access only
I know someone will mention this, so I'll respond in advance... Why are you not using the table count provided within the TTF format?
The TTF format has a 12-byte header. In that header, it identifies how many tables exist. It also provides some information to enable you to do a binary search to quickly locate a table vs. a sequential search.
You can't trust that header. I've found at least one font that Microsoft happily installed. Its structure said only two tables existed. There is a minimum of 9 required tables. So if the table count was wrong, so was that other info pertaining to binary searches. In that specific example, the 18th table was the one I was looking for. It existed (is a required table), but the table count was entered incorrectly. Probably could've found more, but I chose to write the routines to skip past that header & begin a sequential search; validating as I went along.
Edited: One requirement I refused to be lenient on... Per specifications, each table must be sorted, by name, in ascending order. FYI: Sorted data is a prerequisite for binary searches. So, if that rule is not enforced by the TTF creator, the above routines would abort if the 'name' table came after some other table name higher in the order.
Update: The header must be trusted else the font should be considered invalid or corrupted. After much more research and testing, I found that the fonts in question were actually TTC font files, containing multiple fonts and another table prepended to the file. I have since rewrote the code to address this newer format and some of the following posts touch on that.
Last edited by LaVolpe; May 23rd, 2017 at 06:06 PM.
Insomnia is just a byproduct of, "It can't be done"
And just because someone may want an implementation that uses the API ReadFile, here's a routine I'm actually using. The code below is parsing TTF font name from data contained within another file format. Therefore the offset to where the TTF information exists is dynamic.
A few variables are class-level, so I'll explain them here, instead of commenting the code for that purpose:
m_Source is the file handle retrieved by CreateFile
m_SourceOffset is where in the source, the TTF begins, zero-bound offset from start of source file
m_SourceLen is the size of the TTF file
So if using on the TTF file itself: m_SourceOffset = 0 & m_SourceLen = actual file size
Code:
Private Function pvParseFont(FontIndex As Long, ByVal LanguageID As Long) As String
' note: multi-byte values are stored in big endian (reverse order from Microsoft)
Dim lngValue As Long, lRead As Long
Dim tCount As Long, lValue As Long
Dim lSize As Long, sName As String
Dim lMax As Long, nOffset As Long
Dim fIndex As Long, fCount As Long
Dim lBase As Long, iLangID As Integer
Dim UB As Long, LB As Long ' binary search variables
Const fTAG As Long = 1851878757 ' "name" (reversed) converted to 4 bytes, case-sensitive
Const ttcTag As Long = 1717793908 ' "ttcf" (reversed) converted to 4 bytes, case-sensitive
If FontIndex < 0& Then FontIndex = 0&
fIndex = FontIndex: FontIndex = 0& ' initalize Index to indicate failure
If LanguageID = 0& Then
LanguageID = &H904& ' set to 1033 (reversed bytes)
Else ' swap bytes for loop usage below
LanguageID = ((LanguageID And &HFF) * &H100& Or (LanguageID And &HFFFF&) \ &H100&)
End If
lngValue = pvSetResourcePosition(False)
If lngValue = ttcTag Then ' multi-font format
SetFilePointer m_Source, m_SourceOffset + 8&, 0&, FILE_BEGIN ' skip major/minor version info
ReadFile m_Source, lngValue, 4&, lRead
fCount = pvReverseLong(lngValue)
If fCount < 1& Then GoTo EH ' sanity checks
If fIndex >= fCount Then GoTo EH
If fCount * 4& + 12& > m_SourceLen Then GoTo EH
SetFilePointer m_Source, fIndex * 4&, 0&, FILE_CURRENT
ReadFile m_Source, lngValue, 4&, lRead: lBase = pvReverseLong(lngValue) ' set base where we start getting font table data
SetFilePointer m_Source, m_SourceOffset + lBase + 4&, 0&, FILE_BEGIN
ElseIf FontIndex > 0& Then
GoTo EH ' not multi-font file, return failure
End If
ReadFile m_Source, lngValue, 2&, lRead ' number of tables
tCount = (lngValue And &HFF) * &H100& Or ((lngValue And &HFF00&) \ &H100&)
If tCount < 1& Then GoTo EH
If tCount * 16& + 12& > m_SourceLen Then GoTo EH
LB = 1&: UB = tCount ' begin binary search
Do Until LB > UB
nOffset = LB + ((UB - LB) \ 2&) ' locate table entry position
SetFilePointer m_Source, m_SourceOffset + lBase + (nOffset - 1&) * 16& + 12&, 0&, FILE_BEGIN
ReadFile m_Source, lngValue, 4&, lRead
lngValue = pvReverseLong(lngValue)
If lngValue = fTAG Then ' found it, exit loop
Exit Do
ElseIf lngValue > fTAG Then ' higher in sort order
UB = nOffset - 1&
Else ' lower in sort order
LB = nOffset + 1&
End If
Loop
If LB > UB Then GoTo EH ' "name" table not found
nOffset = lBase + (nOffset - 1&) * 16& + 12& ' include 12 bytes for the 'name' table
If nOffset + 16& > m_SourceLen Then GoTo EH
' note: lBase no longer needed; all other offsets are relative to start of file, not ttc offsets
' validate the target table
SetFilePointer m_Source, 4&, 0&, FILE_CURRENT ' skip the checksum field (name we already read) & read offset
ReadFile m_Source, lngValue, 4&, lRead: nOffset = pvReverseLong(lngValue)
If nOffset > m_SourceLen Then GoTo EH
ReadFile m_Source, lngValue, 4&, lRead: lSize = pvReverseLong(lngValue) ' read size of the "name" table
If nOffset + lSize > m_SourceLen Then GoTo EH
lMax = nOffset + lSize ' set new max (any offsets > lMax is outside "name" table)
SetFilePointer m_Source, m_SourceOffset + nOffset, 0&, FILE_BEGIN
' process the "name" table
lngValue = 0&: ReadFile m_Source, lngValue, 2&, lRead ' specs dictate the be zero
If Not lngValue = 0 Then GoTo EH ' invalid font structure?
ReadFile m_Source, lngValue, 2&, lRead ' get number of 'names' in the 'name' table
tCount = (lngValue And &HFF) * &H100& Or (lngValue And &HFF00&) \ &H100&
If (tCount * 12&) + nOffset > lMax Then GoTo EH
ReadFile m_Source, lngValue, 2&, lRead ' get offset to the strings from last cached offset
' note: this should = NrNames * 12 + 6 byte "name" table header. But we won't enforce it
nOffset = nOffset + ((lngValue And &HFF) * &H100& Or (lngValue And &HFF00&) \ &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 wanted will be 3 (Microsoft encoding)
' 3rd set of 2-bytes will be the language ID (LCID)
' 4th set of 2-bytes wanted will be 4 (Full name of the font)
ReadFile m_Source, lngValue, 4&, lRead ' reading 4 instead of two to prevent additional seek
If (lngValue And &HFFFF&) = &H300& Then
ReadFile m_Source, iLangID, 2&, lRead: lngValue = 6& ' get LangID & track number of bytes remaining in table
If iLangID = &H904 Or iLangID = LanguageID Then
ReadFile m_Source, lValue, 2&, lRead: lngValue = 4& ' get NameID (4) & track number bytes remaining in table
If (lValue And &HFFFF&) = &H400 Then
' found what we're looking for
ReadFile m_Source, lSize, 2&, lRead ' get the size of the string
lSize = (lSize And &HFF) * &H100& Or (lSize And &HFFFF&) \ &H100&
ReadFile m_Source, lValue, 4&, lRead ' get its additional offset
' microsoft-encoding has a 1-byte prefix (not positive how it works; think related to font subfamilies)
nOffset = nOffset + ((lValue And &HFF) * &H100& Or (lValue And &HFF00&) \ &H100&) + 1&
If nOffset + lSize > lMax Then GoTo EH
SetFilePointer m_Source, m_SourceOffset + nOffset, 0&, FILE_BEGIN
' size our string & seek to the beginning of the string
sName = String$(lSize \ 2, vbNullChar)
ReadFile m_Source, ByVal StrPtr(sName), lSize, lRead
If iLangID = LanguageID Then Exit For
End If
End If
SetFilePointer m_Source, lngValue, 0&, FILE_CURRENT ' skip to next string table
Else
SetFilePointer m_Source, 8&, 0&, FILE_CURRENT ' skip to next string table
End If
Next
If Not sName = vbNullString Then ' else didn't find font name
pvParseFont = sName
If fCount > 0& Then
If fIndex = 0& Then FontIndex = fCount Else FontIndex = fIndex
Else
FontIndex = fIndex + 1&
End If
End If
EH:
End Function
And here are the API declarations I used, ReadFile is tweaked on its last parameter. The pvReverseLong function is provided in post #1 above.
Code:
Public Declare Function SetFilePointer Lib "kernel32.dll" (ByVal hFile As Long, ByVal lDistanceToMove As Long, ByRef lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Public Declare Function ReadFile Lib "kernel32.dll" (ByVal hFile As Long, ByRef lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, ByRef lpNumberOfBytesRead As Long, Optional ByVal lpOverlapped As Long) As Long
Public Const FILE_BEGIN As Long = 0
Public Const FILE_CURRENT As Long = 1
Last edited by LaVolpe; May 23rd, 2017 at 05:56 PM.
Reason: included API decs
Insomnia is just a byproduct of, "It can't be done"
Just a little FYI. Yep, being too lenient on the number of tables rule is not a good thing likely. Though I can parse every valid font file I've tested, no need to take chances if not needed. The fonts I found that had the incorrect table count were indeed a more advanced font format. I was misinterpreting it as a standard TTF file/table, it is what's called a TTCF table (collection of TTF tables). Back to the grind so I can properly parse these files with more confidence & less chance for errors...
Edited: A follow-up and will post back another day on this topic. The fonts in question are indeed multiple fonts contained in single file. For example, a directory listing for "cambria*.tt*" in my fonts folder will return 4 font files: 3 TTF, and 1 TTC. The 3 TTF fonts are a subfamily (bold, italic & bold-italic) of the Cambria family. The TTC file contained two fonts: Cambria & Cambria Math. Both those are listed individually if choosing a font. Personally, just need to rethink presentation since I didn't expect multiple fonts in a single file (haven't kept up with the times I guess).
In short, the code on this page is still applicable, but for TTF fonts only, not TTC fonts which would need to be addressed a bit differently
Last edited by LaVolpe; May 22nd, 2017 at 05:00 PM.
Insomnia is just a byproduct of, "It can't be done"
Super simple example... Get the pvParseFontNameFromFile & pvReverseLong routines from post #1
Code:
Dim sFile As String, sPath As String, sFontName As String
sPath = "c:\windows\fonts\"
sFile = Dir$(sPath & "*.ttf")
Do Until sFile = ""
If Not (sFile = ".." Or sFile = ".") Then
Debug.Print sFile; " font: "; pvParseFontNameFromFile(sPath & sFile)
End If
sFile = Dir$()
Loop
Call Dir$("")
Insomnia is just a byproduct of, "It can't be done"
FYI for any interested... Updated functions to include parsing font names from both TTF (single font file) and TTC (multi-font file). Combined sample code too large for a single post, so I just added it to a text file and uploaded that into post #1 above.
The updated code does enforce the table count entries and takes advantage of that by using binary search to reduce number of file reads.
Insomnia is just a byproduct of, "It can't be done"
Re: CommonControls (Replacement of the MS common controls)
First of all, LaVolpe, thanks to you and a few more like you (supremely brilliant) in this forum. You all make life sooo much easier for me (and many others, I am sure). God bless you all! Its a phenomenal service to the society. I feel and say this from the bottom of my heart.
Well, a few days ago, I saw this thread and implemented both the 'font parsing' functions in your text file. They work like a charm (both on file and data), needless to say. Amazing stuff. Thanks a TON. But, I would wish to know whether I need to do anything special to list all the fonts from a "variable" font (for e.g. Bahnschrift.ttf). I tried a few things. I copied Bahnschrift.ttf to another normal (non-system) folder and renamed it's extension as ".ttc" or renamed the file itself to "aaa.ttc" and tried to see whether it will list all the 15 font styles this font possesses. But, I could not succeed. So, kindly let me know how to do it, if possible. If not possible with the current code, kindly let me know whether it will be possible for you to enhance your code to cover "variable" fonts too.
Secondly, some of the styles of 'Bahnschrift' have names greater than 32 in length. For e.g. "Bahnschrift SemiBold SemiCondensed". So, when I use "EnumFontFamiliesEX" to list all font families, I do not get the full name for this font. How to get the full name? Perhaps the only way is to get it from the ".ttf" file itself, as you have done? Or, is there any API way? Actually, few days back, during my search in the net, I did notice some structure having LF.lfFullFacename or something similar to that. I forgot to bookmark that page. When I search now, I am not getting it. If I remember right, some deprecated API function was using that structure.
Thirdly, given a font name (for e.g. "Arial Narrow"), how to pinpoint (programmatically, I mean) that it's family is 'Arial' only? Actually, if I view the "Fonts" folder in my Windows 10 system, Windows explorer lists only the list of unique family names (whose count is 343 in my system) and has a separate column for styles. For eg. for 'Arial', there is only one row. 'Narrow', 'Black', etc. are listed in the Styles column. Similarly, for 'Bahnschrift', there is only one row. All its 15 styles are listed one after the other (comma separated) in a lengthy string under the 'Styles' column. And, 'Arial Unicode MS' is a separate family in itself, as one can expect it to be.
I'm not sure about how to actually retrieve what font family a given font resides in, but if you use CreateFont()
or CreateFontIndirect() and only specify the font's name, you may be able to use the API GetObject() on that font handle again with a LOGFONT struct and then look at the lf.lfPitchAndFamily member. The system should have
changed it to reflect what family the given font name is a part of and what pitch it has. This is a bit roundabout though, so there could be an easier way I'm just not seeing (I'm prone to doing things the hard way without much thought, and easily miss the obvious ). I have no clue on how to find out where the font resides though.
The lf.lfPitchAndFamily is a byte field. And, from https://docs.microsoft.com/en-us/dot...studiosdk-2019, I get to see that it does not contain any font family name information, in the way I want. Or, did I miss something?
Programmatically, what i tried (please note that my knowledge of VB6 is very fundamental) from my end was:
I called EnumFontFamilesEx after setting LF.lfCharset to 1 (DEFAULT_CHARSET) and without setting lfFacename. The callback function returned at least one font for each family, the total count being 392 fonts (in my system). But then, Arial, Arial Black, Arial Narrow - all were listed as unique individual fonts (for charset 0 [ANSI_CHARSET]. Similarly, for Bahnschrift, it returned Bahnschrift, Bahnschrift Condensed, Bahnschrift Light, Bahnschrift Light Condensed, Bahnschrift Light SemiCondensed, Bahnschrift SemiBold, Bahnschrift SemiBold Condensed, Bahnschrift SemiBold SemiCondensed, Bahnschrift SemiCondensed, Bahnschrift SemiLight, Bahnschrift SemiLight Condensed, Bahnschrift SemiLight SemiCondensed. Likewise, for other fonts. Please note that only 12 fonts were listed for Bahnschrift.
I called EnumFontFamilesEx again - on each one of the above list of individual fonts. The callback function returned "Bold, Italic, Bold Italic" styles (as numbers - 700, 255, etc. for lfWeight and lfItalic fields), if present, for each of those fonts. The accumulation of this list went to 557 font styles (in my system) which I compared, font for font, with the list given by a quality font manager like MainType and the count perfectly matched. Please note that for Bahnschrift, Bold style was returned for Bahnschrift, Bahnschrift SemiCondensed and Bahnschrift Condensed. That meant that 3 more styles have to be added to the earlier 12 and that made it to 15 styles for Bahnschrift.
The thing now is:
How to get an exact list like what is shown in the 'Fonts' folder of my Windows 10 system, where only 343 families are listed - with the styles for each one of these font family listed separately. I am curious to know whether such an exact list can be generated and if so how. Further, a software like "MainType" displays a lot of extra information (description, manufacturer, designer, etc.) for any font. Are all these extra info have to be fetched from the Font's various internal TABLEs only OR some/all of them are present in the registry itself (though may be in various different branches).
How to know (programmatically) where to place the word 'Bold' while forming the extra font style names for fonts like Bahnschrift? I mean, logically I would like to place the 'Bold' at the end of each font name. But then, for Bahnschrift SemiCondensed and Bahnschrift Condensed, the additional 'Bold' styled font names are "Bahnschrift Bold SemiCondensed" and "Bahnschrift Bold Condensed" and NOT "Bahnschrift SemiCondensed Bold" and "Bahnschrift Condensed Bold".
Well, that's all are the queries from me, as of now. In case any of my questions above look childish, kindly bear with me. Kindly point me to the right resources.
Thanks a TON once again to LaVolpe and all such benevolent members of this group (Krool, Dilettante, ...) who are super-brilliant and at the same time have the heart to share their priceless codes for the benefit of all of this society.
I think you were on the right track using EnumFontFamiliesEx. For that font in question, I got 12 entries also. However, all the fonts are in the same ttf file. My parser in post #1 only looks for the font name. I can take another look at it and see if I can extract the "sub-font" names also. But no promises. When I opened the font in notepad++, I couldn't find those other font names, just the Bahnschrift Regular. So, Microsoft may very well take the font characteristics and apply words like Bold, SemiBold, Light SemiLight, Italic, etc based on font Weight, Italic & other properties returned in the LogFont structure.
btw: sample code -- rough, just for testing
' in a module
Code:
Public Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(1 To 32) As Byte
End Type
Private Type ENUMLOGFONTA
lf As LOGFONT
fullName(1 To 64) As Byte
Style(1 To 32) As Byte
End Type
Private Type NEWTEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
ntmFlags As Long
ntmSizeEM As Long
ntmCellHeight As Long
ntmAveWidth As Long
End Type
Public Declare Function EnumFontFamiliesEx Lib "gdi32.dll" Alias "EnumFontFamiliesExA" (ByVal hDC As Long, ByRef lpLogFont As LOGFONT, ByVal lpEnumFontProc As Long, ByVal lParam As Long, ByVal dw As Long) As Long
Public Function EnumFontFamProc(elf As ENUMLOGFONTA, tm As NEWTEXTMETRIC, ByVal fntType As Long, ByVal lParam As Long) As Long
Dim s As String
s = StrConv(elf.fullName(), vbUnicode)
Debug.Print Left$(s, InStr(s, vbNullChar) - 1)
EnumFontFamProc = 1
End Function
in your test form somewhere
Code:
Dim lf As LOGFONT
EnumFontFamiliesEx Me.hDC, lf, AddressOf EnumFontFamProc, 0, 0
Just to note, the font name can also be found in the Title property for non-installed font files (PKEY_Title/System.Title). Then of course installed fonts will have all the System.Font.* properties readily available:
To your 'Second' point, the property system method of reading these has no limit I can tell, but the longest name I could find was 'Lucida Sans Typewriter Bold Oblique' at 35 chars.
Thirdly, given a font name (for e.g. "Arial Narrow"), how to pinpoint (programmatically, I mean) that it's family is 'Arial' only? Actually, if I view the "Fonts" folder in my Windows 10 system, Windows explorer lists only the list of unique family names (whose count is 343 in my system) and has a separate column for styles. For eg. for 'Arial', there is only one row. 'Narrow', 'Black', etc. are listed in the Styles column. Similarly, for 'Bahnschrift', there is only one row. All its 15 styles are listed one after the other (comma separated) in a lengthy string under the 'Styles' column. And, 'Arial Unicode MS' is a separate family in itself, as one can expect it to be.
If you want to look at one font like this in the font folder, you can basically treat it as a folder and just do a normal enumeration of its contents:
Since they're independent shell objects, you could create an object directly from the item and read its 'Family' (System.Fonts.FamilyName), which is just 'Arial' for all the Arial styles shown above
The best way to create a display with an exact list like the Fonts folder, is to just display the Fonts folder
(If interested, you could turn the control above into a dedicated font viewer, but setting the Fonts folder as the root, and disabling navigation out of the root, you could even put a tree next to it also with the Fonts folder as root, and have a list of the expandable fonts to browse, or just switch back to the root with all fonts)
Last edited by fafalone; May 17th, 2020 at 06:59 AM.
Just took a look at 'BahnSchrift' on Win10 - and can find that Fonts "Sub-Family-entries"
from the "NameID:" 258 onwards (looking into the TTF-File directly via a Parser-Class).
The usage of these "higher NameIDs" indicates, that this font is an OpenType(derived) Font,
which is described (with its extended NameID-set from 256 onwards) e.g. here: https://docs.microsoft.com/en-us/typ...type/spec/fvar
Class cTTFInfo
Code:
Option Explicit 'RC5-based TTF-FontFile-Parsing (Olaf Schmidt, December 2017)
Private Type tFileHdr
B(0 To 11) As Byte
End Type
Private Type tTableDir
B(0 To 15) As Byte
End Type
Private Type tNameRec
B(0 To 11) As Byte
Data() As Byte
End Type
Public Enum enmNameRecordIDs
nrCopyrightNotice = 0 'Copyright notice.
nrFontFamily = 1 'Font Family name
nrFontSubfamily = 2 'Font Subfamily name; for purposes of definition, this is assumed to address style (italic, oblique) and weight (light, bold, black, etc.) only. A font with no particular differences in weight or style (e.g. medium weight, not italic and fsSelection bit 6 set) should have the string “Regular” stored in this position.
nrUniqueIdentifier = 3 'Unique font identifier
nrFullFontname = 4 'Full font name; this should simply be a combination of strings 1 and 2. Exception: if string 2 is “Regular,” then use only string 1. This is the font name that Windows will expose to users.
nrVersionString = 5 'Version string. In n.nn format.
nrPostscriptName = 6 'Postscript name for the font.
nrTrademark = 7 'Trademark; this is used to save any trademark notice/information for this font. Such information should be based on legal advice. This is distinctly separate from the copyright.
nrMax = 7
End Enum
Public AvailableLCIDs As cCollection
Private FH As tFileHdr, TD() As tTableDir, NR() As tNameRec, mNameIdx As Long, i As Long
Public Sub InitFrom(FileName As String)
mNameIdx = -1
With New_c.FSO.OpenFileStream(FileName, STRM_READ Or STRM_SHARE_DENY_NONE)
.ReadToByteArr FH.B, UBound(FH.B) + 1
If StrComp(New_c.FSO.GetFileExtension(FileName), "ttf", 1) <> 0 Or Version <> "1.0" Or FH.B(5) = 0 Then Err.Raise vbObjectError, , "Unsupported FontFile-Format"
ReDim TD(0 To TablesCount - 1)
For i = 0 To UBound(TD)
.ReadToByteArr TD(i).B, UBound(TD(i).B) + 1
If StrComp(TableName(i), "name", 1) = 0 Then mNameIdx = i
Next
If mNameIdx = -1 Then Err.Raise vbObjectError, , "Couldn't find Name-Table"
.SetPosition TableOffs(mNameIdx)
Dim NH() As Byte, StorageOffs As Long
.ReadToByteArr NH, 6
Set AvailableLCIDs = New_c.JSONObject
ReDim NR(0 To NH(3) + 256& * NH(2) - 1)
For i = 0 To UBound(NR): .ReadToByteArr NR(i).B, UBound(NR(i).B) + 1: Next
StorageOffs = .GetPosition
For i = 0 To UBound(NR)
.SetPosition StorageOffs + NR(i).B(11) + 256& * NR(i).B(10)
If NR(i).B(9) + 256& * NR(i).B(8) <= 0 Then NR(i).Data = "" Else .ReadToByteArr NR(i).Data, NR(i).B(9) + 256& * NR(i).B(8)
If AvailableLCIDs.Exists(CStr(LanguageID(i))) Then
AvailableLCIDs.Prop(CStr(LanguageID(i))) = AvailableLCIDs.Prop(CStr(LanguageID(i))) + 1
Else
AvailableLCIDs.Prop(CStr(LanguageID(i))) = 1
End If
Next
End With
End Sub
Public Property Get Version() As String
Version = FH.B(1) & "." & FH.B(3)
End Property
Public Property Get TablesCount() As Long
TablesCount = FH.B(5) + 256& * FH.B(4)
End Property
Public Property Get TableName(ByVal Idx As Long) As String
TableName = Chr$(TD(Idx).B(0)) & Chr$(TD(Idx).B(1)) & Chr$(TD(Idx).B(2)) & Chr$(TD(Idx).B(3))
End Property
Public Property Get TableOffs(ByVal Idx As Long) As Long
TableOffs = TD(Idx).B(11) + 256& * TD(Idx).B(10) + 65536 * TD(Idx).B(9) + 16777216 * TD(Idx).B(8)
End Property
Public Property Get TableLen(ByVal Idx As Long) As Long
TableLen = TD(Idx).B(15) + 256& * TD(Idx).B(14) + 65536 * TD(Idx).B(13) + 16777216 * TD(Idx).B(12)
End Property
Public Property Get NameRecordsCount() As Long
NameRecordsCount = UBound(NR) + 1
End Property
Public Property Get PlatformID(ByVal Idx As Long) As Long
PlatformID = NR(Idx).B(1) + 256& * NR(Idx).B(0)
End Property
Public Property Get EncodingID(ByVal Idx As Long) As Long
EncodingID = NR(Idx).B(3) + 256& * NR(Idx).B(2)
End Property
Public Property Get LanguageID(ByVal Idx As Long) As Long
LanguageID = NR(Idx).B(5) + 256& * NR(Idx).B(4)
End Property
Public Property Get NameID(ByVal Idx As Long) As Long
NameID = NR(Idx).B(7) + 256& * NR(Idx).B(6)
End Property
Public Property Get NameData(ByVal Idx As Long) As Byte()
NameData = NR(Idx).Data
End Property
Public Property Get NameText(ByVal Idx As Long, Optional ByVal LCID As Long) As String
If UBound(NR(Idx).Data) + 1 = 0 Then Exit Property
If EncodingID(Idx) <> 0 Or PlatformID(Idx) = 3 Then
Dim Tmp As Byte, B() As Byte: B = NR(Idx).Data
For i = 0 To UBound(B) - 1 Step 2: Tmp = B(i): B(i) = B(i + 1): B(i + 1) = Tmp: Next 'ByteSwap from BigEndian
NameText = B
Else
NameText = StrConv(NR(Idx).Data, vbUnicode, IIf(PlatformID(Idx) = 1, 1033, LCID))
End If
End Property
Public Function FindNRIndex(ByVal ByNameID As enmNameRecordIDs, Optional ByVal LCID As Long = 1033) As Long
FindNRIndex = -1 'preset with the "not-found"-value
1 For i = 0 To UBound(NR) 'try to find for the specified LCID first
If NameID(i) = ByNameID And LanguageID(i) = LCID Then FindNRIndex = i: Exit Function
Next
If LCID <> 1033 Then LCID = 1033: GoTo 1 'one more try with the default-LCID (because it was not given)
For i = 0 To UBound(NR) 'if still not found, fall back to a search without LCID-Matching (first one wins)
If NameID(i) = ByNameID Then FindNRIndex = i: Exit Function
Next
End Function
Public Function FindNRText(ByVal ByNameID As enmNameRecordIDs, Optional ByVal LCID As Long = 1033) As String
Dim Idx As Long
Idx = FindNRIndex(ByNameID, LCID)
If Idx <> -1 Then FindNRText = NameText(Idx, LCID)
End Function
Form-TestCode (with a Filter-Setting for "Bahn*.ttf")
Code:
Option Explicit
Private DL As cDirList, TTFInfo As New cTTFInfo
Private WithEvents lstFontFiles As VB.ListBox 'we create this Control dynamically below
Private Sub Form_Load()
Set lstFontFiles = Controls.Add("VB.ListBox", "lstFontFiles")
lstFontFiles.Visible = True: lstFontFiles.Move 0, 0, 3000, 5000
FillFontFilesList "Bahn*.ttf"
End Sub
Private Sub FillFontFilesList(Optional Filter As String = "*.ttf")
Set DL = New_c.FSO.GetDirList(New_c.FSO.GetSpecialFolder(CSIDL_FONTS), , Filter)
lstFontFiles.Clear
Dim i As Long
For i = 0 To DL.FilesCount - 1
lstFontFiles.AddItem UCase$(DL.FileName(i))
Next
End Sub
Private Sub lstFontFiles_Click()
If lstFontFiles.ListIndex < 0 Then Exit Sub
Dim FontFile As String
FontFile = DL.Path & DL.FileName(lstFontFiles.ListIndex)
With TTFInfo
.InitFrom FontFile
'an OpenType(derived)-Font will include the tables 'fvar' and 'gvar' for example
'see https://docs.microsoft.com/en-us/typography/opentype/spec/fvar
Debug.Print "Tables:"
Dim i As Long
For i = 0 To .TablesCount - 1
Debug.Print i, .TableName(i), .TableOffs(i), .TableLen(i)
Next
Debug.Print "Name-Records:"
For i = 0 To .NameRecordsCount - 1
'.NameIDs >= 256 indicate "OpenType-stuff" (mostly starting with 'Weight','Width', followed by the subfamily-names
Debug.Print i, .NameID(i), .EncodingID(i), .LanguageID(i), .NameText(i)
Next
' Debug.Print vbLf; Replace(TTFInfo.AvailableLCIDs.SerializeToJSONString, ",", "," & vbCrLf)
End With
End Sub
Maybe that helps, in case the MS-APIs don't hand out the full infos for that Font.
I think you were on the right track using EnumFontFamiliesEx. For that font in question, I got 12 entries also. ... .. .
Yesss, that was the structure I missed to bookmark. Thanks a lot for the link.
And, thanks a ton for the example too which shows how to use this structure. So, its quite easy now to get the full font name (names which are greater than 31 in length too). Thanks again.
I noticed one thing though:
Setting a form's font name, a flexgrid's cell's font name, etc., to a font name whose length is greater than 31 is not possible. I need to use the first 31 characters only. Wonder whether this is a limitation for Vb6 alone. May be not because LOGFONT structure itself has lfFaceName length as 32 only. This is not an issue for me, as of now. But, just thought of knowing.
Regarding those 3 extra font styles for Bahnschrift and how to exactly know (programmatically) where to place the 'Bold' in their names, I shall await for your enhanced code (if you get the time to do the same).
Meanwhile, I will also look into the solutions from fafalone and Schmidt, which look quite awesome and exciting.
Just took a look at 'BahnSchrift' on Win10 - and can find that Fonts "Sub-Family-entries"
from the "NameID:" 258 onwards (looking into the TTF-File directly via a Parser-Class). ... .. . Olaf
I am quite excited to see your solution. But, just help me out on one thing. It gives error "User-defined type not defined" for "DL As cDirList". I did add reference to "Microsoft Scripting Runtime"(scrrun.dll) but the error persists. Anything else I have to do, kindly guide me. I did try searching in the net for CDirList structure (thinking that perhaps I need to define it) but could not get any.
... just help me out on one thing.
It gives error "User-defined type not defined" for "DL As cDirList"...
At the top of the Parser-Class (cTTFInfo) I made a comment (though admittedly short) , that the Code is "RC5-based"...
RC5 is a shortform for vbRichClient5.dll, which comes in a (free downloadable) package on vbRichClient.com.
(containing a lot of Helper-Classes, to make our "daily coding-efforts" shorter and easier).
After downloading the BaseDll-zip-package, unpacking into a Folder - and registering vbRichClient5.dll,
you will need to check-in a Project-Reference to "vbRichClient5" into your Project,
before the two CodeSnippets (one in a Class, named cTTFInfo, the other in an empty Form) - will work.
Piggybacking on Schmidt's stuff, I was just curious to see what is reported in the TTF from my parser (which I had to tweak to allow the following to come through).
The 1st two numbers are the name-field block ordinal and NameID, followed by the string value for that ID. See the link provided by Schmidt and jump down to the NameID section for details on what those mean. As Schmidt indicated, IDs > 255 are "are reserved for font-specific names such as those referenced by a font’s layout features"
fyi... name-field blocks 0-13 had unicode info, so when run in IDE, lots of ??? chars - not worth posting.
Just to note, the font name can also be found in the Title property for non-installed font files (PKEY_Title/System.Title). Then of course installed fonts will have all the System.Font.* properties readily available: ... .. .
Since they're independent shell objects, you could create an object directly from the item and read its 'Family' (System.Fonts.FamilyName), which is just 'Arial' for all the Arial styles shown above
The best way to create a display with an exact list like the Fonts folder, is to just display the Fonts folder ... .. .
But, I need time to test out your quite novel solution(s). Kindly bear with me.
Please Note:
I tried to post this reply several times yesterday itself (and have tried several times today too) but met with the same error "Sadly, you’ve reached a page that can’t be displayed. We’ve logged this action, ... .. .". Once this error starts appearing, it persists. So, in future, if there are delays in my ack./replies, kindly understand that this error could be one of the reasons for the delay. I pray this reply goes through.
Piggybacking on Schmidt's stuff, I was just curious to see what is reported in the TTF from my parser (which I had to tweak to allow the following to come through). ... .. .
As far as I can see, your tweak almost gave the required result. Thats great. Out of the 15 font styles of Bahnschrift, the name-field blocks from '30 to 42' (in your parser's report) list 13 of them. The starred(*) ones are the 2 font styles missing.
Out of the above 15, in the API way (EnumerateFamiliesEx), 12 are listed in the first general run itself. To get the additional extra 3 styles (Bahnschrift Bold, Bahnschrift Bold SemiCondensed and Bahnschrift Bold Condensed), I ran EnumerateFamiliesEx again (with lfFaceName filled), for each of the 12 styles obtained in the first general run. Three of the above styles alone, viz. Bahnschrift, Bahnschrift SemiCondensed and Bahnschrift Condensed returned an extra style (Bold). But, as stated already, the Bold style is obtained as a number (700) only. So, programmatically, there is no way for me to know where to place the 'Bold' word for 'Bahnschrift SemiCondensed' and 'Bahnschrift Condensed'. Your report above (after your tweaking) now tells where to place the 'Bold' for 'Bahnschrift SemiCondensed'.
By the by, using fafalone's absolutely amazing ucShellBrowse control, I was able to get the desired 15 font styles for 'BahnSchrift'. The advantage is that not only for 'BahnSchrift', but for Arial (and all such other fonts which have multiple font styles) too, I can get the desired result (in the same way as reported by Microsoft in the 'Fonts' folder). So, as of now, for me, that's the only way by which I can get the desired information for all fonts (in the same manner as reported by Microsoft). Thanks a TON for all of your efforts and help.
At the top of the Parser-Class (cTTFInfo) I made a comment (though admittedly short) , that the Code is "RC5-based"... ... .. . Olaf
Thanks for your clear-cut instructions. I was easily able to run your code thereafter. But, it reported "Bahnschrift" alone as the output. Did I miss something?
Since Bahnschrift.ttf is a variable TTF font (as mentioned in my very first reply in this thread and which I learnt from the net - https://en.wikipedia.org/wiki/Variable_fonts, etc. - to be having further more data than a regular TTF font), may be I have to explore your code and try to modify it on my own, availing the valuable resources supplied by you and the valuable suggestions from LaVolpe on the same??
Note: I do have come across your Wonderful "vbRichClient5" work earlier but somehow could not get time to explore it.
Thanks for your clear-cut instructions. I was easily able to run your code thereafter.
But, it reported "Bahnschrift" alone as the output. Did I miss something?
Yes, probably the clicking onto the sole Filename-entry in the normal VB-ListBox
(a single FileName-entry was added there only, because we've passed an appropriate File-Filter-String to the DirList-Object beforehand...)
If you'd pass a normal Filter-String instead, as e.g. "*.ttf" ... then the List would be filled with all ttf-Files in the Windows-FontFolder.
So a MouseClick on any of the listed FontFiles, will print the Detail-Infos for that File into the Immediate-Window.
For comparison - here's my Debug-Output, which was generated by clicking on BahnSchrift.ttf:
(and it includes all 15 Sub-Styles at the end - I've marked them Bold in the text-section below):
Yes, probably the clicking onto the sole Filename-entry in the normal VB-ListBox
(a single FileName-entry was added there only, because we've passed an appropriate File-Filter-String to the DirList-Object beforehand...)
If you'd pass a normal Filter-String instead, as e.g. "*.ttf" ... then the List would be filled with all ttf-Files in the Windows-FontFolder.
So a MouseClick on any of the listed FontFiles, will print the Detail-Infos for that File into the Immediate-Window.
For comparison - here's my Debug-Output, which was generated by clicking on BahnSchrift.ttf:
(and it includes all 15 Sub-Styles at the end - I've marked them Bold in the text-section below):
... .. .
HTH
Olaf
Oh yes... Wow! Brilliant!
How did I miss it out? It is so... obvious. My sincere apologies for missing out on the obvious.
Thanks a TON for your straightforward solution.
@softv. If you have additional questions regarding RC5 or its usage, take it to another part of the forum. I don't want this thread to turn into a topic on RC5.
If Schmidt wants to submit an RC5 thread with more details and examples, that's fine and he can link it from this thread.
Insomnia is just a byproduct of, "It can't be done"
Piggybacking on Schmidt's stuff, I was just curious to see what is reported in the TTF from my parser (which I had to tweak to allow the following to come through). ... .. .
fyi... name-field blocks 0-13 had unicode info, so when run in IDE, lots of ??? chars - not worth posting.
My earlier kind request - that I shall await your enhanced parser code, if you get the time to do the same - still remains. So, I very much look forward to your tweaked parser code (giving out the name-field blocks for 43 and 44 too), if you have the time to finalise and upload the same here. Much thanks in advance. If at all possible for your enhanced parser code to have the Unicode info too (and any other useful non-unicode info too, whichever you deem fit) in some string array, that is welcome too since I work on Unicode stuff. Would remain greatly thankful to you.
Here is my version of a font name parser i wrote back in '07 that i submitted to PSC. Maybe you could get some ideas from it to add to yours?
Code:
Attribute VB_Name = "modFontInfo"
Option Explicit
'******************************************************************
'thanks to Philip Patrick and his c++ article on the Code Project
'http://www.codeproject.com/KB/GDI/fontnamefromfile.aspx
'VB code by Lewis Miller 12/04/07 [email protected]
'******************************************************************
'12/11/07 BugFix: Soorya has noted a problem with unicode font names. His proposed fix
' has been added. Thanks to soorya for the bug find.
'Remarks:
'Font files store all there information in motorola (or Big-Endian) format
'which is incompatible with vb, so we must use memory swapping tricks
'to retrieve the values we want to use from font files. You cannot access/read a variable
'that has been loaded from the font file unless you first swap it to intel (or Little-Endian)
'format.... doing so will cause havoc in your program :)
'api declarations
Private Declare Function ntohl Lib "ws2_32.dll" (ByVal netlong As Long) As Long
Private Declare Function ntohs Lib "ws2_32.dll" (ByVal netshort As Integer) As Integer
'font structures (taken from philips article)
Public Type OFFSET_TABLE 'len = 12
uMajorVersion As Integer
uMinorVersion As Integer
uNumOfTables As Integer
uSearchRange As Integer
uEntrySelector As Integer
uRangeShift As Integer
End Type
Public Type TABLE_DIRECTORY 'len = 16
szTag As String * 4 'table name
uCheckSum As Long 'Check sum
uOffset As Long 'Offset from beginning of file
uLength As Long 'length of the table in bytes
End Type
Public Type NAME_TABLE_HEADER 'len = 6
uFSelector As Integer 'format selector. Always 0
uNRCount As Integer 'Name Records count
uStorageOffset As Integer 'Offset for strings storage, from start of the table
End Type
Public Type NAME_RECORD 'len = 12
uPlatformID As Integer '
uEncodingID As Integer '
uLanguageID As Integer '
uNameID As Integer '
uStringLength As Integer '
uStringOffset As Integer ' from start of storage area
End Type
'************************************************************
'Helper Functions
'***********************************************************
'convert a big-endian Long to a little-endian Long
Sub SwapLong(LongVal As Long)
LongVal = ntohl(LongVal)
End Sub
'convert a big-endian Integer (short) to a little-endian Integer (short)
Sub SwapInt(IntVal As Integer)
IntVal = ntohs(IntVal)
End Sub
'************************************************************
'retrieves the font name from a font file
'the file must be a true type font 1.0
'***********************************************************
Function GetFontName(ByVal FontPath As String) As String
Dim TblDir As TABLE_DIRECTORY 'table directory
Dim OffSetTbl As OFFSET_TABLE 'table information
Dim NameTblHdr As NAME_TABLE_HEADER 'name table info
Dim NameRecord As NAME_RECORD 'info table
Dim FileNum As Integer
Dim lPosition As Long
Dim sFontTest As String
Dim X As Long
Dim I As Long
'make sure font file exists
If Len(FontPath) = 0 Then
Exit Function
End If
If Dir$(FontPath) = vbNullString Then
Exit Function
End If
On Error GoTo GetFontName_Error
'open the file
FileNum = FreeFile
Open FontPath For Binary As FileNum
'read the first main table header
Get #FileNum, , OffSetTbl
With OffSetTbl
SwapInt .uMajorVersion
SwapInt .uMinorVersion
'check major and minor versions for 1.0
If .uMajorVersion = 1 And .uMinorVersion = 0 Then
SwapInt .uNumOfTables
If .uNumOfTables > 0 Then
For X = 0 To .uNumOfTables - 1
Get #FileNum, , TblDir
If StrComp(TblDir.szTag, "name", vbTextCompare) = 0 Then
'we have found the name table hdr, now we get the length and offset of name record
With TblDir
SwapLong .uLength
SwapLong .uOffset
If .uOffset Then
Get #FileNum, .uOffset + 1, NameTblHdr
SwapInt NameTblHdr.uNRCount
SwapInt NameTblHdr.uStorageOffset
While I < NameTblHdr.uNRCount
Get #FileNum, , NameRecord
SwapInt NameRecord.uNameID
'1 specifies font name, this could be modified to get other info
If NameRecord.uNameID = 1 Then
SwapInt NameRecord.uStringLength
SwapInt NameRecord.uStringOffset
lPosition = Loc(FileNum) 'save current file position
If NameRecord.uStringLength Then
sFontTest = Space$(NameRecord.uStringLength)
Get #FileNum, .uOffset + NameRecord.uStringOffset + NameTblHdr.uStorageOffset + 1, sFontTest
Exit For
End If
'search more
Seek #FileNum, lPosition
End If
I = I + 1
Wend
End If
End With
End If
Next X
End If
End If
End With
Close #FileNum
'note: some fonts are returned in unicode (double byte) format
' so we must remove the null characters - thanks to soorya
GetFontName = Replace$(sFontTest, vbNullChar, "")
On Error GoTo 0
Exit Function
GetFontName_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure GetFontName() of Module modFontInfo.", vbCritical
End Function
Reply With Quote
Originally Posted by xxdoc123
... .. .
