Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0774: Fontnamen aus einer TrueTypeFont-Datei auslesen

VB 5/6-Tipp 0774: Fontnamen aus einer TrueTypeFont-Datei auslesen

 von Frank Schüler

Schwierigkeitsgrad:

Verwendete API-Aufrufe: keine

Download: Download des Beispielprojektes [4.05 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Project1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Dateiauswahlliste "lbTTF"
Option Explicit

Private Sub Form_Load()

    ' Parameter für die FileListBox
    With lbTTF
    
        .Pattern = "*.ttf"
        .Path = AddPathSlash(Environ("windir")) & "Fonts"
        .ListIndex = 0
        
    End With
    
End Sub

Private Sub lbTTF_Click()

    ' Fontname aus Datei ermitteln und anzeigen
    Me.Caption = GetTTFName(AddPathSlash(lbTTF.Path) & lbTTF.FileName)
    
End Sub

' fügt einen Backslash an den Pfad an wenn kein Backslash vorhanden ist
Private Function AddPathSlash(ByVal Path As String) As String

    If Right$(Path, 1) <> "\" Then Path = Path & "\"
    
    AddPathSlash = Path
    
End Function
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'------ Anfang Modul "modTTFName" alias modTTFName.bas ------
' Originalcode auf
' http://www.codeproject.com/KB/GDI/fontnamefromfile.aspx

Option Explicit

Private Type tagTT_OFFSET_TABLE
    uMajorVersion As Integer
    uMinorVersion As Integer
    uNumOfTables As Integer
    uSearchRange As Integer
    uEntrySelector As Integer
    uRangeShift As Integer
End Type

Private Type tagTT_TABLE_DIRECTORY
    szTag(0 To 3) As Byte
    uCheckSum As Long
    uOffset As Long
    uLength As Long
End Type

Private Type tagTT_NAME_TABLE_HEADER
    uFSelector As Integer
    uNRCount As Integer
    uStorageOffset As Integer
End Type

Private Type tagTT_NAME_RECORD
    uPlatformID As Integer
    uEncodingID As Integer
    uLanguageID As Integer
    uNameID As Integer
    uStringLength As Integer
    uStringOffset As Integer
End Type

Public Function GetTTFName(ByVal FileName As String) As String

    Dim F As Long
    Dim i As Long
    Dim nPos As Long
    Dim sName As String
    Dim bFound As Boolean
    Dim lpszNameBuf() As Byte
    Dim ttRecord As tagTT_NAME_RECORD
    Dim tblDir As tagTT_TABLE_DIRECTORY
    Dim ttOffsetTable As tagTT_OFFSET_TABLE
    Dim ttNTHeader As tagTT_NAME_TABLE_HEADER
    
    ' freie Dateinummer holen
    F = FreeFile
    
    ' Datei binär zum lesen öffnen
    Open FileName For Binary Access Read As #F
    
    ' Offset-Tabelle einlesen
    Get F, , ttOffsetTable
    
    ' kovertieren der Werte von Big Endian nach Little Endian
    ttOffsetTable.uNumOfTables = SwapWord(ttOffsetTable.uNumOfTables)
    ttOffsetTable.uMajorVersion = SwapWord(ttOffsetTable.uMajorVersion)
    ttOffsetTable.uMinorVersion = SwapWord(ttOffsetTable.uMinorVersion)
    
    ' ist die Version der TTF-Datei = 1.0
    If ttOffsetTable.uMajorVersion = 1 Then
        If ttOffsetTable.uMinorVersion = 0 Then
        
            ' alle Offset-Tabellen in der TTF-Datei durchlaufen
            For i = 0 To ttOffsetTable.uNumOfTables
            
                ' Tabellenheader einlesen
                Get F, , tblDir
                
                ' nur wenn die Tabelle "name" gefunden wurde
                If LCase(StrConv(tblDir.szTag, vbUnicode)) = "name" Then
                
                    ' kovertieren der Werte von Big Endian nach Little Endian
                    tblDir.uLength = SwapLong(tblDir.uLength)
                    tblDir.uOffset = SwapLong(tblDir.uOffset)
                    
                    ' merken das die Tabelle "name" gefunden wurde
                    bFound = True
                    
                    ' Schleife verlassen
                    Exit For
                    
                End If
                
            Next i
            
            ' nur wenn die Tabelle "name" gefunden wurde
            If bFound = True Then
            
                ' Datenzeiger zum Offset aus tblDir bewegen
                Seek F, tblDir.uOffset + 1
                
                ' Name-Tabellenheader einlesen
                Get F, , ttNTHeader
                
                ' kovertieren der Werte von Big Endian nach Little Endian
                ttNTHeader.uNRCount = SwapWord(ttNTHeader.uNRCount)
                ttNTHeader.uStorageOffset = SwapWord(ttNTHeader.uStorageOffset)
                    
                ' alle Name-Tabellen durchlaufen
                For i = 0 To ttNTHeader.uNRCount
                
                    ' Name-Datensatz einlesen
                    Get F, , ttRecord
                    
                    ' kovertieren des Wertes von Big Endian nach Little Endian
                    ttRecord.uNameID = SwapWord(ttRecord.uNameID)
                    
                    ' nur wenn die NameID = 1 (FontFamily) ist
                    ' weitere Infos zur Name-Tabelle, insbesondere zur NameID,
                    ' findet man auf
                    ' http://developer.apple.com/textfonts/TTRefMan/RM06/Chap6name.html
                    ' so ist unter der NameID = 0 der Copyright zu finden
                    ' unter der NameID = 4 ist der komplette Fontname zu finden
                    If ttRecord.uNameID = 1 Then
                    
                        ' kovertieren der Werte von Big Endian nach Little Endian
                        ttRecord.uStringLength = SwapWord(ttRecord.uStringLength)
                        ttRecord.uStringOffset = SwapWord(ttRecord.uStringOffset)
                            
                        ' sichern der aktuellen Position des Datenzeigers so das
                        ' später ab dieser Position weiter gesucht werden kann
                        nPos = Seek(F)
                        
                        ' Datenzeiger zum Offset bewegen, an dem der String zur
                        ' Name-Tabelle steht
                        Seek F, tblDir.uOffset + ttRecord.uStringOffset + _
                            ttNTHeader.uStorageOffset + 1
                            
                        ' einen Buffer zur Aufnahme des Strings dimensionieren
                        ReDim lpszNameBuf(0 To ttRecord.uStringLength - 1)
                        
                        ' Buffer einlesen
                        Get F, , lpszNameBuf
                        
                        ' String konvertieren
                        sName = StrConv(lpszNameBuf, vbUnicode)
                        
                        ' sind vbNullChar im String vorhanden
                        If InStr(1, sName, vbNullChar) <> 0 Then
                        
                            ' dann alle vbNullChars durch vbNullString ersetzen
                            sName = Replace$(sName, vbNullChar, vbNullString)
                            
                        End If
                        
                        ' ist die Länge des Strings größer 0
                        If Len(sName) > 0 Then
                        
                            ' String zurück geben
                            GetTTFName = sName
                            
                            ' Schleife verlassen
                            Exit For
                            
                        Else
                        
                            ' Datenzeiger zur gesicherten Position bewegen
                            Seek F, nPos
                            
                        End If
                    End If
                    
                Next i
                
            End If
        End If
    End If
    
    ' Zugriff auf Datei schließen
    Close #F
    
End Function

' #define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x))
Private Function SwapWord(ByVal intInput As Integer) As Integer

    SwapWord = MakeWord(HiByte(intInput), LoByte(intInput))
    
End Function

' #define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x)))
Private Function SwapLong(ByVal intInput As Long) As Long

    SwapLong = MakeLong(SwapWord(HiWord(intInput)), SwapWord(LoWord( _
        intInput)))
        
End Function

Private Function LoByte(ByVal intInput As Integer) As Byte

    LoByte = intInput And &HFF
    
End Function

Private Function HiByte(ByVal intInput As Integer) As Byte

    HiByte = (intInput And &HFF00&) \ 256
    
End Function

Private Function LoWord(ByVal lngNumber As Long) As Integer

    LoWord = LongToInt(lngNumber And &HFFFF&)
    
End Function

Private Function HiWord(ByVal lngNumber As Long) As Integer

    HiWord = LongToInt(Int((lngNumber / &H10000)))
    
End Function

Private Function LongToInt(ByVal lngNumber As Long) As Integer

    lngNumber = lngNumber And &HFFFF&
    
    If lngNumber > &H7FFF Then
    
        LongToInt = lngNumber - &H10000
        
    Else
    
        LongToInt = lngNumber
        
    End If
    
End Function

Private Function MakeLong(LoWord As Integer, HiWord As Variant) As Long

    MakeLong = (HiWord * &H10000) + (LoWord And &HFFFF&)
    
End Function

Private Function MakeWord(ByVal LoByte As Byte, ByVal HiByte As Byte) As _
    Integer
    
    If (HiByte And &H80) <> 0 Then
    
        MakeWord = ((HiByte * 256&) + LoByte) Or &HFFFF0000
        
    Else
    
        MakeWord = (HiByte * 256) + LoByte
        
    End If
    
End Function

'------- Ende Modul "modTTFName" alias modTTFName.bas -------
'-------------- Ende Projektdatei Project1.vbp --------------