VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Begin VB.Form frmMain 
   AutoRedraw      =   -1  'True
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Font Creator - www.r-pg.net"
   ClientHeight    =   4800
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   5205
   BeginProperty Font 
      Name            =   "Verdana"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "frmMain.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   MousePointer    =   2  'Cross
   ScaleHeight     =   320
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   347
   StartUpPosition =   3  'Windows Default
   Begin MSComctlLib.StatusBar StatusBar1 
      Align           =   2  'Align Bottom
      Height          =   255
      Left            =   0
      TabIndex        =   23
      Top             =   4545
      Width           =   5205
      _ExtentX        =   9181
      _ExtentY        =   450
      Style           =   1
      SimpleText      =   "Ready"
      _Version        =   393216
      BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628} 
         NumPanels       =   1
         BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
         EndProperty
      EndProperty
   End
   Begin VB.Frame Frame2 
      Caption         =   "Font"
      Height          =   3615
      Left            =   120
      TabIndex        =   11
      Top             =   840
      Visible         =   0   'False
      Width           =   4935
      Begin VB.VScrollBar scy 
         Height          =   1455
         Left            =   2880
         TabIndex        =   22
         Top             =   240
         Width           =   255
      End
      Begin VB.HScrollBar scx 
         Height          =   255
         Left            =   120
         TabIndex        =   21
         Top             =   1680
         Width           =   2775
      End
      Begin VB.PictureBox picContainer 
         Appearance      =   0  'Flat
         BackColor       =   &H80000005&
         BorderStyle     =   0  'None
         ForeColor       =   &H80000008&
         Height          =   1455
         Left            =   120
         ScaleHeight     =   97
         ScaleMode       =   3  'Pixel
         ScaleWidth      =   185
         TabIndex        =   19
         Top             =   240
         Width           =   2775
         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          =   960
            Left            =   0
            ScaleHeight     =   64
            ScaleMode       =   3  'Pixel
            ScaleWidth      =   80
            TabIndex        =   20
            Top             =   0
            Width           =   1200
         End
      End
      Begin VB.CommandButton Command7 
         Caption         =   "Back"
         Height          =   375
         Left            =   3240
         TabIndex        =   18
         Top             =   240
         Width           =   1575
      End
      Begin VB.CommandButton Command1 
         Caption         =   "Save"
         BeginProperty Font 
            Name            =   "Verdana"
            Size            =   8.25
            Charset         =   0
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   375
         Left            =   3240
         TabIndex        =   17
         Top             =   720
         Width           =   1575
      End
      Begin VB.TextBox Text1 
         Height          =   375
         Left            =   120
         TabIndex        =   16
         Text            =   "Text1"
         Top             =   2160
         Width           =   2895
      End
      Begin VB.CommandButton Command2 
         Caption         =   "Preview Text"
         Height          =   375
         Left            =   3120
         TabIndex        =   15
         Top             =   2160
         Width           =   1695
      End
      Begin VB.CheckBox chk4 
         Caption         =   "Use Grid"
         Height          =   255
         Left            =   1800
         TabIndex        =   14
         Top             =   1920
         Width           =   1215
      End
      Begin VB.CheckBox chk5 
         Caption         =   "Transparent"
         Enabled         =   0   'False
         Height          =   255
         Left            =   120
         TabIndex        =   13
         Top             =   1920
         Width           =   1335
      End
      Begin VB.PictureBox picTest 
         Appearance      =   0  'Flat
         AutoRedraw      =   -1  'True
         BackColor       =   &H00F18E76&
         BeginProperty Font 
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H80000008&
         Height          =   855
         Left            =   120
         ScaleHeight     =   55
         ScaleMode       =   3  'Pixel
         ScaleWidth      =   311
         TabIndex        =   12
         Top             =   2640
         Width           =   4695
      End
   End
   Begin VB.Frame Frame1 
      Caption         =   "Choose Font"
      Height          =   3615
      Left            =   120
      TabIndex        =   0
      Top             =   840
      Width           =   4935
      Begin VB.PictureBox picBorder 
         BackColor       =   &H00000000&
         Height          =   375
         Left            =   2640
         ScaleHeight     =   315
         ScaleWidth      =   315
         TabIndex        =   26
         Top             =   2640
         Width           =   375
      End
      Begin VB.PictureBox picText 
         BackColor       =   &H00FFFFFF&
         Height          =   375
         Left            =   2640
         ScaleHeight     =   315
         ScaleWidth      =   315
         TabIndex        =   25
         Top             =   2160
         Width           =   375
      End
      Begin VB.PictureBox picBG 
         BackColor       =   &H00FF00FF&
         Height          =   375
         Left            =   2640
         ScaleHeight     =   315
         ScaleWidth      =   315
         TabIndex        =   24
         Top             =   1680
         Width           =   375
      End
      Begin VB.ComboBox Combo1 
         Appearance      =   0  'Flat
         Height          =   315
         Left            =   120
         Style           =   2  'Dropdown List
         TabIndex        =   10
         Top             =   240
         Width           =   4695
      End
      Begin VB.PictureBox picPreview 
         Appearance      =   0  'Flat
         AutoRedraw      =   -1  'True
         BackColor       =   &H00FEFEFE&
         BeginProperty Font 
            Name            =   "MS Sans Serif"
            Size            =   18
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00FFFFFF&
         Height          =   960
         Left            =   120
         ScaleHeight     =   62
         ScaleMode       =   3  'Pixel
         ScaleWidth      =   310
         TabIndex        =   9
         Top             =   600
         Width           =   4680
      End
      Begin VB.CheckBox chk1 
         Caption         =   "Center"
         Height          =   375
         Left            =   120
         TabIndex        =   7
         Top             =   2400
         Width           =   1095
      End
      Begin VB.CheckBox chk2 
         Caption         =   "Grid"
         Height          =   375
         Left            =   120
         TabIndex        =   6
         Top             =   2760
         Width           =   1095
      End
      Begin VB.CheckBox chk3 
         Caption         =   "Border"
         Height          =   375
         Left            =   120
         TabIndex        =   5
         Top             =   3120
         Width           =   975
      End
      Begin VB.CommandButton Command3 
         Caption         =   "Background Color"
         Height          =   375
         Left            =   3120
         TabIndex        =   4
         Top             =   1680
         Width           =   1695
      End
      Begin VB.CommandButton Command5 
         BackColor       =   &H00FFFFFF&
         Caption         =   "Text Color"
         Height          =   375
         Left            =   3120
         TabIndex        =   3
         Top             =   2160
         Width           =   1695
      End
      Begin VB.CommandButton Command6 
         BackColor       =   &H00000000&
         Caption         =   "Border Color"
         Height          =   375
         Left            =   3120
         TabIndex        =   2
         Top             =   2640
         Width           =   1695
      End
      Begin VB.CommandButton Command4 
         Caption         =   "Generate !"
         BeginProperty Font 
            Name            =   "Verdana"
            Size            =   8.25
            Charset         =   0
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   375
         Left            =   2640
         TabIndex        =   1
         Top             =   3120
         Width           =   2175
      End
      Begin MSComctlLib.Slider Slider1 
         Height          =   255
         Left            =   120
         TabIndex        =   8
         Top             =   1560
         Width           =   2415
         _ExtentX        =   4260
         _ExtentY        =   450
         _Version        =   393216
         Min             =   8
         Max             =   36
         SelStart        =   9
         Value           =   9
      End
   End
   Begin MSComDlg.CommonDialog cd1 
      Left            =   5520
      Top             =   5040
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.Image Image1 
      Height          =   750
      Left            =   0
      Picture         =   "frmMain.frx":08CA
      Top             =   0
      Width           =   5250
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Declare Function SetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function TransparentBlt Lib "msimg32.dll" (ByVal hdcDest As Long, ByVal nXOriginDest As Long, ByVal nYOriginDest As Long, ByVal nWidthDest As Long, ByVal hHeightDest As Long, ByVal hdcSrc As Long, ByVal nXOriginSrc As Long, ByVal nYOriginSrc As Long, ByVal nWidthSrc As Long, ByVal nHeightSrc As Long, ByVal crTransparent As Long) As Long
        
