Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" (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
Private Declare Function RemoveFontResource Lib "gdi32" Alias "RemoveFontResourceA" (ByVal lpFilename As String) As Long
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long

Private Const VER_PLATFORM_WIN32_NT = 2
Private Const HWND_BROADCAST = &HFFFF&
Private Const WM_FONTCHANGE = &H1D
Private Const MAX_PATH = 260
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const REG_SZ = 1

3. Legen Sie eine eigene Prozedur unter Allgemein an.
Entsteht automatisch durch das Einfügen des Codes.
Private Sub Add32Font(Filename As String)
Dim lResult As Long
Dim strFontPath As String, strFontname As String
Dim hKey As Long

strFontPath = Space$(MAX_PATH)
strFontname = Filename

If NT Then 'für Windows NT
   lResult = GetWindowsDirectory(strFontPath, MAX_PATH)
   If lResult <> 0 Then
      Mid$(strFontPath, lResult + 1, 1) = "\"
      strFontPath = RTrim$(strFontPath)
   End If
Else ' für Win95
   lResult = GetWindowsDirectory(strFontPath, MAX_PATH)
   If lResult <> 0 Then
      Mid$(strFontPath, lResult + 1) = "\fonts\"
      strFontPath = RTrim$(strFontPath)
   End If
End If

lResult = AddFontResource(strFontPath + strFontname)
If lResult = 0 Then MsgBox "Fehler aufgetreten bei der Fonts Registrierung !"
'Schreiben des Registryeintrags
lResult = RegOpenKey(HKEY_LOCAL_MACHINE, "software\microsoft\windows\currentversion\" & "fonts", hKey)
lResult = RegSetValueEx(hKey, "Proscape Font " & strFontname & " (TrueType)", 0, REG_SZ, ByVal strFontname, Len(strFontname))
lResult = RegCloseKey(hKey)
'Ergebnisausgabe
lResult = PostMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0)
MsgBox Filename & " registriert!"
End Sub

4. Legen Sie eine weitere eigene Prozedur unter Allgemein an.
Entsteht automatisch durch das Einfügen des Codes .

Private Function NT() As Boolean
Dim lResult As Long
Dim vi As OSVERSIONINFO
vi.dwOSVersionInfoSize = Len(vi)
lResult = GetVersionEx(vi)
If vi.dwPlatformId And VER_PLATFORM_WIN32_NT Then
   NT = True
Else
   NT = False
End If

End Function

5. Und eine weitere eigene Prozedur zum ermitteln des Windowsverzeichnisses.
Entsteht automatisch durch das Einfügen des Codes .

Function GetWinDir() As String
Dim Buffer As String * 254, r As Long, sDir As String
r = GetWindowsDirectory(Buffer, 254)
sDir = Left(Buffer, r)
If Right(sDir, 1) = "\" Then sDir = Left(sDir, Len(sDir) - 1)
GetWinDir = sDir
End Function

6. Und nun die letzte Prozedur zur Ergebnisrückgabe.
Entsteht automatisch durch das Einfügen des Codes .
Public Function Reverse(Text As String) As String
On Error Resume Next
Dim I%, mx%, result$
mx = Len(Text)

For I = mx To 1 Step -1
   result = result + Mid$(Text, I, 1)
Next

Reverse = result
End Function

7. Fügen Sie nun auf Ihrer Form einen CommandButton hinzu und fügen Sie in die Prozedur Click folgendes ein.
Dim Pfad, x$, Windows As String

'Obligatorische Backslashprüfung
If Not Right(App.Path, 1) = "\" Then
   Pfad = App.Path & "\"
Else
   Pfad = App.Path
End If

'Funktion Windowsverzeichnis ermitteln
Windows = GetWinDir

'Obligatorische Backslashprüfung
If Not Right(Windows, 1) = "\" Then
   Windows = Windows & "\"
End If

x$ = ""
x$ = Dir(Pfad & "*.ttf")

If x$ = "" Then
   'wenn keine TTF zum registrieren gefunden wurde
   MsgBox "Keine TTF im Verzeichnis gefunden !", 16, "TTF - Registrierung"
   Exit Sub
Else
   'Kopieren des TTF ins Schriftenverzeichnis
   FileCopy Pfad & x$, Windows & "Fonts\" & x$
   'Aufruf der Funktion zum registrieren der TTF im Schriftenverzeichnis
   Call Add32Font(x$)
End If

'die nächste Schriftart bitte
Do While Not x$ = ""
   x$ = ""
   x$ = Dir 'alle weiteren TTF
   If Not x$ = "" Then
      FileCopy Pfad & x$, Windows & "Fonts\" & x$
      Call Add32Font(x$)
   End If
Loop

8. Erläuterung zum Programmaufbau.
Es ist so aufgebaut, das alle TTF, die sich in dem Verzeichnis befinden, aus dem das Programm heraus gestartet wurde in das Schriftenverzeichnis kopiert werden und dort in die Registry registriert werden. Die TTF im Applikationsverzeichnis können anschließend gelöscht werden.

9. Programmtest mit F5