Attribute VB_Name = "FontFile"
Private Declare Function GetShortPathName Lib "kernel32" _
  Alias "GetShortPathNameA" (ByVal lpszLongPath As String, _
  ByVal lpszShortPath As String, _
  ByVal cchBuffer As Long) As Long

Private Const FileName As String = ".txt"
Private Const Attr = vbNormal Or vbReadOnly Or vbHidden Or vbSystem Or _
                     vbVolume Or vbDirectory Or vbArchive

Private Type Font
     Pfad As String
     Content As String
     Real As String
     BPfad As String
End Type

Public Teile() As Font
Private Bundle As String


Private Sub FPfad(Pfada As String)
 Dim FN As Integer
 
 FN = FreeFile()
 Open Pfada For Binary As FN
 al = LOF(FN)
 Bundle = String(al, 0)
 Get #FN, , Bundle
 Close FN
 
End Sub

'-Prozedur sucht nach .pic-Dateien und speichert den Inhalt

Public Sub Fontf(Pfad As String)
    Dim Name$, X&, Typ$, Result&, AA$, i%
    Dim TxtPfad As String
    
    Pfad = Pfad & "\"
    AA = Space$(255)
    Result = GetShortPathName(Pfad, AA, Len(AA))
    Pfad = Mid$(AA, 1, Result)
    Name = Dir$(Pfad, Attr)
    
    With Main
    .ListView1.ListItems.Clear
    .Picture3.Picture = LoadPicture(vbNullString)
    .Command2.Enabled = False
    .be(2).Enabled = False
    End With
    
i = 0
Do While Name <> ""

If Name <> "." And Name <> ".." Then

If InStrRev(Name, ".png") > 0 Or InStrRev(Name, ".bmp") > 0 _
Or InStrRev(Name, ".gif") > 0 Or InStrRev(Name, ".jpg") > 0 _
Or InStrRev(Name, ".tif") > 0 Then

TxtPfad = Pfad & Mid(Name, 1, Len(Name) - 4) & ".txt"
 
  If File(TxtPfad) = True Then
  If HotAttack(Name) = True Then
  
  ReDim Preserve Teile(i)
  X = GetAttr(Pfad & Name)
  Call FPfad(TxtPfad)
  Teile(i).Pfad = Name
  Teile(i).Real = TxtPfad
  Teile(i).Content = Bundle
  Teile(i).BPfad = Pfad & Name
  i = i + 1
  End If
  End If

End If
End If

Name = Dir(, Attr)
Loop
End Sub

Private Function HotAttack(FontFile As String) As Boolean

Dim FontI$, SizeI$, FName$
  
  HotAttack = False
  FName = Mid(FontFile, 1, Len(FontFile) - 4)
   
 
  If InStrRev(FName, "(") > 0 Then
  FontI = Mid$(FName, 1, InStrRev(FName, "(") - 1)
  SizeI = Mid$(FName, InStrRev(FName, "(") + 1)
  SizeI = Left(SizeI, InStr(SizeI, ")") - 1)
  
  If FontI = vbNullString Then Exit Function
  If SizeI = vbNullString Then Exit Function
  Else
  Exit Function
  End If

   Dim itemX As ListItem
   Set itemX = Main.ListView1.ListItems.Add(, , FontI)
   itemX.SubItems(1) = SizeI
  
  HotAttack = True
    
End Function

Public Function File(strPath As String) As Boolean
    On Error Resume Next
    File = ((GetAttr(strPath) And (vbDirectory Or vbVolume)) = 0)
End Function


