汉字代码.frm

字库代码提取

Dim HzArr(1 To 32) As String
Dim HzSpArr(1 To 64) As String
Dim HzWparr(1 To 64) As String
Dim i, j, k, m, n

On Error GoTo endJq
If txtHz = "" Then
MsgBox "没有填写汉字！", vbOKOnly + vbInformation, "提示"
Exit Sub
ElseIf Len(txtHz.Text) >= 2 Then
MsgBox "只能检取一个汉字！", vbOKOnly + vbExclamation, "提示"
txtHz.SetFocus
txtHz.SelStart = 0
txtHz.SelLength = Len(txtHz.Text)
Exit Sub
ElseIf Asc(txtHz.Text) >= 0 And Asc(txtHz.Text) < 128 Then
MsgBox "请输入汉字！", vbOKOnly + vbExclamation, "提示"
txtHz.SetFocus
txtHz.SelStart = 0
txtHz.SelLength = Len(txtHz.Text)
Exit Sub
Else
End If

Screen.MousePointer = 13
txtHpp = ""
txtSpp = ""
txtWpp = ""
txtHpy = ""
txtSpy = ""
txtTpy = ""
txtDz.Text = ""
txtHp.Text = ""
txtSp.Text = ""
txtLp.Text = ""
Jnm = Hex(Asc(txtHz.Text))    '获取机内码
Qwm = Hex(Asc(txtHz.Text) - &HA0A0)   '获取区位码

If Len(Qwm) = 3 Then
Qm = Mid(Qwm, 1, 1)  '区码
Wm = Mid(Qwm, 2, 2)  '位码
ElseIf Len(Qwm) = 4 Then
Qm = Mid(Qwm, 1, 2)  '区码
Wm = Mid(Qwm, 3, 2)  '位码
Else
Exit Sub
End If
JqWz = 32 * ((CLng("&H" & Qm) - 1) * 94 + (CLng("&H" & Wm) - 1))   '获取起始位置
'对于CCLIB.DOT汉字库可用下列方法取起始位置。当然读取文件为CCLIB.DOT。
'If CLng("&H" & Qm) >= 1 And CLng("&H" & Qm) <= 9 Then
'JqWz = 32 * ((CLng("&H" & Qm) - 1) * 94 + (CLng("&H" & Wm) - 1))
'ElseIf CLng("&H" & Qm) >= 16 And CLng("&H" & Qm) <= 87 Then
'JqWz = 32 * ((CLng("&H" & Qm) - 7) * 94 + (CLng("&H" & Wm) - 1))  '有些杂志有误，将7误为位码。
'Else
'Exit Sub
'End If
DoEvents

' 打开汉字库文件分配给数组
FileName = Fname
fnum = FreeFile
Open Fname For Binary As #fnum
num_bytes = LOF(fnum)
ReDim bytes(1 To num_bytes)
Get #fnum, , bytes
Close fnum

For i = 1 To 32
bitHz = Hex(bytes(JqWz + i))
   If Len(bitHz) = 1 Then
   bitHz = "0" & bitHz
   End If
HzArr(i) = bitHz    '汉字的BCD码数组
txtHpp = txtHpp & bitHz & "H "     '横排
Next i


For i = 1 To 31
If Left(HzArr(i), 1) <= &H9 Then
ymHz = HzArr(i)
Else
ymHz = "0" & HzArr(i)
End If
txtHpy = txtHpy & ymHz & "H,"
Next i
If Left(HzArr(32), 1) <= &H9 Then
ymHz = HzArr(32)
Else
ymHz = "0" & HzArr(32)
End If
txtHpy = txtHpy & ymHz & "H"