Private Type MyFont
    X As Integer
    Y As Integer
    Width As Integer
    Name As String
End Type

Private Characters(0 To 255) As MyFont
Private MaxWidth As Integer
Private MaxHeight As Integer
Private ColorKey As Long
Private TextColor As Long
Private BorderColor As Long

Public Function RenderText(Target As Long, Text As String)
    
    Dim ty As Integer
    Dim tx As Integer
    
    For i = 1 To Len(Text)
        Dim Character As String
        Character = Mid(Text, i, 1)
        Dim CharacterID As Integer
        CharacterID = Asc(Character)
        
        If chk4.Value = 1 Then
        
            If tx * MaxWidth >= picTest.ScaleWidth Then
                tx = 0
                ty = ty + 1
            End If
            tx = tx + 1
            
            If chk5.Value = 0 Then
                BitBlt Target, tx * MaxWidth - MaxWidth, ty * MaxHeight, MaxWidth, MaxHeight, picEdit.hDC, Characters(CharacterID).X, Characters(CharacterID).Y, vbSrcCopy
            Else
                TransparentBlt Target, tx * MaxWidth - MaxWidth, ty * MaxHeight, MaxWidth, MaxHeight, picEdit.hDC, Characters(CharacterID).X, Characters(CharacterID).Y, MaxWidth, MaxHeight, ColorKey
            End If
            
        Else
            
            If tx >= picTest.ScaleWidth Then
                tx = 0
                ty = ty + 1
            End If
            
            If chk5.Value = 0 Then
                BitBlt Target, tx, ty * MaxHeight, Characters(CharacterID).Width, MaxHeight, picEdit.hDC, Characters(CharacterID).X, Characters(CharacterID).Y, vbSrcCopy
            Else
                TransparentBlt Target, tx, ty * MaxHeight, Characters(CharacterID).Width, MaxHeight, picEdit.hDC, Characters(CharacterID).X, Characters(CharacterID).Y, Characters(CharacterID).Width, MaxHeight, ColorKey
            End If
            
            tx = tx + Characters(CharacterID).Width
        End If
    Next i

