Option Explicit
Dim CurrentOption%
Dim theFontName$
Dim theTTF$

Private Sub Command1_Click()
Unload Me
End Sub

Private Sub Form_Load()

Dir1.Path = App.Path
File1.Path = Dir1.Path

'// Blir fel om det inte finns några poster att visa!
File1.ListIndex = 0

End Sub

Private Sub Dir1_Change()
File1.Path = Drive1.Drive
File1.Pattern = "*.ttf"
End Sub

Private Sub File1_Click()

Dim stat&

LoadFontInfo File1.Path & "\" & File1.FileName, List1, _
CurrentOption, theFontName$

If Option1(1).Value <> True Then Exit Sub

'// TT-fontens filnamn och sökväg
theTTF$ = File1.Path & "\" & File1.FileName

'// adderar fonten 'permanent'
AddFontResource theTTF$

'// Presenterar fonten
Text1.Font = theFontName$
Text1.Refresh

'// Avinstallerar fonten igen
'// Obs! Filen tas INTE bort fysiskt
stat& = RemoveFontResource(theTTF$)
' stat& = RemoveFontResource("c:\windows\fonts\" & File1.FileName)

'// Uppdaterar poolen med fonter
' som ligger cachade av Windows
stat& = SendMessageBynum(HWND_BROADCAST, WM_FONTCHANGE, 0, 0)

End Sub

Private Sub Option1_Click(index As Integer)

CurrentOption% = index

'// Aktiverar fil-klickning
File1_Click

End Sub