'竖排处理
    For j = 1 To 4
    HzSpArr(j) = HexBcd(IntByte(Left(HzArr(8 * j - 7), 1), 4), IntByte(Left(HzArr(8 * j - 5), 1), 4), IntByte(Left(HzArr(8 * j - 3), 1), 4), IntByte(Left(HzArr(8 * j - 1), 1), 4))
    HzSpArr(j + 16) = HexBcd(IntByte(Right(HzArr(8 * j - 7), 1), 4), IntByte(Right(HzArr(8 * j - 5), 1), 4), IntByte(Right(HzArr(8 * j - 3), 1), 4), IntByte(Right(HzArr(8 * j - 1), 1), 4))
    HzSpArr(j + 32) = HexBcd(IntByte(Left(HzArr(8 * j - 6), 1), 4), IntByte(Left(HzArr(8 * j - 4), 1), 4), IntByte(Left(HzArr(8 * j - 2), 1), 4), IntByte(Left(HzArr(8 * j), 1), 4))
    HzSpArr(j + 48) = HexBcd(IntByte(Right(HzArr(8 * j - 6), 1), 4), IntByte(Right(HzArr(8 * j - 4), 1), 4), IntByte(Right(HzArr(8 * j - 2), 1), 4), IntByte(Right(HzArr(8 * j), 1), 4))
    Next j
    For j = 1 To 4
    HzSpArr(j + 4) = HexBcd(IntByte(Left(HzArr(8 * j - 7), 1), 3), IntByte(Left(HzArr(8 * j - 5), 1), 3), IntByte(Left(HzArr(8 * j - 3), 1), 3), IntByte(Left(HzArr(8 * j - 1), 1), 3))
    HzSpArr(j + 20) = HexBcd(IntByte(Right(HzArr(8 * j - 7), 1), 3), IntByte(Right(HzArr(8 * j - 5), 1), 3), IntByte(Right(HzArr(8 * j - 3), 1), 3), IntByte(Right(HzArr(8 * j - 1), 1), 3))
    HzSpArr(j + 36) = HexBcd(IntByte(Left(HzArr(8 * j - 6), 1), 3), IntByte(Left(HzArr(8 * j - 4), 1), 3), IntByte(Left(HzArr(8 * j - 2), 1), 3), IntByte(Left(HzArr(8 * j), 1), 3))
    HzSpArr(j + 52) = HexBcd(IntByte(Right(HzArr(8 * j - 6), 1), 3), IntByte(Right(HzArr(8 * j - 4), 1), 3), IntByte(Right(HzArr(8 * j - 2), 1), 3), IntByte(Right(HzArr(8 * j), 1), 3))
    Next j
    For j = 1 To 4
    HzSpArr(j + 8) = HexBcd(IntByte(Left(HzArr(8 * j - 7), 1), 2), IntByte(Left(HzArr(8 * j - 5), 1), 2), IntByte(Left(HzArr(8 * j - 3), 1), 2), IntByte(Left(HzArr(8 * j - 1), 1), 2))
    HzSpArr(j + 24) = HexBcd(IntByte(Right(HzArr(8 * j - 7), 1), 2), IntByte(Right(HzArr(8 * j - 5), 1), 2), IntByte(Right(HzArr(8 * j - 3), 1), 2), IntByte(Right(HzArr(8 * j - 1), 1), 2))
    HzSpArr(j + 40) = HexBcd(IntByte(Left(HzArr(8 * j - 6), 1), 2), IntByte(Left(HzArr(8 * j - 4), 1), 2), IntByte(Left(HzArr(8 * j - 2), 1), 2), IntByte(Left(HzArr(8 * j), 1), 2))
    HzSpArr(j + 56) = HexBcd(IntByte(Right(HzArr(8 * j - 6), 1), 2), IntByte(Right(HzArr(8 * j - 4), 1), 2), IntByte(Right(HzArr(8 * j - 2), 1), 2), IntByte(Right(HzArr(8 * j), 1), 2))
    Next j
    For j = 1 To 4
    HzSpArr(j + 12) = HexBcd(IntByte(Left(HzArr(8 * j - 7), 1), 1), IntByte(Left(HzArr(8 * j - 5), 1), 1), IntByte(Left(HzArr(8 * j - 3), 1), 1), IntByte(Left(HzArr(8 * j - 1), 1), 1))
    HzSpArr(j + 28) = HexBcd(IntByte(Right(HzArr(8 * j - 7), 1), 1), IntByte(Right(HzArr(8 * j - 5), 1), 1), IntByte(Right(HzArr(8 * j - 3), 1), 1), IntByte(Right(HzArr(8 * j - 1), 1), 1))
    HzSpArr(j + 44) = HexBcd(IntByte(Left(HzArr(8 * j - 6), 1), 1), IntByte(Left(HzArr(8 * j - 4), 1), 1), IntByte(Left(HzArr(8 * j - 2), 1), 1), IntByte(Left(HzArr(8 * j), 1), 1))
    HzSpArr(j + 60) = HexBcd(IntByte(Right(HzArr(8 * j - 6), 1), 1), IntByte(Right(HzArr(8 * j - 4), 1), 1), IntByte(Right(HzArr(8 * j - 2), 1), 1), IntByte(Right(HzArr(8 * j), 1), 1))
    Next j
For k = 1 To 32
txtSpp = txtSpp & HzSpArr(2 * k - 1) & HzSpArr(2 * k) & "H "    '竖排
Next k

