form1.frm

字模程序 字模程序 字模程序 字模程序

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   5010
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   9585
   LinkTopic       =   "Form1"
   ScaleHeight     =   5010
   ScaleWidth      =   9585
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton Command1 
      Caption         =   "字模"
      Height          =   615
      Left            =   1200
      TabIndex        =   2
      Top             =   4200
      Width           =   2295
   End
   Begin VB.TextBox Text2 
      Height          =   2055
      Left            =   840
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   1
      Top             =   1680
      Width           =   6975
   End
   Begin VB.TextBox Text1 
      Height          =   1095
      Left            =   840
      TabIndex        =   0
      Top             =   240
      Width           =   6855
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'the size of the result array
Private Const row_1 = 15
Private Const col_1 = row_1
'either the point should be HighLight or no
Private m_bHighLight(row_1, col_1) As Boolean



'calculate which points should be HighLight, for Chinese.
Private Sub CalcPointCn(ByVal strText As String)
On Error Resume Next

    If Len(strText) = 0 Then Exit Sub
    If Asc(strText) >= 0 Then Exit Sub
    
    strText = Left(strText, 1)
    
    Dim hzkPath As String
    'hzkPath = App.Path + "\" + "HZK16"
    'Open hzkPath For Binary Access Read As #1
    'Open App.Path + "\HZK16" For Binary As #hzkPath
    hzkPath = App.Path & IIf(Len(App.Path) = 3, "", "\") & "HZK16.dat"
    
    If Dir(hzkPath) = "" Then
        MsgBox "未能找到汉字库，请检查后重试！", vbCritical Or vbOKOnly
        Exit Sub
    End If
    
    Dim i As Long, l_QuHao As Long, l_WeiHao As Long
    i = Asc(strText) + 65536
    '第一个字节减去 0xA0,然后再减1,减1是因为字库计数从零开始.位号相同
    l_QuHao = i \ 256 - 160 - 1
    l_WeiHao = i Mod 256 - 160 - 1
    
    '接收用于表示一个汉字的32个字节
    Dim byt(1 To 32) As Byte
    
On Error GoTo ErrHandle

    Open hzkPath For Binary As #1
        Get #1, (94 * l_QuHao + l_WeiHao) * 32 + 1, byt
    Close #1
    
    Dim j As Long
    
    For i = 1 To 32 Step 2
        
        For j = 7 To 0 Step -1
        
            If byt(i) And 2 ^ j Then
                
                m_bHighLight(i \ 2, 7 - j) = True
            
            Else
                
                m_bHighLight(i \ 2, 7 - j) = False
            
            End If
            
        Next
        
        For j = 7 To 0 Step -1
        
            If byt(i + 1) And 2 ^ j Then
                
                m_bHighLight(i \ 2, 15 - j) = True
            
            Else
            
                m_bHighLight(i \ 2, 15 - j) = False
            
            End If
        
        Next
    
    Next
    'Text2.Text = byt
    For i = 1 To 32
    If byt(i) > 15 Then
        Text2.Text = Text2.Text + CStr(Hex(byt(i))) + " "
        Else
        Text2.Text = Text2.Text + "0" + CStr(Hex(byt(i))) + " "
    End If
Next i

Exit Sub
ErrHandle:
    Close #1
    MsgBox "错误代号:" & Err.Number & vbCrLf & vbCrLf & "错误描述:" & Err.Description, vbInformation Or vbOKOnly, "错误 - 提取字模"
End Sub

Private Sub Command1_Click()
CalcPointCn (Text1.Text)
'Dim i As Integer

End Sub