Private PocetPismen
Private Pole() As String

Private Sub Form_Load()
    Show
    Pic.Move -Width
End Sub

Private Sub NP_Click()
    cd.Flags = cdlCFEffects Or cdlCFBoth
    cd.ShowFont
    Dim s As String, a As Integer: s = ""
    Dim b As Integer
    'For a = 1 To PocetPismen: s = s & Chr(64 + a): Next
    Ps.FontName = cd.FontName
    Ps.FontSize = cd.FontSize
    Ps.FontBold = cd.FontBold
    Ps.FontItalic = cd.FontItalic
    Ps.FontStrikethru = cd.FontStrikethru
    Ps.FontUnderline = cd.FontUnderline
    
    Ls.FontName = cd.FontName
    Ls.FontSize = cd.FontSize
    Ls.FontBold = cd.FontBold
    Ls.FontItalic = cd.FontItalic
    Ls.FontStrikethru = cd.FontStrikethru
    Ls.FontUnderline = cd.FontUnderline
    '
        Pis.Enabled = True
        Exit Sub
    '
    Ps.Visible = True
    Ps.Cls
    Li.Clear
    For a = 1 To 1 'PocetPismen
        s = s & Chr(64 + a)
        Ls.Caption = s
        Li.AddItem Ls.Width
    Next
    Ps.Print s
    For a = 0 To Li.ListCount - 1
        b = Li.List(a) * Screen.TwipsPerPixelX
        Ps.Line (b, 0)-(b, Ps.Height * Screen.TwipsPerPixelY), 255
    Next
    Ps.Visible = False
    SavePicture Ps.Image, App.Path & "\Obr.bmp"
    Shell "mspaint " & App.Path & "\Obr.bmp", vbMinimizedFocus
End Sub

Private Sub Otevri_Click()
    With cd
        .FileName = ""
        .ShowOpen
        If .FileName = "" Then Exit Sub
    End With
    Pi.Picture = LoadPicture(cd.FileName)
    Pic.Picture = Pi.Picture
    Preved.Enabled = True
    Pis.Enabled = True
End Sub

Private Sub Pis_Click()
    'Prev 2
    Form2.Show 1
    PocetPismen = Len(Pismn.Text)
    Dim i As Integer
    Dim a As Integer, b As Integer, c As Integer, d As Integer
    Dim ODY As Integer: ODY = Ps.Height
    Dim ODX As Integer
    ReDim Pole(1 To 100, 1 To PocetPismen)
    Dim Vyska As Integer: Vyska = 0
    Ps.Visible = True
    Dim z As String * 1
    For i = 1 To PocetPismen
        ODX = 0
        z = Mid(Pismn.Text, i, 1)
        Ps.Cls
        Ps.Print " " & z
        Ls.Caption = " " & z
        Pi.Picture = Ps.Image
        For b = 1 To Ls.Width * 2
            For a = 1 To Ls.Height * 2
                If Pi.Point(b, a) <> 16777215 Then
                    If ODX = 0 Then ODX = b
                    If i = 1 And a < ODY Then ODY = a
                End If
            Next
        Next
        For b = 1 To 100
            Pole(b, i) = "Pismeno[" & b & "]:='"
        Next
        For a = ODY To ODY + Ls.Height + Screen.TwipsPerPixelY * 1
            For b = ODX To ODX + Ls.Width + Screen.TwipsPerPixelX * 1
                If Pi.Point(b, a) <> 16777215 Then
                    If b < 10 Then
                        Pole(a - ODY + 1, i) = Pole(a - ODY + 1, i) & "0" & b
                    Else
                        Pole(a - ODY + 1, i) = Pole(a - ODY + 1, i) & b
                    End If
                    If a - ODY + 1 > Vyska Then Vyska = a - ODY + 1
                End If
            Next
        Next
    Next
    Ps.Visible = False
    Pi.Picture = LoadPicture("")
    Preved.Enabled = False
    Uloz Vyska - 1
End Sub

Private Sub Preved_Click()
    Prev 0
End Sub

Private Sub Prev(X As Byte)
    With cd
        .FileName = ""
        .ShowSave
        If .FileName = "" Then Exit Sub
    End With
    Dim i As Integer, o As Integer, a As Integer, b As Integer
    Dim Jake As Byte, Od As Integer
    i = Pic.Width
    o = Pic.Height
    If i > 640 Then i = 640: If o > 480 Then o = 480
    Dim Barva As OLE_COLOR, s As String: s = ""
    Dim d As Byte
    If X = 1 Then ReDim Pole(1 To o, 1 To PocetPismen)
    'Pole(a,b):
    'a - číslo řádky
    'b - číslo písmene
    For a = 1 To o 'Y
        If X = 1 Then
            For b = 1 To PocetPismen
                Pole(a, b) = "Pismeno[" & a & "]:='"
            Next
        End If
        Jake = 1
        Od = 0
        For b = 1 To i 'X
            Barva = Pi.Point(b - 1, a - 1)
            If X = 0 Then
            Select Case Barva
                Case 0: d = 0
                Case 16777215: d = 15
                Case 8421504: d = 8
                Case 12632256: d = 7
                Case 255: d = 12
                Case 128: d = 4
                Case 65535: d = 14
                Case 32896: d = 6
                Case 65280: d = 10
                Case 32768: d = 2
                Case 8421376: d = 3
                Case 16776960: d = 11
                Case 16711680: d = 9
                Case 8388608: d = 1
                Case 16711935: d = 13
                Case 8388736: d = 5
            End Select
            s = s & Chr(d + 65)
            End If
        Next
    Next
    If X = 0 Then
        RB.Text = s
        RB.SaveFile cd.FileName, rtfText
        MsgBox ("Provedeno...")
    End If
End Sub


Private Sub Uloz(o As Integer)
    With cd
        .Flags = Empty
        .FileName = ""
        .ShowSave
        If .FileName = "" Then Exit Sub
    End With
    Dim s As String
    Dim a As Integer, b As Integer
        s = "Unit " & cd.FileTitle & ";" & vbCrLf
        s = s & "Interface" & vbCrLf & "Uses Graph;" & vbCrLf
        s = s & "Const Velikost = " & o & ";" & vbCrLf
        s = s & "Var Pismeno:array[1..Velikost] of string;" & vbCrLf
        s = s & "Procedure PrepniPismeno(X:integer);" & vbCrLf
        s = s & "Procedure NapisText(X,Y:integer;Text:string;M:byte);" & vbCrLf
        s = s & "Implementation" & vbCrLf
        s = s & "Procedure PrepniPismeno(X:integer);" & vbCrLf
        s = s & "Begin" & vbCrLf
        s = s & "Case X Of" & vbCrLf
        For b = 1 To PocetPismen
            s = s & Asc(Mid(Pismn.Text, b, 1)) & ": Begin" & vbCrLf
            For a = 1 To o
                s = s & "      " & Pole(a, b) & "';" & vbCrLf
            Next
            s = s & String(Len(Str(b)) + 1, " ") & "End;" & vbCrLf
        Next
        s = s & "End;" & vbCrLf
        s = s & "End;" & vbCrLf
        s = s & "Procedure NapisText(X,Y:integer;Text:string;M:byte);" & vbCrLf
        s = s & TT.Text & vbCrLf
        s = s & "Begin End."
        RB.Text = s
        RB.SaveFile cd.FileName & ".pas", rtfText
        MsgBox ("Provedeno...")
End Sub

Private Zna(0 To 6) As String

Private Sub Form_Load()
    Dim i As Integer
    For i = 0 To 5
        Zna(i) = ""
    Next
    For i = 1 To 26
        Zna(0) = Zna(0) + Chr(i + 64)
        Zna(1) = Zna(1) + Chr(i + 96)
    Next
    Zna(2) = "0123456789"
    Zna(3) = ".,;:?!-"
    Zna(4) = "ÁÉÍÝÓÚŮČĎĚŇŘŠŤŽ"
    Zna(5) = "áéíýóúůčďěňřšťž"
    Zna(6) = "+-*/\<>[](){}&#_=@%^$'" + Chr(34)
    Ch_Click (0)
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Zavri_Click
End Sub

Private Sub Ch_Click(Index As Integer)
    Dim i As Integer
    Pismn.Text = ""
    For i = 0 To Ch.Count - 1
        If Ch(i).Value = 1 Then Pismn.Text = Pismn.Text + Zna(i)
    Next
End Sub

Private Sub Zavri_Click()
    If Left(Pismn.Text, 1) <> "|" Then Pismn.Text = "|" + Pismn.Text
    If Len(Pismn.Text) = 0 Then Pismn.Text = "A"
    Form1.Pismn.Text = Pismn.Text
    Hide
End Sub