Tippseite

VB-Homepage Tipp 408

Schriftarten temporär im System registrieren / Fontvorschau

Sie kennen sicher einige Tools auf dem Markt, die Ihnen die Funktionalität bieten, Schriftarten erst anzuschauen, bevor Sie sie installieren. Eine feine Sache, bedenkt man die Schwämme an Schriftarten und das mit jeder Schriftart das System von Haus aus mehr zu tun bekommt.
Und so sollen Sie zukünftig auch die Möglichkeit haben, Schriftarten temporär im System zu registreiren um Sie zu betrachten oder um Ihrem Programm die Darstellung in einer Schriftart zu garantieren, die ggf. nicht im System verfügbar ist.

Allgemein/Deklarationen
Private Declare Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" (ByVal lpFileName As String) As Long
Private Declare Function RemoveFontResource Lib "gdi32" Alias "RemoveFontResourceA" (ByVal lpFileName As String) As Long
Private Declare Function CreateScalableFontResource Lib "gdi32" Alias "CreateScalableFontResourceA" (ByVal fHidden As Long, ByVal lpszResourceFile As String, ByVal lpszFontFile As String, ByVal lpszCurrentPath As String) As Long

Dim strFontName As String
Dim strErsterFont As String

Allgemein/GetFontName
Function GetFontName(FileNameTTF As String) As String

Dim hFile As Integer
Dim Buffer As String
Dim FontName As String
Dim TempName As String
Dim iPos As Integer

'Anlegen einer Temp.Datei
TempName = App.Path & "\~TEMP.FOT"

If CreateScalableFontResource(1, TempName, FileNameTTF, vbNullString) Then
   hFile = FreeFile

   Open TempName For Binary Access Read As hFile
      Buffer = Space(LOF(hFile))
      Get hFile, , Buffer
      iPos = InStr(Buffer, "FONTRES:") + 8
      FontName = Mid(Buffer, iPos, InStr(iPos, Buffer, vbNullChar) - iPos)
   Close hFile
   Kill TempName
End If
GetFontName = FontName
End Function

Soviel erstmal zur Deklaration, weiter mit den notwendigen Objekten.
Fügen Sie nun zwei Commandbutton auf Ihre Form (Command1 / Command2)
und vergeben Sie als Bezeichnung (Registrieren / Deregistrieren) an.
Stellen Sie außerdem Command2.Enabled=False ein.
Desweiteren benötigen wir noch ein Ausgabeobjekt (hier Label1), der uns den echten Schriftartennamen in der installierten Schriftart anzeigen soll. Außerdem noch ein weiteres Labelobjekt (Label2), der den Dateinamen ausgeben soll.

Layout :

	Command1		Command2

	Label1

	Label2

Nun geht es mit der Deklaration der Aktionen weiter.
Form/Load
'Sucht die erste Schriftartdatei im Programmverzeichnis
'(also bitte eine hinein kopieren)
strErsterFont = Dir(App.Path & "\*.ttf")

If strErsterFont = "" Then
MsgBox "Es wurde keine Schriftart im Programmverzeichnis gefunden"
Unload Me
End
End If
strFontName = App.Path & "\" & strErsterFont
Label2.Caption = strErsterFont

Form/Unload
If Command2.Enabled = True Then
MsgBox "Bitte erst Schriftart wieder deregistrieren" 'Sicher ist Sicher
Cancel = 1
End If

Command1/Click
Dim lWert As Long

Command1.Enabled = False
Command2.Enabled = True

lWert = AddFontResource(strFontName)

'Fehler
If lWert = 0 Then MsgBox "Fehler bei der Installation der Schriftart"

Label1.Font = GetFontName(strFontName)
Label1.Caption = GetFontName(strFontName)

Command2/Click
Dim lWert As Long

Command1.Enabled = True
Command2.Enabled = False

lWert = RemoveFontResource(strFontName)

'Fehler
If lWert = 0 Then MsgBox "Fehler bei der Deinstallation der Schriftart"

Label1.Font = "Arial"
Label1.Caption = ""

An Vorarbeit war es das, denken Sie an das zur Verfügung stellen einer Schriftartendatei im Programmverzeichnis und Sie können Ihr Programm starten.
Haben Sie die Datei registriert (Command1), wird Ihnen der Text im Label1 in der
neuen Schriftart angezeigt.

Tipp-Download

Quelle :