End Function

Public Function DrawFont()

    picEdit.FontSize = Slider1.Value
    picEdit.FontBold = True
    picEdit.FontItalic = False
    picEdit.FontName = Combo1.List(Combo1.ListIndex)
    picEdit.BackColor = ColorKey
    picEdit.ForeColor = TextColor

    picEdit.Cls
    
    Dim cx As Integer
    Dim cy As Integer
    Dim cS As String
    
    MaxWidth = 0
    MaxHeight = 0

    GetBiggestCharacter MaxWidth, MaxHeight
    
    If chk3.Value Then
        MaxWidth = MaxWidth + 2
        MaxHeight = MaxHeight + 2
    End If
    
    picEdit.Width = MaxWidth * 12
    
    Dim LeftOver As Integer
    
    If chk2.Value = 1 Then
        DrawGrid
    End If
    
    For i = 32 To 126
        
        Counter = Counter + 1
        If Counter = 10 Then
            cy = cy + MaxHeight
            picEdit.Height = cy + MaxHeight
            cx = 0
            Counter = 0
        End If
        
        If chk1.Value = 1 Then
            If picEdit.TextWidth(Chr(i)) < MaxWidth Then
                LeftOver = MaxWidth - picEdit.TextWidth(Chr(i))
                cx = cx + LeftOver / 2
            End If
        End If
        
        Characters(i).Name = Chr(i)
        Characters(i).X = cx - LeftOver / 2
        Characters(i).Y = cy
        Characters(i).Width = picEdit.TextWidth(Chr(i)) + IIf(chk3.Value = 1, 2, 0)
     
        If chk3.Value = 1 Then
            cx = cx + 1
            cy = cy + 1
        End If
        
        picEdit.CurrentX = cx
        picEdit.CurrentY = cy
        picEdit.Print Chr(i)
        
        If LeftOver > 0 Then
            cx = cx - LeftOver / 2
            LeftOver = 0
        End If
        
        cx = cx + MaxWidth
        If chk3.Value = 1 Then
            cx = cx - 1
            cy = cy - 1
        End If
    Next i
    
    cx = picEdit.ScaleWidth - MaxWidth
    cy = 0
    
    Dim DebugText As String
    DebugText = MaxWidth & "/" & MaxHeight & "Smoki"
    
    For i = 1 To Len(DebugText)
        picEdit.CurrentY = cy
        picEdit.CurrentX = cx
        picEdit.Print Mid(DebugText, i, 1)
        cy = cy + MaxHeight
    Next i
    
    If chk3.Value = 1 Then
        Border picEdit, ColorKey
    End If

End Function

Public Function GetBiggestCharacter(ByRef Width As Integer, ByRef Height As Integer)

    For i = 32 To 126
        If picEdit.TextWidth(Chr(i - 1)) > Width Then
            Width = picEdit.TextWidth(Chr(i - 1))
        End If
        
        If picEdit.TextHeight(Chr(i - 1)) > Height Then
            Height = picEdit.TextHeight(Chr(i - 1))
        End If
    Next i
    
End Function

Public Function DrawGrid()

    For X = 0 To picEdit.ScaleHeight Step MaxHeight
        picEdit.Line (0, X)-(picEdit.ScaleWidth, X), vbBlack
    Next X

    For Y = 0 To picEdit.ScaleWidth Step MaxWidth
        picEdit.Line (Y, 0)-(Y, picEdit.ScaleHeight), vbBlack
    Next Y
    
End Function

