VERSION 5.00
Begin VB.Form Saves 
   AutoRedraw      =   -1  'True
   BorderStyle     =   4  'Fixed ToolWindow
   Caption         =   " Speichern"
   ClientHeight    =   2865
   ClientLeft      =   45
   ClientTop       =   315
   ClientWidth     =   4860
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   191
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   324
   ShowInTaskbar   =   0   'False
   StartUpPosition =   1  'CenterOwner
   Begin VB.PictureBox pics 
      AutoRedraw      =   -1  'True
      BackColor       =   &H00FF00FF&
      BorderStyle     =   0  'None
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00FFFFFF&
      Height          =   2280
      Left            =   240
      ScaleHeight     =   2280
      ScaleWidth      =   4680
      TabIndex        =   16
      Top             =   5640
      Visible         =   0   'False
      Width           =   4680
   End
   Begin VB.PictureBox Picture2 
      BorderStyle     =   0  'None
      Height          =   255
      Left            =   3600
      Picture         =   "Save.frx":0000
      ScaleHeight     =   255
      ScaleWidth      =   1215
      TabIndex        =   3
      Top             =   2520
      Width           =   1215
      Begin VB.Label Label3 
         Alignment       =   2  'Center
         Appearance      =   0  'Flat
         BackColor       =   &H80000005&
         BackStyle       =   0  'Transparent
         BorderStyle     =   1  'Fixed Single
         Caption         =   "&Abbrechen"
         ForeColor       =   &H80000008&
         Height          =   255
         Left            =   0
         TabIndex        =   4
         Top             =   0
         Width           =   1215
      End
   End
   Begin VB.PictureBox Picture3 
      BorderStyle     =   0  'None
      Height          =   255
      Left            =   2280
      Picture         =   "Save.frx":0329
      ScaleHeight     =   255
      ScaleWidth      =   1215
      TabIndex        =   1
      Top             =   2520
      Width           =   1215
      Begin VB.Label Label4 
         Alignment       =   2  'Center
         Appearance      =   0  'Flat
         BackColor       =   &H80000005&
         BackStyle       =   0  'Transparent
         BorderStyle     =   1  'Fixed Single
         Caption         =   "&Erstellen"
         ForeColor       =   &H80000008&
         Height          =   255
         Left            =   0
         TabIndex        =   2
         Top             =   0
         Width           =   1215
      End
   End
   Begin VB.PictureBox picEdit 
      AutoRedraw      =   -1  'True
      BackColor       =   &H00FF00FF&
      BorderStyle     =   0  'None
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00FFFFFF&
      Height          =   2280
      Left            =   240
      ScaleHeight     =   152
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   312
      TabIndex        =   0
      Top             =   3000
      Visible         =   0   'False
      Width           =   4680
   End
   Begin VB.PictureBox Picture1 
      Appearance      =   0  'Flat
      BackColor       =   &H00FFFFFF&
      ForeColor       =   &H80000008&
      Height          =   2295
      Left            =   120
      ScaleHeight     =   2265
      ScaleWidth      =   4665
      TabIndex        =   5
      Top             =   120
      Width           =   4695
      Begin VB.ComboBox Combo1 
         Height          =   315
         ItemData        =   "Save.frx":0652
         Left            =   120
         List            =   "Save.frx":0665
         Style           =   2  'Dropdown List
         TabIndex        =   14
         Top             =   1200
         Width           =   1455
      End
      Begin VB.CheckBox Check2 
         BackColor       =   &H00FFFFFF&
         Caption         =   "Fontmap erstellen"
         Height          =   255
         Left            =   1800
         TabIndex        =   13
         Top             =   1680
         Value           =   1  'Checked
         Width           =   1575
      End
      Begin VB.PictureBox Picture6 
         Appearance      =   0  'Flat
         BackColor       =   &H00FFFFFF&
         ForeColor       =   &H80000008&
         Height          =   255
         Left            =   -8
         ScaleHeight     =   225
         ScaleWidth      =   4665
         TabIndex        =   12
         Top             =   2040
         Width           =   4695
         Begin VB.Image Image7 
            Height          =   540
            Left            =   0
            Picture         =   "Save.frx":0682
            Top             =   0
            Width           =   1785
         End
      End
      Begin VB.TextBox Text1 
         Appearance      =   0  'Flat
         BackColor       =   &H00FFFFFF&
         Height          =   285
         Left            =   720
         Locked          =   -1  'True
         TabIndex        =   9
         Top             =   480
         Width           =   2655
      End
      Begin VB.PictureBox Picture37 
         BorderStyle     =   0  'None
         Height          =   285
         Left            =   3480
         Picture         =   "Save.frx":09AB
         ScaleHeight     =   285
         ScaleWidth      =   1095
         TabIndex        =   7
         Top             =   480
         Width           =   1095
         Begin VB.Label Label53 
            Appearance      =   0  'Flat
            BackColor       =   &H80000005&
            BackStyle       =   0  'Transparent
            BorderStyle     =   1  'Fixed Single
            Caption         =   "   &Wählen"
            ForeColor       =   &H80000008&
            Height          =   285
            Left            =   0
            TabIndex        =   8
            Top             =   0
            Width           =   1095
         End
         Begin VB.Image Image15 
            Appearance      =   0  'Flat
            Height          =   225
            Left            =   780
            Picture         =   "Save.frx":0CD4
            Top             =   15
            Width           =   285
         End
      End
      Begin VB.CheckBox Check1 
         BackColor       =   &H00FFFFFF&
         Caption         =   "Styles erlauben"
         Height          =   255
         Left            =   120
         TabIndex        =   6
         Top             =   1680
         Value           =   1  'Checked
         Width           =   1575
      End
      Begin VB.Label Label2 
         BackColor       =   &H00FFFFFF&
         BackStyle       =   0  'Transparent
         Caption         =   "Ausgabeformat:"
         BeginProperty Font 
            Name            =   "Tahoma"
            Size            =   8.25
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00800000&
         Height          =   255
         Left            =   120
         TabIndex        =   15
         Top             =   960
         Width           =   1215
      End
      Begin VB.Image Image6 
         Height          =   3120
         Left            =   3000
         Picture         =   "Save.frx":10BB
         Top             =   -240
         Width           =   1785
      End
      Begin VB.Label Label1 
         BackStyle       =   0  'Transparent
         Caption         =   "Ordner:"
         Height          =   375
         Left            =   120
         TabIndex        =   11
         Top             =   520
         Width           =   1215
      End
      Begin VB.Label Label56 
         BackColor       =   &H00FFFFFF&
         BackStyle       =   0  'Transparent
         Caption         =   "Speichern unter:"
         BeginProperty Font 
            Name            =   "Tahoma"
            Size            =   8.25
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00800000&
         Height          =   255
         Left            =   120
         TabIndex        =   10
         Top             =   120
         Width           =   1695
      End
   End
