form1.frm

汉字取模VB源码,可以分析出汉字的结构,从而为实现LED上传提供方便

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   3000
   ClientLeft      =   6975
   ClientTop       =   3615
   ClientWidth     =   6615
   LinkTopic       =   "Form1"
   ScaleHeight     =   3000
   ScaleMode       =   0  'User
   ScaleWidth      =   6615
   Begin VB.TextBox Text3 
      Height          =   1335
      Left            =   2400
      MultiLine       =   -1  'True
      TabIndex        =   3
      Text            =   "Form1.frx":0000
      Top             =   120
      Width           =   4095
   End
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   615
      Left            =   480
      TabIndex        =   2
      Top             =   1920
      Width           =   1455
   End
   Begin VB.TextBox Text2 
      Height          =   1095
      Left            =   2400
      MultiLine       =   -1  'True
      TabIndex        =   1
      Text            =   "Form1.frx":0006
      Top             =   1680
      Width           =   4095
   End
   Begin VB.TextBox Text1 
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   21.75
         Charset         =   134
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   615
      Left            =   600
      TabIndex        =   0
      Text            =   "李"
      Top             =   480
      Width           =   615
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim hzstr1() As String '从文本中取出的中文存放的一个数组
Dim n As Integer '文本计数用hzLen（）
Dim address1  '存放在hzk16中的地址
Dim zmhp() As Byte '定义横排字存放的树组
 Dim mypath1 '文件所在的文件夹
 Dim zitipath '字体所在路径
 Dim e

Private Sub Command1_Click()
Call s0
Call s1
Call s2

End Sub
Private Sub Form_Click()

Select Case (e)
Case 1:
Me.Left = 8445
Me.Top = 0
e = e + 1
Case 2:
Me.Left = 150
Me.Top = 0
e = e + 1
Case 3:
Me.Left = 0
Me.Top = 8100
e = e + 1
Case 4:
Me.Left = 8595
Me.Top = 8100
e = e + 1
Case 5:
Me.Left = 6915
Me.Top = 3270
e = 1
End Select

End Sub


Private Sub Form_Load()
'**************************************
mypath1 = App.Path & "\" '获取文件所在目录
zitipath = mypath1 & "hzk16" '获取字库所在地址
Text2.Text = "横向取反" & vbCrLf & vbCrLf & "程序设计李健-2007-12-16 QQ:102126913 tel:[phone]"
Me.Caption = "write for:穿透瞬间"
Text3.Text = "横向计算结果"
Command1.Caption = "别点外面"
e = 1

End Sub


Public Sub s0() '将要发送的汉字存入数组中,去除空格,和西文字符
n = 0
Dim L As Integer, i As Integer, j As Integer
L = Len(Text1.Text) '获取文本框中字的字数,此字数不仅包括汉字还包含西文字符,和空格.
For i = 1 To L
If Asc(Mid(Text1.Text, i, 1)) < 0 Then '由于中文的最高位为1,ascii码小于零.
On Error Resume Next
n = n + 1 '得到中文字的字数
End If
Next i
ReDim hzstr1(1 To n) '重新定义存储汉字的数组长度.
j = 1
For i = 1 To L
If Asc(Mid(Text1.Text, i, 1)) < 0 Then
hzstr1(j) = Mid(Text1.Text, i, 1) '把汉字存入数组中.
j = j + 1 'ascii
End If
Next i
End Sub
Public Sub s1()
Dim hzk166() As Byte '定义存放汉字库的数组
Dim qwm '存储区位码
Dim qm '区码
Dim wm '位码
Dim i As Integer, j As Integer
'Dim k As Integer
'Dim bytethz As Byte
Dim intfilenum '定义文件号
'Dim mypath
Dim filena
'mypath = App.Path & "\"
filena = zitipath ' 把字库地址传递过来
'filena = mypath & "hzk16"
intfilenum = FreeFile '获取文件号
Open filena For Binary As #intfilenum '以二进制打开字库文件
Sum = LOF(intfilenum) '获取字库文件的长度,以字节计算
ReDim hzk166(1 To Sum) '重新定义存放字库数组的长度
Get #intfilenum, , hzk166 '将汉字库整体存如数组hzk166()
Close #intfilenum '关闭字库文件,防止发生错误
ReDim zmhp(1 To n, 1 To 32) 'As Byte
For i = 1 To UBound(hzstr1) '字数循环,有几个字循环几次
qwm = Hex(Asc(hzstr1(i)) - &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) '由于标点为三位汉字为四位要获得正确的区位码,必须给予长度判断.否则会出错
End If
address1 = 32 * ((CLng("&H" & qm) - 1) * 94 + (CLng("&H" & wm) - 1)) '获取汉字所在字库的地址
For j = 1 To 32 '每个字为32个字节
'bytehz = Hex(hzk166(address1 + j))
'If Len(bithz) = 1 Then
'bithz = 0 & bithz
'End If
zmhp(i, j) = hzk166(address1 + j) '将点阵数据存入,数组
On Error Resume Next
Next j
Next i
End Sub
Public Sub s2()
Dim s As String
Dim w As String
For i = 1 To 8
'Debug.Print Hex(&HFF - zmhp(1, i)) & ",";
s = s & "0x" & Hex((zmhp(1, i))) & ","
w = w & "0x" & Hex((&HFF - zmhp(1, i))) & ","

Next i
s = s & vbCrLf
w = w & vbCrLf
For i = 9 To 16
'Debug.Print Hex(&HFF - zmhp(1, i)) & ",";
s = s & "0x" & Hex((zmhp(1, i))) & ","
w = w & "0x" & Hex((&HFF - zmhp(1, i))) & ","
Next i
s = s & vbCrLf
w = w & vbCrLf
For i = 17 To 24
'Debug.Print Hex(&HFF - zmhp(1, i)) & ",";
s = s & "0x" & Hex((zmhp(1, i))) & ","
w = w & "0x" & Hex((&HFF - zmhp(1, i))) & ","
Next i
s = s & vbCrLf
w = w & vbCrLf
For i = 25 To 32
'Debug.Print Hex(&HFF - zmhp(1, i)) & ",";
s = s & "0x" & Hex((zmhp(1, i))) & ","
w = w & "0x" & Hex((&HFF - zmhp(1, i))) & ","
Next i
s = s & vbCrLf
w = w & vbCrLf


Text3.Text = "横向取原数据：" & vbCrLf & s
Text2.Text = "取反后数据：" & vbCrLf & w
End Sub

'程序设计李健-2007-12-16 QQ:102126913 tel:[phone]
'wite for 穿透瞬间