Public Function QuickPreview()

    picPreview.FontSize = Slider1.Value
    picPreview.FontBold = True
    picPreview.FontItalic = False
    picPreview.FontUnderline = False
    picPreview.FontName = Combo1.List(Combo1.ListIndex)
    picPreview.Cls
    picPreview.CurrentX = 2
    picPreview.CurrentY = 2
    picPreview.Print "The quick brown fox jumps" & vbCrLf & "over a lazy dog."
    Border picPreview, RGB(254, 254, 254)
    
End Function

Private Function Border(topic As PictureBox, Bg As Long)

    For ax = 0 To topic.ScaleWidth
        For ay = 0 To topic.ScaleHeight
            If GetPixel(topic.hDC, ax, ay) = TextColor Then
            
                If GetPixel(topic.hDC, ax + 1, ay) = Bg Then SetPixel topic.hDC, ax + 1, ay, BorderColor
                If GetPixel(topic.hDC, ax, ay + 1) = Bg Then SetPixel topic.hDC, ax, ay + 1, BorderColor
                If GetPixel(topic.hDC, ax + 1, ay + 1) = Bg Then SetPixel topic.hDC, ax + 1, ay + 1, BorderColor
                If GetPixel(topic.hDC, ax - 1, ay) = Bg Then SetPixel topic.hDC, ax - 1, ay, BorderColor
                If GetPixel(topic.hDC, ax, ay - 1) = Bg Then SetPixel topic.hDC, ax, ay - 1, BorderColor
                If GetPixel(topic.hDC, ax - 1, ay - 1) = Bg Then SetPixel topic.hDC, ax - 1, ay - 1, BorderColor
            
            End If
        Next ay
    Next ax

End Function

Public Function SaveFont()

    If Not DirExists(App.Path & "\Output\") Then MkDir App.Path & "\Output\"
    
    Open App.Path & "\Output\" & picEdit.FontName & "(" & Slider1.Value & ")" & ".txt" For Output As #1
        For i = 32 To 126
            If Not i = 34 Then
                Print #1, Characters(i).X & "," & Characters(i).Y & "," & Characters(i).Width & "," & MaxHeight & "," & Chr(34) & Characters(i).Name & Chr(34)
            End If
        Next i
    Close #1

    Dim img As New CMemoryDC
    
    img.Width = picEdit.ScaleWidth
    img.Height = picEdit.ScaleHeight
    BitBlt img.hDC, 0, 0, img.Width, img.Height, picEdit.hDC, 0, 0, vbSrcCopy
    SavePicture img.Picture, App.Path & "\Output\" & picEdit.FontName & "(" & Slider1.Value & ")" & ".bmp"

End Function

Private Sub Combo1_Change()
    QuickPreview
End Sub

Private Sub Combo1_Click()
    Combo1_Change
End Sub

Private Sub Command1_Click()
    SaveFont
End Sub

Private Sub Command2_Click()
    
    picTest.Cls
    RenderText picTest.hDC, Text1.Text
    picTest.Refresh
    
End Sub

Private Sub Command3_Click()
    cd1.ShowColor
    ColorKey = cd1.Color
    picBG.BackColor = ColorKey
End Sub

Private Sub Command4_Click()
    DrawFont
    
    picEdit.Left = 0
    picEdit.Top = 0
    
    If picEdit.ScaleWidth > picContainer.ScaleWidth Then
        scx.Max = picEdit.ScaleWidth - picContainer.ScaleWidth
        scx.Enabled = True
    Else
        scx.Enabled = False
    End If
    
    If picEdit.ScaleHeight > picContainer.ScaleHeight Then
        scy.Max = picEdit.ScaleHeight - picContainer.ScaleHeight
        scy.Enabled = True
    Else
        scy.Enabled = False
    End If
    
    Frame1.Visible = False
    Frame2.Visible = True
End Sub

Private Sub Command5_Click()
    cd1.ShowColor
    TextColor = cd1.Color
    picText.BackColor = TextColor
End Sub

Private Sub Command6_Click()
    cd1.ShowColor
    BorderColor = cd1.Color
    picBorder.BackColor = BorderColor
End Sub

Private Sub Command7_Click()
    Frame2.Visible = False
    Frame1.Visible = True
End Sub

Private Sub Form_Load()

    Me.Show
    ColorKey = RGB(255, 0, 255)
    TextColor = vbWhite
    For i = 0 To Screen.FontCount - 1
        Combo1.AddItem Screen.Fonts(i)
    Next i
    Combo1.ListIndex = 0
    
End Sub

Private Sub scx_Change()
    
    picEdit.Left = -scx.Value
    
End Sub

Private Sub scy_Change()

    picEdit.Top = -scy.Value
    
End Sub

Private Sub Slider1_Change()
    Slider1_Click
End Sub

Private Sub Slider1_Click()
    QuickPreview
End Sub