For k = 1 To 31
  If ("&H" & HzSpArr(2 * k - 1)) <= &H9 Then
  ymHz = HzSpArr(2 * k - 1) & HzSpArr(2 * k) & "H,"
  Else
  ymHz = "0" & HzSpArr(2 * k - 1) & HzSpArr(2 * k) & "H,"
  End If
txtSpy = txtSpy & ymHz
Next k
If ("&H" & HzSpArr(2 * 32 - 1)) <= &H9 Then
ymHz = HzSpArr(2 * 32 - 1) & HzSpArr(2 * 32) & "H"
Else
ymHz = "0" & HzSpArr(2 * 32 - 1) & HzSpArr(2 * 32) & "H"
End If
txtSpy = txtSpy & ymHz

'排列点阵
For i = 1 To 16
If i = 16 Then
txtDz.Text = txtDz.Text & strFormat(Left(HzArr(2 * i - 1), 1)) & strFormat(Right(HzArr(2 * i - 1), 1)) & strFormat(Left(HzArr(2 * i), 1)) & strFormat(Right(HzArr(2 * i), 1))
Else
txtDz.Text = txtDz.Text & strFormat(Left(HzArr(2 * i - 1), 1)) & strFormat(Right(HzArr(2 * i - 1), 1)) & strFormat(Left(HzArr(2 * i), 1)) & strFormat(Right(HzArr(2 * i), 1)) & vbCrLf
End If
Next i

'我厂排法处理
  For m = 1 To 16
  HzWparr(4 * m - 3) = ChangeBCD(HzSpArr(4 * m))
  HzWparr(4 * m - 2) = ChangeBCD(HzSpArr(4 * m - 1))
  HzWparr(4 * m - 1) = ChangeBCD(HzSpArr(4 * m - 2))
  HzWparr(4 * m) = ChangeBCD(HzSpArr(4 * m - 3))
  Next m
For n = 1 To 16   '前16个
txtWpp = txtWpp & HzWparr(4 * n - 1) & HzWparr(4 * n) & "H "
Next n
For n = 1 To 16  '后16个
txtWpp = txtWpp & HzWparr(4 * n - 3) & HzWparr(4 * n - 2) & "H "    '我厂排法
Next n

For n = 1 To 16
  If ("&H" & HzWparr(4 * n - 1)) <= 9 Then
  ymHz = HzWparr(4 * n - 1) & HzWparr(4 * n) & "H,"
  Else
  ymHz = "0" & HzWparr(4 * n - 1) & HzWparr(4 * n) & "H,"
  End If
txtTpy = txtTpy & ymHz
Next n
For n = 1 To 15
  If ("&H" & HzWparr(4 * n - 3)) <= 9 Then
  ymHz = HzWparr(4 * n - 3) & HzWparr(4 * n - 2) & "H,"
  Else
  ymHz = "0" & HzWparr(4 * n - 3) & HzWparr(4 * n - 2) & "H,"
  End If
txtTpy = txtTpy & ymHz
Next n
If ("&H" & HzWparr(4 * 16 - 3)) <= 9 Then
ymHz = HzWparr(4 * 16 - 3) & HzWparr(4 * 16 - 2) & "H"
Else
ymHz = "0" & HzWparr(4 * 16 - 3) & HzWparr(4 * 16 - 2) & "H"
End If
txtTpy = txtTpy & ymHz

If optHpDm.Value Then
txtHp.Text = txtHpp
ElseIf optHpYm.Value Then
txtHp.Text = txtHpy
End If
If optSPDm.Value Then
txtSp.Text = txtSpp
ElseIf optSPYm.Value Then
txtSp.Text = txtSpy
End If
If optTPDm.Value Then
txtLp.Text = txtWpp
ElseIf optTPYm.Value Then
txtLp.Text = txtTpy
End If

txtHz.SetFocus
txtHz.SelStart = 0
txtHz.SelLength = Len(txtHz.Text)
Screen.MousePointer = 0
Exit Sub
endJq:
End Sub



Private Sub Form_Load()
Dim PassS
Dim PassE
Dim PassQ
MyPath = App.Path & "\"
Fname = MyPath & "hzk16"
txtHz.SelStart = Len(txtHz.Text)
MakeWindow Me
 'AlwaysOnTop Me, True
'检查权限
'SaveSetting "11101110", "11001100", "11111111", "00"
PassS = GetSetting("11101110", "11001100", "11111111", "00")
If CLng(PassS) = 0 Then
PassQ = InputBox("请输入权限密码！" & vbCrLf & "请向作者索取！", "密码")
  If PassQ = "tllg" Then
  SaveSetting "11101110", "11001100", "11111111", "61"
  GoTo Patch
  Else
  MsgBox "密码不正确！", vbOKOnly, "提示"
  GoTo Try
  End If