End
Attribute VB_Name = "Saves"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private WithEvents gdip As cGdiPlus
Attribute gdip.VB_VarHelpID = -1

Private Type FontX
  X As Integer
  Y As Integer
  Width As Integer
  Name As String
End Type

Private Const Sym As String = vbNullString
Private Char(0 To 255) As FontX
Private Source As String
Private OutPfad As String
Private Vlauf As Boolean

Private Const FileTxt = ".txt"
Private Const FileBMP = ".bmp"


Private Sub Label3_Click()
  Unload Me
End Sub

Private Sub Form_Load()
  Combo1.ListIndex = 0
  Text1.Text = CompactPath(Me, sPath, Text1)
  Text1.SelStart = Len(Text1.Text)
  Text1.ToolTipText = sPath
End Sub

Sub PicEvent()
  With Main
   
  If .List1.Selected(5) = True Then
  picEdit.ForeColor = &HFFFFFF
  Else
  picEdit.ForeColor = .Shape1.FillColor
  End If
  
  picEdit.FontSize = .FSize.Text
  picEdit.FontBold = .Style(1).Value
  picEdit.FontItalic = .Style(2).Value
  picEdit.FontUnderline = .Style(3).Value
  picEdit.FontName = .Combo1.List(.Combo1.ListIndex)
  picEdit.Cls
  End With

End Sub

Sub Paintit(Pic As PictureBox)
 Dim StX As Integer
 Dim StY As Integer
      
 StX = 2
 StY = 4
 
 For i = 1 To 254
 
 StX = StX + Pic.TextWidth(Chr(i - 1))
 StX = StX + Pic.TextWidth(Chr(0))
 
If Pic.TextWidth(Chr(i + 1)) + StX > Pic.ScaleWidth - 8 Then
      
 If Vlauf = True Then
 With Pic
  pics.Cls
  pics.ScaleMode = 3
  pics.Width = StX + Pic.TextWidth(Chr(i)) + 2
  pics.Height = Pic.TextHeight(Chr(0))
  pics = LoadPicture("")
    
  BitBlt pics.hDC, 0, 0, StX + Pic.TextWidth(Chr(i)) + 2, _
         .TextHeight(Chr(0)), .hDC, 2, StY, vbSrcCopy
         pics.Refresh
  
  Call Textur(pics)
    
  BitBlt .hDC, 2, StY, StX + Pic.TextWidth(Chr(i)) + 2, _
  .TextHeight(Chr(0)), pics.hDC, 0, 0, vbSrcCopy
  .Refresh
 End With
 End If
 
     StY = StY + Pic.TextHeight(Chr(0)) + 4
     Pic.Height = StY + Pic.TextHeight(Chr(i)) + 4
     StX = 2
