form1.frm

vb 上位机更改点阵显示的数据

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   5025
   ClientLeft      =   6975
   ClientTop       =   3615
   ClientWidth     =   6660
   LinkTopic       =   "Form1"
   ScaleHeight     =   5025
   ScaleMode       =   0  'User
   ScaleWidth      =   6660
   Begin VB.TextBox Text4 
      Height          =   1695
      Left            =   2400
      MultiLine       =   -1  'True
      TabIndex        =   4
      Text            =   "Form1.frx":0000
      Top             =   3000
      Width           =   4095
   End
   Begin VB.TextBox Text3 
      Height          =   1335
      Left            =   2400
      MultiLine       =   -1  'True
      TabIndex        =   3
      Text            =   "Form1.frx":0006
      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":000C
      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
   Begin VB.Label Label1 
      Caption         =   "Label1"
      Height          =   255
      Left            =   360
      TabIndex        =   5
      Top             =   3240
      Width           =   1935
   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 zmsp() As Byte '
 Dim mypath1 '文件所在的文件夹
 Dim zitipath '字体所在路径
 Dim e
 Public LoginSucceeded As Boolean

Private Sub Command1_Click()
Call s0
Call s1
Call s2
Call s3
Call s5
Me.Cls
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 = "横向取反"
Me.Caption = "write for:——————"
Text3.Text = "横向计算结果"
Command1.Caption = "别点外面"
e = 1
Text4.Text = "竖向计算结果" & vbCrLf & vbCrLf & "点阵上用的是这个数据"

If (LoginSucceeded = True) Then Call Command1_Click


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
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 '
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 s3() '将横排转化为竖排
Dim i As Integer, k As Integer
Dim j As Integer
Dim m As Integer
Dim bithz1 As Byte '用来判断该位的值
Dim z As Byte '
Dim qq As Byte '
ReDim zmsp(1 To n, 1 To 32)

For i = 1 To n
'i = 1
j = 1
For k = 1 To 2 '
'Debug.Print "_____"
qq = &H80 '
'If (qq >= &H1) Then
For m = 1 To 8
'Debug.Print "_____"'运算根据16*16点阵横排与竖排的存放特性进行计算.
z = &H0
If ((zmhp(i, k) And qq) = 0) Then bithz1 = &H0 Else bithz1 = &H1 '8
z = &H80 * bithz1 '作位最高位
If ((zmhp(i, k + 2) And qq) = 0) Then bithz1 = &H0 Else bithz1 = &H1 '7
z = z + (&H40 * bithz1)
If ((zmhp(i, k + 4) And qq) = 0) Then bithz1 = &H0 Else bithz1 = &H1 '6
z = z + (&H20 * bithz1)
If ((zmhp(i, k + 6) And qq) = 0) Then bithz1 = &H0 Else bithz1 = &H1 '5
z = z + (&H10 * bithz1)
If ((zmhp(i, k + 8) And qq) = 0) Then bithz1 = &H0 Else bithz1 = &H1 '4
z = z + (&H8 * bithz1)
If ((zmhp(i, k + 10) And qq) = 0) Then bithz1 = &H0 Else bithz1 = &H1 '3
z = z + (&H4 * bithz1)
If ((zmhp(i, k + 12) And qq) = 0) Then bithz1 = &H0 Else bithz1 = &H1 '2
z = z + (&H2 * bithz1)
If ((zmhp(i, k + 14) And qq) = 0) Then bithz1 = &H0 Else bithz1 = &H1 '1
z = z + (&H1 * bithz1) '作为最底位
zmsp(i, j) = z '取的为上部分
j = j + 1
z = 0
If ((zmhp(i, k + 16) And qq) = 0) Then bithz1 = &H0 Else bithz1 = &H1 '8
z = &H80 * bithz1
If ((zmhp(i, k + 18) And qq) = 0) Then bithz1 = &H0 Else bithz1 = &H1 '7
z = z + (&H40 * bithz1)
If ((zmhp(i, k + 20) And qq) = 0) Then bithz1 = &H0 Else bithz1 = &H1 '6
z = z + (&H20 * bithz1)
If ((zmhp(i, k + 22) And qq) = 0) Then bithz1 = &H0 Else bithz1 = &H1 '5
z = z + (&H10 * bithz1)
If ((zmhp(i, k + 24) And qq) = 0) Then bithz1 = &H0 Else bithz1 = &H1 '4
z = z + (&H8 * bithz1)
If ((zmhp(i, k + 26) And qq) = 0) Then bithz1 = &H0 Else bithz1 = &H1 '3
z = z + (&H4 * bithz1)
If ((zmhp(i, k + 28) And qq) = 0) Then bithz1 = &H0 Else bithz1 = &H1 '2
z = z + (&H2 * bithz1)
If ((zmhp(i, k + 30) And qq) = 0) Then bithz1 = &H0 Else bithz1 = &H1 '1
z = z + (&H1 * bithz1)
zmsp(i, j) = z '下一部分
j = j + 1 '            这一不分有些麻烦,要看的话多注意理解vb中16进制数的运算
z = 0
qq = (qq / &H2) '取横排的下一位*****************哈哈，但愿大家能看懂××××××××××××××
Next m
Next k
Next i
End Sub '将横排存放的汉字转化位,竖排存放的由于vb没有移位运算只有按位相与,进行判断.
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
Public Sub s5()
Dim s As String
Dim w As String
For i = 1 To 8
'Debug.Print Hex(&HFF - zmhp(1, i)) & ",";
s = s & "0x" & Hex((zmsp(1, i))) & ","

Next i
s = s & vbCrLf

For i = 9 To 16
'Debug.Print Hex(&HFF - zmhp(1, i)) & ",";
s = s & "0x" & Hex((zmsp(1, i))) & ","

Next i
s = s & vbCrLf

For i = 17 To 24
'Debug.Print Hex(&HFF - zmhp(1, i)) & ",";
s = s & "0x" & Hex((zmsp(1, i))) & ","

Next i
s = s & vbCrLf

For i = 25 To 32
'Debug.Print Hex(&HFF - zmhp(1, i)) & ",";
s = s & "0x" & Hex((zmsp(1, i))) & ","

Next i
s = s & vbCrLf



Text4.Text = "竖向取原数据：" & vbCrLf & s
'Text2.Text = "横向取反后数据：" & vbCrLf & w


End Sub

'程序设计李健-2007-12-16 QQ:102126913 tel:
'write for 穿透瞬间
'*******************************************************
'rewrite 2008-1-8
'write for snail boy
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label1.Caption = "(x,y)=" & "(" & X & "," & Y & ")"
Me.Line (X, Y)-(X + 100, Y + 100), vbRed
End Sub