End If

Try:
If CLng(PassS) = 0 Then
MsgBox "你可以使用30次！", vbOKOnly, "提示"
 PassE = CStr(Hex(CLng(PassS) + 1))
 SaveSetting "11101110", "11001100", "11111111", PassE
ElseIf CLng(PassS) >= 1 And CLng(PassS) <= 30 Then
 If (CLng(PassS) + 1) <= 9 Then
 PassE = "0" & CStr(CLng(PassS) + 1)
 Else
 PassE = CStr(CLng(PassS) + 1)
 End If
 SaveSetting "11101110", "11001100", "11111111", PassE
ElseIf CLng(PassS) = 31 Then
 PassE = CStr(CLng(PassS) + 1)
 SaveSetting "11101110", "11001100", "11111111", PassE
 MsgBox "你使用还剩1次！", vbOKOnly, "提示"
ElseIf CLng(PassS) = 32 Then
 PassE = CStr(CLng(PassS) + 1)
 SaveSetting "11101110", "11001100", "11111111", PassE
ElseIf CLng(PassS) >= 33 And CLng(PassS) <= 60 Then
MsgBox "你使用已超过30次！", vbOKOnly, "提示"
PassQ = InputBox("请输入权限密码！" & vbCrLf & "请向作者索取！", "密码")
  If PassQ = "tllg" Then
  SaveSetting "11101110", "11001100", "11111111", "61"
  GoTo Patch
  Else
  End
  End If
Else

End If

Patch:
optHpDm.Value = True
optSPDm.Value = True
optTPDm.Value = True

cmdOK_Click
Screen.MousePointer = 0
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If MsgBox("确定退出吗？", vbExclamation + vbYesNo, "询问") = vbYes Then
CloseBool = True
End
Else
CloseBool = False
End If

If CloseBool Then
Cancel = False
Else
Cancel = True
End If
End Sub

Private Sub imgTitleClose_Click()
If MsgBox("确定退出吗？", vbExclamation + vbYesNo, "询问") = vbYes Then
CloseBool = True
End
Else
CloseBool = False
End If
End Sub

Private Sub imgTitleHelp_Click()
'    MsgBox "You can insert code here for loading a help file."
frmAbout.Show vbModal
End Sub

Private Sub optHpDm_Click()
txtHp.Text = txtHpp
End Sub

Private Sub optHpYm_Click()
txtHp.Text = txtHpy
End Sub

Private Sub optSPDm_Click()
txtSp.Text = txtSpp
End Sub
Private Sub imgTitleLeft_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    DoDrag Me
End Sub

Private Sub imgTitleMain_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    DoDrag Me
End Sub

Private Sub imgTitleMinimize_Click()
    Me.WindowState = 1
End Sub

Private Sub imgTitleRight_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    DoDrag Me
End Sub

Private Sub lblTitle_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    DoDrag Me
End Sub
Private Sub optSPYm_Click()
txtSp.Text = txtSpy
End Sub

Private Sub optTPDm_Click()
txtLp.Text = txtWpp
End Sub

Private Sub optTPYm_Click()
txtLp.Text = txtTpy
End Sub

Private Sub txtDz_KeyPress(KeyAscii As Integer)
KeyAscii = 0
End Sub

Private Sub txtHp_KeyPress(KeyAscii As Integer)
KeyAscii = 0
End Sub

Private Sub txtHz_KeyPress(KeyAscii As Integer)
If KeyAscii = vbKeyReturn Then
cmdOK_Click
End If
End Sub

Private Sub txtLp_KeyPress(KeyAscii As Integer)
KeyAscii = 0
End Sub

Private Sub txtSp_KeyPress(KeyAscii As Integer)
KeyAscii = 0
End Sub

Private Sub labEmail_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
     labEmail.ForeColor = &H800080
End Sub

Private Sub labEmail_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    labEmail.ForeColor = &H800000
    ShellExecute hwnd, "open", "mailto:" + labEmail.Caption, vbNullString, vbNullString, SW_SHOW
End Sub

Private Sub labHomepage_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
     labHomepage.ForeColor = &H800080
End Sub

Private Sub labHomepage_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    labHomepage.ForeColor = &H800000
    ShellExecute hwnd, "open", labHomepage.Caption, vbNullString, vbNullString, SW_SHOW
End Sub