End If
   
 Char(i).Name = Chr(i)
 Char(i).X = StX - 1
 Char(i).Y = StY - 1
 Char(i).Width = Pic.TextWidth(Chr(i)) + 2
 
 Pic.CurrentX = StX
 Pic.CurrentY = StY
 Pic.Print Chr(i)
 Next i
 
 If Vlauf = True Then
 With Pic
  pics.Cls
  pics.ScaleMode = 3
  pics.Width = StX + Pic.TextWidth(Chr(i)) + 2
  pics.Height = Pic.TextHeight(Chr(0))
  pics = LoadPicture("")
    
  BitBlt pics.hDC, 0, 0, StX + Pic.TextWidth(Chr(i)) + 2, _
         .TextHeight(Chr(0)), .hDC, 2, StY, vbSrcCopy
         pics.Refresh
  
  Call Textur(pics)
    
  BitBlt .hDC, 2, StY, StX + Pic.TextWidth(Chr(i)) + 2, _
  .TextHeight(Chr(0)), pics.hDC, 0, 0, vbSrcCopy
  .Refresh
 End With
 End If

End Sub

Private Sub Label4_Click()
 Call CreatAll
End Sub

Sub CreatAll()
Dim data As Integer
Dim Valu As Long
 
 'Regwert von Clear-Typ vorbereiten
 Valu = fWertLesen(&H80000001, _
 "Control Panel\Desktop\", "FontSmoothing")
 
 Call fStringSpeichernLong(&H80000001, _
  "Control Panel\Desktop\", "FontSmoothing", 0)
  
'Status-Balken vorbereiten
  Picture6.BackColor = vbWhite
  Image7.Visible = True
  Dauer = 100

'Bildeinstellungen laden
  Call PicEvent

'Balken aktualisieren
  PB = 10
  Call Balken(Saves.Picture6)

'Verlauf anpassen
 Vlauf = False
 If Check1.Value = vbChecked Then
 If Stil1.Check2.Value = vbChecked Then
 If Main.List1.Selected(6) = True Then
  Vlauf = True
 End If
 End If
 End If

'Fonts zeichnen...
  Call Paintit(picEdit)

'Balken aktualisieren
  PB = 20
  Call Balken(Saves.Picture6)
  
'Effekte erlauben?...
  If Check1.Value = vbChecked Then
   Call Check(picEdit, Picture6, , 2)
  End If

'Schauen ob Output-Direcotry exisitiert...
  If sPath = Output Then
    If Not DirExists(OutPfad) Then
    MkDir Output
    End If
  End If
  
  'Pfad der Dateien anlegen
  Source = sPath & "\" & picEdit.FontName
  Source = Source & "(" & Main.FSize.Text & ")"
  

  If File(Source & FileTxt) Then
  Dim i As Long
   i = 0
  Do While File(Source & "-" & i & FileTxt)
    i = i + 1
  Loop
  
  Source = Source & "-" & i
  End If
  
  'Fontfile erlauben?...
  If Check2.Value = vbChecked Then
  data = FreeFile
  Open Source & FileTxt For Output As #data
   PB = 60: Call Balken(Saves.Picture6)
   
   For i = 32 To UBound(Char) - 1

   If Not i = 34 Then

   Print #data, _
    Char(i).X & "," & _
    Char(i).Y & "," & _
    Char(i).Width & "," & _
    picEdit.TextHeight("W") & "," & _
    Chr(34) & Char(i).Name & _
    Chr(34)
   End If

    Next i
  Close #data

  PB = 80: Call Balken(Saves.Picture6)
  End If
  
  DoEvents
  
 Call fStringSpeichernLong(&H80000001, _
 "Control Panel\Desktop\", "FontSmoothing", CStr(Valu))

'Als Bild abspeichern...
 If Combo1.Text = "BMP" Then
   SavePicture picEdit.Image, Source & FileBMP
   Call Erfolg
 Else
   Call SaveIt
 End If

  Unload Me
End Sub

Sub SaveIt()
Dim Pfad As String

  Pfad = Source & "." & LCase(Combo1.Text)

 On Error GoTo Fehler
  
  Set gdip = New cGdiPlus
  Set picEdit.Picture = picEdit.Image
  
  If gdip.PictureBoxToFile(picEdit, Pfad, 100) Then
  Call Erfolg
  Else
  GoTo Fehler
  End If
  Set gdip = Nothing
  Exit Sub
  
Fehler:
  Set gdip = Nothing
  Call SFehler
End Sub

Sub Erfolg()
  PB = 100: Call Balken(Saves.Picture6)
  MsgBox "Bild erfolgreich gespeichert", vbInformation, "Erfolg:"
End Sub

Sub SFehler()
 PB = 100: Call Balken(Saves.Picture6)
 MsgBox "Bild konnte nicht gespeichert werden", vbCritical, "Fehler:"
End Sub

Private Sub Label53_Click()
Dim PfadO
  PfadO = Dialog("Bitte Speicher-Ordner wählen", Me)
  
  If PfadO <> vbNullString Then
    Text1.Text = CompactPath(Me, PfadO, Text1)
    Text1.SelStart = Len(Text1.Text)
    Text1.ToolTipText = PfadO
    sPath = PfadO
  End If
  
End Sub

