📄 main_jbzl_khlb.frm
字号:
Top = 315
Width = 765
End
Begin VB.Label Label2
Caption = "号码"
Height = 165
Left = 6600
TabIndex = 17
Top = 315
Width = 765
End
End
Begin VB.Label Label8
Caption = "选表"
Height = 375
Left = 2160
TabIndex = 23
Top = 5520
Width = 495
End
Begin VB.Label Label7
Caption = "串口选择"
Height = 255
Left = 9120
TabIndex = 21
Top = 1680
Width = 855
End
Begin VB.Label Label5
Caption = "版本号"
Height = 375
Left = 240
TabIndex = 15
Top = 3720
Width = 855
End
Begin VB.Label Label4
Caption = "接收显示"
Height = 375
Left = 4680
TabIndex = 12
Top = 4440
Width = 855
End
Begin VB.Label Label3
Caption = "输入显示"
Height = 375
Left = 120
TabIndex = 11
Top = 4440
Width = 735
End
End
Attribute VB_Name = "main_jbzl_khlb"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public blnAdd As Boolean
Public Flagold As Boolean
Public i As Integer
Public s As String
Sub view_data()
Dim i As Integer
If Adodc1.Recordset.RecordCount > 0 Then
For i = 0 To Text1.UBound
Text1(i) = DataGrid1.Columns(i).Text
Next i
End If
End Sub
Private Sub Combo1_Click()
MSCommMy.CommPort = Combo1.ListIndex + 1
End Sub
Private Sub DataGrid1_RowColChange(LastRow As Variant, ByVal LastCol As Integer)
view_data
s = DataGrid1.Columns(0)
End Sub
'串口初始化 串口
Private Sub Form_Load()
MSCommMy.Settings = "9600,n,8,1" '设置串口参数
'MSCommMy.InputMode = 1 '接收二进制数据
MSCommMy.InputMode = 0 '接收文本型数据
'MSCommMy.SThreshold = 1 '设置一次从发送缓冲区读取字节数为1
'MSCommMy.InputLen = 1 '设置Input 一次从接收缓冲读取字节数为1
'RThreshold = 16 '设置16个字节到达时才响应OnComm事件
MSCommMy.InputLen = 0 '读取接收缓冲区中全部的内容
Combo1.List(0) = "COM1"
Combo1.List(1) = "COM2"
Combo1.List(2) = "COM3"
Combo1.List(3) = "COM4"
Combo1.List(4) = "COM5"
Combo1.List(5) = "COM6"
Combo1.Text = "COM1"
Flagold = False
'初始化数据库
tlbState Toolbar1, False
Adodc1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\db_sell.mdb;Persist Security Info=False"
Adodc2.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\db_sell.mdb;Persist Security Info=False"
Adodc1.RecordSource = "客户类别表"
Adodc1.Refresh
Adodc2.RecordSource = "select * from 客户类别表"
Adodc2.Refresh
view_data
End Sub
'打开通信端口
'把字符通过串口发送出去
Private Sub Cmdsend_Click()
Dim MyString, Mychar, OutString, OutString1
Dim MyHex
Dim Jyan
Dim MyAsc As Integer
Dim Count As Integer
Dim Mychar0 As String
Dim Mychar1 As String
Dim a, j, i
Dim out() As Byte
If Flagold = False Then
ReDim out(Len(Textsend.Text) + 4)
If MSCommMy.PortOpen = False Then MSCommMy.PortOpen = True
'处理发送的字符数据格式，将字符串格式转换成16进制数据
MyString = Trim(Textsend.Text) ' 赋值要做一个循环，每次进行一个字符操作
Jyan = 0 ' 校验值,十进制
MyAsc = Asc("Y")
out(0) = CByte(MyAsc)
Jyan = Jyan + MyAsc
For Count = 1 To Len(Textsend.Text)
Mychar = Mid(MyString, Count, 1)
MyAsc = Asc(Mychar)
out(Count) = CByte(MyAsc)
Jyan = Jyan + MyAsc
Next Count
out(Len(Textsend.Text) + 1) = CByte(Hex2Dec(Mid(Text2.Text, 1, 2)))
out(Len(Textsend.Text) + 2) = CByte(Hex2Dec(Mid(Text2.Text, 3, 2)))
MyAsc = Asc("Z")
out(Len(Textsend.Text) + 3) = CByte(MyAsc)
'老表后面的校验和不计算
If Flagold = False Then
Jyan = Jyan + MyAsc
Mychar0 = Mid(Text2.Text, 1, 2)
Mychar1 = Mid(Text2.Text, 3, 2)
a = Hex2Dec(Mychar0) + Hex2Dec(Mychar1)
Jyan = Jyan + a
out(Len(Textsend.Text) + 4) = CByte(Hex2Dec(Right(Hex(Jyan), 2)))
End If '数据发送完毕
Flagold = False '老表标志清除
MSCommMy.Output = out
'For i = 0 To Len(Textsend.Text) + 4
'OutString1 = Trim(OutString) & Trim(Chr(out(i)))
'Next i
'Textsend.Text = OutString1
Else
ReDim out(Len(Textsend.Text) + 3)
If MSCommMy.PortOpen = False Then MSCommMy.PortOpen = True
'处理发送的字符数据格式，将字符串格式转换成16进制数据
MyString = Trim(Textsend.Text) ' 赋值要做一个循环，每次进行一个字符操作
Jyan = 0 ' 校验值,十进制
MyAsc = Asc("Y")
out(0) = CByte(MyAsc)
Jyan = Jyan + MyAsc
For Count = 1 To Len(Textsend.Text)
Mychar = Mid(MyString, Count, 1)
MyAsc = Asc(Mychar)
out(Count) = CByte(MyAsc)
Jyan = Jyan + MyAsc
Next Count
out(Len(Textsend.Text) + 1) = CByte(Hex2Dec(Mid(Text2.Text, 1, 2)))
out(Len(Textsend.Text) + 2) = CByte(Hex2Dec(Mid(Text2.Text, 3, 2)))
MyAsc = Asc("Z")
out(Len(Textsend.Text) + 3) = CByte(MyAsc)
MSCommMy.Output = out
'Flagold = False '老表标志清除
'For i = 0 To Len(Textsend.Text) + 3
'OutString1 = Trim(OutString) & Trim(Chr(out(i)))
'Next i
'Textsend.Text = OutString1
End If
'启动定时器计时,时间间隔20秒
Timer1.Enabled = True
Timer2.Enabled = True
End Sub
'清空按钮
Private Sub Cmdclear_Click_Click()
Textsend.Text = ""
End Sub
'点击老表
Private Sub oldmeter_Click()
Flagold = True
MsgBox "您选择了测试老表，请确认。注意：每次测试老表都要先点击老表选项。默认情况下，自动选择新表测试"
End Sub
'定时自动从输入缓冲区读取字符
Private Sub Timer1_Timer()
If MSCommMy.InBufferCount > 0 Then
TextReceive.Text = TextReceive.Text + MSCommMy.Input
Timer1.Enabled = False '关闭定时器1
Timer2.Enabled = False
Else
TextReceive.Text = ""
MSCommMy.InBufferCount = 0 '清空接收缓冲区
End If
End Sub
'关闭通信端口,停止程序运行
Private Sub Cmdquit_Click()
MSCommMy.PortOpen = False
End
End Sub
'消息处理,接收数据
Private Sub Timer2_Timer()
TextReceive.Text = MSCommMy.Input '将缓冲区内的数据读入
If Flagold = False And TextReceive.Text = "ok" Then
MsgBox "成功收到"
'MSCommMy.InBufferCount = 0 '清空接收缓冲区
Flagold = False
Timer2.Enabled = False
ElseIf Flagold = True And Len(TextReceive.Text) > 2 Then
Flagold = False
Timer2.Enabled = False
Else
MsgBox "20秒已到,请重新点击“发送数据”"
Timer2.Enabled = False
Flagold = False '老表标志清除
End If
End Sub
'数据库处理
Private Sub Text1_GotFocus(Index As Integer)
Text1(Index).BackColor = &HFFFF00
Text1(Index).SelStart = 0
Text1(Index).SelLength = Len(Text1(Index))
End Sub
Private Sub Text1_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyReturn And Index < 1 Then Text1(Index + 1).SetFocus
End Sub
Private Sub Text1_LostFocus(Index As Integer)
Text1(Index).BackColor = &H80000005
End Sub
Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Key
Case "add" '添加
blnAdd = True ' '设置标识变量为False，此时为添加
tlbState Toolbar1, True '调用自定义过程，设置Toolbar的按钮状态
Text1(0) = "": Text1(1) = "" '清空文本框中的内容
Text1(2) = "" '清空文本框中的内容
Text1(0).Locked = False: Text1(1).Locked = False '解除控件锁定
Text1(0).Locked = False '解除控件锁定
Textsend.Text = "" '清空发送窗口
Case "modify" '修改
If Adodc1.Recordset.RecordCount > 0 Then '如果记录大于零
blnAdd = False '设置标识变量为False，此时为修改
tlbState Toolbar1, True '调用自定义过程，设置Toolbar的按钮状态
Text1(0).Locked = False: Text1(1).Locked = False '解除控件锁定
view_data '调用自定义过程，显示数据
Else
MsgBox "系统没有要修改的数据！"
End If
Case "delete" '删除
If Adodc1.Recordset.RecordCount > 0 Then '如果记录大于零
Adodc1.Recordset.Delete '删除
Adodc1.Recordset.Update '更新
Else
MsgBox "系统没有要删除的数据！"
End If
Case "save" '保存
If Text1(0).Text = "" Then
MsgBox "系统不允许" & Label1 & "为空！"
Exit Sub
End If
On Error GoTo SaveErr
With Adodc2.Recordset
If blnAdd = True Then
.AddNew
.Fields("客户类别") = Text1(0)
.Fields("号码") = Text1(1)
.Fields("仪表编号") = Text1(2) ''''''''
If Len(Text1(1)) <> 11 Then
MsgBox "输入的号码不是11位,重新输入" '输入错
Text1(1) = "" '清空
Text1(0) = "" '清空
blnAdd = False '设置标识变量为False 不允许添加
Text1(1).Locked = True '锁定
On Error GoTo SaveErr '不更新
GoTo 11
End If
.Fields("录入日期") = Date
.Update
Adodc2.Refresh
11: Else
.Filter = "客户类别 = '" + s + "'"
If .RecordCount > 0 Then
' MsgBox Text1(0)
' MsgBox .Fields("客户类别")
.Fields("客户类别") = Text1(0)
.Fields("号码") = Text1(1)
.Fields("仪表编号") = Text1(2) ''''''''
.Fields("录入日期") = Date
.Update
End If
Adodc2.Refresh
End If
Textsend.Text = Text1(1).Text '改动 传递号码
' MsgBox Textsend.Text
End With
Adodc1.Refresh
tlbState Toolbar1, False
Text1(0).Locked = True: Text1(1).Locked = True
Exit Sub
SaveErr:
MsgBox Err.Description
Case "cancel" '取消
tlbState Toolbar1, False
Text1(0).Locked = True: Text1(1).Locked = True
view_data
Case "close" '关闭
Unload Me
Case "20秒"
MsgBox "接收不到ok,请重新发送"
End Select
End Sub
'添加按钮
Private Sub Command1_Click()
Adodc1.Recordset.AddNew '添加新纪录
Adodc1.Recordset.Fields("号码") = Text1(1).Text
End Sub
Private Sub Command2_Click()
Adodc1.Recordset.Update '保存提交
Adodc1.Refresh '刷新
End Sub
'16进制转换10进制
Public Function Hex2Dec(InputData As String) As Double
Dim i As Integer
Dim DecOut As Double
Dim Lenhex As Integer
Dim HexStep As Double
DecOut = 0
InputData = UCase(InputData)
Lenhex = Len(InputData)
For i = 1 To Lenhex
If IsNumeric(Mid(InputData, i, 1)) Then
GoTo NumOk
ElseIf Mid(InputData, i, 1) = "A" Then
GoTo NumOk
ElseIf Mid(InputData, i, 1) = "B" Then
GoTo NumOk
ElseIf Mid(InputData, i, 1) = "C" Then
GoTo NumOk
ElseIf Mid(InputData, i, 1) = "D" Then
GoTo NumOk
ElseIf Mid(InputData, i, 1) = "E" Then
GoTo NumOk
ElseIf Mid(InputData, i, 1) = "F" Then
GoTo NumOk
Else
Exit Function
End If
NumOk:
Next i
HexStep = 0
For i = Lenhex To 1 Step -1
HexStep = HexStep * 16
If HexStep = 0 Then
HexStep = 1
End If
If Mid(InputData, i, 1) = "0" Then
DecOut = DecOut + (0 * HexStep)
ElseIf Mid(InputData, i, 1) = "1" Then
DecOut = DecOut + (1 * HexStep)
ElseIf Mid(InputData, i, 1) = "2" Then
DecOut = DecOut + (2 * HexStep)
ElseIf Mid(InputData, i, 1) = "3" Then
DecOut = DecOut + (3 * HexStep)
ElseIf Mid(InputData, i, 1) = "4" Then
DecOut = DecOut + (4 * HexStep)
ElseIf Mid(InputData, i, 1) = "5" Then
DecOut = DecOut + (5 * HexStep)
ElseIf Mid(InputData, i, 1) = "6" Then
DecOut = DecOut + (6 * HexStep)
ElseIf Mid(InputData, i, 1) = "7" Then
DecOut = DecOut + (7 * HexStep)
ElseIf Mid(InputData, i, 1) = "8" Then
DecOut = DecOut + (8 * HexStep)
ElseIf Mid(InputData, i, 1) = "9" Then
DecOut = DecOut + (9 * HexStep)
ElseIf Mid(InputData, i, 1) = "A" Then
DecOut = DecOut + (10 * HexStep)
ElseIf Mid(InputData, i, 1) = "B" Then
DecOut = DecOut + (11 * HexStep)
ElseIf Mid(InputData, i, 1) = "C" Then
DecOut = DecOut + (12 * HexStep)
ElseIf Mid(InputData, i, 1) = "D" Then
DecOut = DecOut + (13 * HexStep)
ElseIf Mid(InputData, i, 1) = "E" Then
DecOut = DecOut + (14 * HexStep)
ElseIf Mid(InputData, i, 1) = "F" Then
DecOut = DecOut + (15 * HexStep)
Else
End If
Next i
Hex2Dec = DecOut
eds:
End Function
Public Function Byte2Dec(MyByte() As Byte) As Integer
Dim MyValue As Integer
Dim MyString1 As String
Dim MyArray(8)
MyByte = "10100011"
MyString = MyByte
MyArray(8) = Mid(MyString1, 1, 1)
MyArray(7) = Mid(MyString1, 2, 1)
MyArray(6) = Mid(MyString1, 3, 1)
MyArray(5) = Mid(MyString1, 4, 1)
MyArray(4) = Mid(MyString1, 5, 1)
MyArray(3) = Mid(MyString1, 6, 1)
MyArray(2) = Mid(MyString1, 7, 1)
MyArray(1) = Mid(MyString1, 8, 1)
MyValue = Val(MyArray(8)) * 128 + Val(MyArray(7)) * 64 + Val(MyArray(6)) * 32 + Val(MyArray(5)) * 16 + Val(MyArray(4)) * 8 + Val(MyArray(3)) * 4 + Val(MyArray(2)) * 2 + Val(MyArray(1)) * 1
Byte2Dec = MyValue
'MsgBox (MyValue)
End Function
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -