module1.bas

联机手写汉字识别

X = X1
Y = Y1
If G_L_Flag = 8 Or G_L_Flag = 7 Then
    Flag_8 = -1
Else
    Flag_8 = 1
End If

D = Flag_8 * 2 * (Y2 - Y1) - (X2 - X1)

If G_L_Flag = 7 Then
    'Do While Y < Y2
    Do While X > X2
        If D >= 0 Then
            X = X - 1
            D = D - 2 * (Y2 - Y1)
        Else
            Y = Y + 1
            D = D - 2 * (X2 - X1)
        End If
        If A(Y, X) = 1 Then
            Key_B = Key_B + 1
        End If
        A(Y, X) = 1
            S = Y * Pic1_Width \ GRID_NO
            T = X * Pic1_Height \ GRID_NO
            U = (Y - 1) * Pic1_Width \ GRID_NO
            V = (X - 1) * Pic1_Height \ GRID_NO
            fMainForm.Picture1.Line (U, V)-(S, T), , BF
    Loop
Else
Do While X < X2
    If D >= 0 Then
        Y = Y + Flag_8 * 1
        D = D - 2 * (X2 - X1)
    Else
        X = X + 1
        D = D + 2 * Flag_8 * (Y2 - Y1)
    End If
    If G_L_Flag = 2 Then ''' Or G_L_Flag = 7 Then
       If A(Y, X) = 1 Then
            Key_B = Key_B + 1
       End If
       A(Y, X) = 1
            S = Y * Pic1_Width \ GRID_NO
            T = X * Pic1_Height \ GRID_NO
            U = (Y - 1) * Pic1_Width \ GRID_NO
            V = (X - 1) * Pic1_Height \ GRID_NO
            fMainForm.Picture1.Line (U, V)-(S, T), , BF
    Else
        If A(X, Y) = 1 Then
            Key_B = Key_B + 1
        End If
        A(X, Y) = 1
            S = X * Pic1_Width \ GRID_NO
            T = Y * Pic1_Height \ GRID_NO
            U = (X - 1) * Pic1_Width \ GRID_NO
            V = (Y - 1) * Pic1_Height \ GRID_NO
            fMainForm.Picture1.Line (U, V)-(S, T), , BF
    End If
Loop
End If
End Sub

Sub Grid_Line(ByVal X1 As Integer, ByVal Y1 As Integer, ByVal X2 As Integer, ByVal Y2 As Integer)
'Dim TEMP As Integer
'If X1 > X2 Then
'    TEMP = X1
'    X1 = X2
'    X2 = TEMP
'    TEMP = Y1
'    Y1 = Y2
'    Y2 = TEMP
'End If
If X1 <= X2 Then
    If Y1 <= Y2 Then
        If (Y2 - Y1) <= (X2 - X1) Then
            G_L_Flag = 1
            Call G_L_SUB(X1, Y1, X2, Y2)    ''1
        Else
            G_L_Flag = 2   ''2 & 7
            Call G_L_SUB(Y1, X1, Y2, X2)    '2
        End If
    Else
        If (-Y2 + Y1) <= (X2 - X1) Then
            G_L_Flag = 8
            Call G_L_SUB(X1, Y1, X2, Y2)  ''8//4
        Else
            G_L_Flag = 7   ''2 & 7
            Call G_L_SUB(Y1, X1, Y2, X2)  ''7
        End If
    End If
Else
    If Y2 <= Y1 Then
        If (Y1 - Y2) <= (X1 - X2) Then
            G_L_Flag = 1
            Call G_L_SUB(X2, Y2, X1, Y1)    ''1
        Else
            G_L_Flag = 2   ''2 & 7
            Call G_L_SUB(Y2, X2, Y1, X1)    '2
        End If
    Else
        If (-Y1 + Y2) <= (X1 - X2) Then
            G_L_Flag = 8
            Call G_L_SUB(X2, Y2, X1, Y1)  ''8//4
        Else
            G_L_Flag = 7   ''2 & 7
            Call G_L_SUB(Y2, X2, Y1, X1)  ''7
        End If
    End If
End If

End Sub
Sub MiZiGe()
    Dim tmpDstyle As Integer, tmpDwidth As Integer
    With fMainForm
        tmpDstyle = .Picture1.DrawStyle
        tmpDwidth = .Picture1.DrawWidth
        .Picture1.DrawStyle = 2
        .Picture1.DrawWidth = 1
        
        .Picture1.Line (0, 0)-(Pic1_Width, Pic1_Height)
        .Picture1.Line (0.5 * Pic1_Width, 0)-(0.5 * Pic1_Width, Pic1_Height)
        .Picture1.Line (0, 0.5 * Pic1_Height)-(Pic1_Width, 0.5 * Pic1_Height)
        .Picture1.Line (0, Pic1_Height)-(Pic1_Width, 0)
        
        .Picture1.DrawStyle = tmpDstyle
        .Picture1.DrawWidth = tmpDwidth
    End With
End Sub

Sub ExCharact()
    Dim Out_Elem As New CharactInfo
    Call Pic2_rfsh
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    With fMainForm
      If .TextOut.Text <> "" And Key_C <> "" Then
            Out_Elem.HanZi = .TextOut.Text
            Out_Elem.Key = Key_C
        Select Case Key_A
            Case 1
                Chara01.Add Out_Elem.Key, Out_Elem.HanZi
            Case 2
                Chara02.Add Out_Elem.Key, Out_Elem.HanZi
            Case 3
                Chara03.Add Out_Elem.Key, Out_Elem.HanZi
            Case 4
                Chara04.Add Out_Elem.Key, Out_Elem.HanZi
            Case 5
                Chara05.Add Out_Elem.Key, Out_Elem.HanZi
            Case 6
                Chara06.Add Out_Elem.Key, Out_Elem.HanZi
            Case 7
                Chara07.Add Out_Elem.Key, Out_Elem.HanZi
            Case 8
                Chara08.Add Out_Elem.Key, Out_Elem.HanZi
            Case 9
                Chara09.Add Out_Elem.Key, Out_Elem.HanZi
            Case 10
                Chara10.Add Out_Elem.Key, Out_Elem.HanZi
            Case 11
                Chara11.Add Out_Elem.Key, Out_Elem.HanZi
            Case 12
                Chara12.Add Out_Elem.Key, Out_Elem.HanZi
            Case 13
                Chara13.Add Out_Elem.Key, Out_Elem.HanZi
            Case 14
                Chara14.Add Out_Elem.Key, Out_Elem.HanZi
            Case 15
                Chara15.Add Out_Elem.Key, Out_Elem.HanZi
            Case 16
                Chara16.Add Out_Elem.Key, Out_Elem.HanZi
            Case Else:
        End Select
        
        Call OutText(Out_Elem, Key_A)
        .TextOut.Text = ""
      End If
    End With
    
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'    Call Init_Grid
End Sub

Sub HSPNT(ByVal X1 As Integer, ByVal Y1 As Integer, ByVal X2 As Integer, ByVal Y2 As Integer)

If Y2 > Y1 Then   ''SP
        If Abs(X2 - X1) / (Y2 - Y1) < Tan(10 * PI / 180) Then
            Key_C = Key_C & "S"
            Exit Sub
        End If
        If X2 < X1 And (X1 - X2) / (Y2 - Y1) < Tan(75 * PI / 180) Then
            Key_C = Key_C & "P"
            Exit Sub
        End If
End If

If X1 < X2 Then ''NHT
    If Abs(Y2 - Y1) / (X2 - X1) < Tan(20 * PI / 180) Then
        Key_C = Key_C & "H"
        Exit Sub
    Else
        If Y2 > Y1 And (Y2 - Y1) / (X2 - X1) > Tan(15 * PI / 180) Then
            Key_C = Key_C & "N"
            Exit Sub
        Else
            If Y2 < Y1 And (Y1 - Y2) / (X2 - X1) > Tan(15 * PI / 180) Then
                Key_C = Key_C & "T"
                Exit Sub
            End If
        End If
    End If
End If
    
Key_C = Key_C & "X" 'X  uncertain maybe anything
End Sub
Function ReSemble(ByVal Key_Extract As String, ByVal Key_Store As String) As Single
Dim K As Integer
Dim S1 As String, S2 As String
Dim D As Single
D = 0#

For K = 1 To Key_A
    S1 = Mid$(Key_Extract, K, 1)
    S2 = Mid$(Key_Store, K, 1)
    
    If S1 = S2 Or S1 = "X" Or S2 = "X" Then
        D = D + 1#
    Else
        If (S1 = "H" And (S2 = "N" Or S2 = "T")) Or _
           (S2 = "H" And (S1 = "N" Or S1 = "T")) Or _
           (S1 = "S" And (S2 = "N" Or S2 = "P")) Or _
           (S2 = "S" And (S1 = "N" Or S1 = "P")) Then
            D = D + 0.6
        End If
    End If
Next K
D = D / Key_A
ReSemble = D
'          H   S   P   N   T   X
'         _________________________
'       H | 1 | 0 | 0 |0.6|0.6| 1 |
'         ------------------------
'       S | 0 | 1 |0.6|0.6| 0 | 1 |
'         ------------------------
'       P | 0 |0.6| 1 | 0 | 0 | 1 |
'         ------------------------
'       N |0.6|0.6| 0 | 1 | 0 | 1 |
'         ------------------------
'       T |0.6| 0 | 0 | 0 | 1 | 1 |
'         ------------------------
'       X | 1 | 1 | 1 | 1 | 1 | 1 |
'         -------------------------
'       d = r(i, j)
'       D = (d1+d2+...+dm)/m
'       D = Max (Di) AND D > Resemble_Extent
End Function

Sub OutText(ByVal Out_Elem As CharactInfo, ByVal KeyA As Integer)
Dim fso As New FileSystemObject
Dim Ff As File
Dim Ts As TextStream
Dim Str As String
Select Case KeyA        '=Len(Out_Elem.Key)
    Case 1:     Str = "1"
    Case 2:     Str = "2"
    Case 3:     Str = "3"
    Case 4:     Str = "4"
    Case 5:     Str = "5"
    Case 6:     Str = "6"
    Case 7:     Str = "7"
    Case 8:     Str = "8"
    Case 9:     Str = "9"
    Case 10:     Str = "A"
    Case 11:     Str = "B"
    Case 12:     Str = "C"
    Case 13:     Str = "D"
    Case 14:     Str = "E"
    Case 15:     Str = "F"
    Case 16:     Str = "G"
End Select
Str = Str & Out_Elem.HanZi & Out_Elem.Key

If fso.FileExists("c:\character.txt") = False Then
    fso.CreateTextFile ("c:\character.txt")
End If
Set Ff = fso.GetFile("c:\character.txt")
Set Ts = Ff.OpenAsTextStream(ForAppending)
    Ts.WriteLine Str
    Ts.Close
End Sub

Sub Init_Col()
Dim fso As New FileSystemObject:    Dim Ff As File
Dim Ts As TextStream:               Dim Str As String
Dim S1_HanZi As String, S2_KeyC As String

If fso.FileExists("c:\character.txt") = False Then
    fso.CreateTextFile ("c:\character.txt")
End If
Set Ff = fso.GetFile("c:\character.txt")
Set Ts = Ff.OpenAsTextStream(ForReading)

Do While Not Ts.AtEndOfStream
        Str = Ts.ReadLine
        S1_HanZi = Mid$(Str, 2, 1)
        Select Case Left(Str, 1)
           Case "1"
                S2_KeyC = Mid$(Str, 3, 1)
                Chara01.Add S2_KeyC, S1_HanZi
           Case "2":
                S2_KeyC = Mid$(Str, 3, 2)
                Chara02.Add S2_KeyC, S1_HanZi
           Case "3"
                S2_KeyC = Mid$(Str, 3, 3)
                Chara03.Add S2_KeyC, S1_HanZi
           Case "4"
                S2_KeyC = Mid$(Str, 3, 4)
                Chara04.Add S2_KeyC, S1_HanZi
           Case "5"
                S2_KeyC = Mid$(Str, 3, 5)
                Chara05.Add S2_KeyC, S1_HanZi
           Case "6":
                S2_KeyC = Mid$(Str, 3, 6)
                Chara06.Add S2_KeyC, S1_HanZi
           Case "7"
                S2_KeyC = Mid$(Str, 3, 7)
                Chara07.Add S2_KeyC, S1_HanZi
           Case "8"
                S2_KeyC = Mid$(Str, 3, 8)
                Chara08.Add S2_KeyC, S1_HanZi
           Case "9":
                S2_KeyC = Mid$(Str, 3, 9)
                Chara09.Add S2_KeyC, S1_HanZi
            Case "A"
                S2_KeyC = Mid$(Str, 3, 10)
                Chara10.Add S2_KeyC, S1_HanZi
            Case "B"
                S2_KeyC = Mid$(Str, 3, 11)
                Chara11.Add S2_KeyC, S1_HanZi
            Case "C"
                S2_KeyC = Mid$(Str, 3, 12)
                Chara12.Add S2_KeyC, S1_HanZi
            Case "D"
                S2_KeyC = Mid$(Str, 3, 13)
                Chara13.Add S2_KeyC, S1_HanZi
            Case "E"
                S2_KeyC = Mid$(Str, 3, 14)
                Chara14.Add S2_KeyC, S1_HanZi
            Case "F"
                S2_KeyC = Mid$(Str, 3, 15)
                Chara15.Add S2_KeyC, S1_HanZi
            Case "G"
                S2_KeyC = Mid$(Str, 3, 16)
                Chara16.Add S2_KeyC, S1_HanZi
        End Select
Loop
    Ts.Close
End Sub
Sub ConcaDi(ByVal HanZi As String, ByVal Key As String)
Dim L As Integer
Dim NotRepeat As Boolean
Dim Hanzi_Temp As String

NotRepeat = True
With fMainForm
    For L = 0 To MaxId
        Hanzi_Temp = .Concadidate(L).Caption
        If StrComp(Hanzi_Temp, HanZi, vbTextCompare) = 0 Then
            NotRepeat = False
        End If
    Next L
    If NotRepeat Then
        .Concadidate(MaxId).Caption = HanZi
        '.Concadidate(MaxId).Visible = True
        CharaOut.Add Key, HanZi
        MaxId = MaxId + 1
        Load .Concadidate(MaxId)
    End If
End With

End Sub
Sub Init_ConcaDi()
    Do While MaxId > 0
        Unload fMainForm.Concadidate(MaxId)
        MaxId = MaxId - 1
    Loop
    fMainForm.Concadidate(0).Caption = ""
    fMainForm.Concadidate(0).Visible = False
End Sub