📄 form1.frm
字号:
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
LicValid = -1 'True
End
End
Begin ciaXPFrame30.XPFrame30 XPFrame302
Height = 2535
Left = 240
Top = 240
Width = 3495
_ExtentX = 6165
_ExtentY = 4471
BackColor = 16048068
BorderColor = 33023
Caption = "901A8BAF4FE1606F"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = 0
Radius = 20
LicValid = -1 'True
Begin VB.TextBox Text1
Height = 2175
Left = 120
MultiLine = -1 'True
TabIndex = 8
Top = 240
Width = 3255
End
End
Begin VB.Menu mnuTray
Caption = "文件"
Begin VB.Menu mnuTrayRestore
Caption = "还原"
End
Begin VB.Menu mnuTrayMinimize
Caption = "最小化"
End
Begin VB.Menu mnuTraySep
Caption = "-"
End
Begin VB.Menu mnuAbout
Caption = "关于"
End
Begin VB.Menu mnuTrayClose
Caption = "结束"
End
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public LastState As Integer
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const WM_SYSCOMMAND = &H112
Private Const SC_MOVE = &HF010&
Private Const SC_RESTORE = &HF120&
Private Const SC_SIZE = &HF000&
Private portnumber As Integer
Dim package(76) As Byte
Dim backdata(76) As Byte
Function receive_data()
tti = Now
tdelay = 5
'***************************************************************检测缓冲区是否有数据
Do
DoEvents
tti1 = (Now - tti) * 24# * 60# * 60#
Loop Until MSComm1.InBufferCount >= 1 Or tti1 > tdelay
'Text1.Text = Text1.Text + "检测缓冲区" + Chr(13) + Chr(10)
If MSComm1.InBufferCount = 0 And tti1 > tdelay Then '************************若无数据或等待时间超过设定值,退出
receive_data = 0
Text1.Text = Text1.Text + "未发现数据包" + Chr(13) + Chr(10)
Exit Function
End If
Text1.Text = Text1.Text + "发现数据包并接收" + Chr(13) + Chr(10)
'************************************************************人为设置一个间隔时间,确保收发正常
tti = Now
ttdelay = 1
Do
DoEvents
tti1 = (Now - tti) * 24# * 60# * 60#
Loop Until tti1 > ttdelay
'************************************************************从缓冲区中读出数据,清空缓冲区
ll = MSComm1.InBufferCount
receive_data = ll
For i = 0 To ll - 1
datat = MSComm1.Input
datatemp(i) = datat(0)
Next i
End Function
Function check_data(ll)
Dim lhex As String
Dim hhex As String
Dim i As Integer
Dim length As Integer
length = ll
If (length > 0) Then
Text1.Text = Text1.Text + "校验数据包" + Chr(13) + Chr(10)
For i = 1 To length - 12
lengthBW = datatemp(i + 9)
If (i + 5 + lengthBW + 3 <= length) Then
If datatemp(i) = &HEB Then
If datatemp(i + 1) = &H90 Then
If datatemp(i + 2) = &HEB Then
If datatemp(i + 3) = &H90 Then
If datatemp(i + 4) = &H2 Then
If datatemp(i + 5 + lengthBW + 3) = &H3 Then
sump = sumcode(datatemp(), i, i + 5 + lengthBW + 3)
sumstr = Right("0000" + Hex(sump), 4)
lhex = Right(sumstr, 2)
hhex = Left(sumstr, 2)
If lhex = Right("00" + Hex(datatemp(i + 5 + lengthBW + 3 - 2)), 2) And hhex = Right("00" + Hex(datatemp(i + 5 + lengthBW + 3 - 1)), 2) Then
For j = 1 To 6 + lengthBW + 3
data(j) = datatemp(i + j - 1)
Next j
check_data = 6 + lengthBW + 3
Text1.Text = Text1.Text + "开始处理有效数据包" + Chr(13) + Chr(10)
Else
check_data = 0
Text1.Text = Text1.Text + "丢弃无效数据包！！！" + Chr(13) + Chr(10)
End If
End If
End If
End If
End If
End If
End If
End If
Next i
End If
End Function
Function sumcode(p() As Byte, start As Integer, codelength As Integer) As Integer
Dim sumtemp As Single
sumtemp = 0#
For i = start + 5 To codelength - 3
sumtemp = sumtemp + p(i)
Next i
sumcode = Int(sumtemp)
End Function
Private Sub processing(yy1 As Integer)
Dim teffect As Integer
teffect = 30
'pnum = check_data()
If (yy1 <> 0) Then
'检校特征码
Select Case data(7)
Case &H6 'ACK
If (code <> 0) Then
Select Case code
Case &H40
codestr = "上传故障状态成功"
Case &H41
codestr = "上传放电量成功"
Case &H42
codestr = "上传脉冲数成功"
Case &H43
codestr = "上传所有测量数据成功"
End Select
Text1.Text = Text1.Text + "收到ACK信号" + codestr + Chr(13) + Chr(10)
filestr = Str(Now) + "收到ACK信号" + codestr
End If
Case &H15 'NCK
If (code <> 0) Then
Select Case code
Case &H40
codestr = "重新上传故障状态"
Case &H41
codestr = "重新上传放电量"
Case &H42
codestr = "重新上传脉冲数"
Case &H43
codestr = "重新上传所有测量数据"
Case &H15
codestr = ""
End Select
Text1.Text = Text1.Text + "收到NCK信号" + codestr + Chr(13) + Chr(10)
filestr = Str(Now) + "收到NCK信号" + codestr
retrans_data
End If
Case &H40 '故障状态上传
packingdata (3)
backup (3)
trans_data
Text1.Text = Text1.Text + "收到C1信号，上传故障状态" + Chr(13) + Chr(10)
filestr = Str(Now) + "收到C1信号，回应R1信号，上传故障状态"
For i1 = 1 To chsum
viewgrid.TextMatrix(3, i1) = trouble(i1)
viewgrid.TextMatrix(1, i1) = 0
viewgrid.TextMatrix(2, i1) = 0
Next i1
Case &H41 '放电量上传
packingdata (4)
backup (4)
trans_data
Text1.Text = Text1.Text + "收到C2信号，上传放电量" + Chr(13) + Chr(10)
filestr = Str(Now) + "收到C2信号，回应R2信号，上传放电量"
For i1 = 1 To chsum
viewgrid.TextMatrix(3, i1) = 0
viewgrid.TextMatrix(1, i1) = pcdata(i1)
viewgrid.TextMatrix(2, i1) = 0
Next i1
Case &H42 '脉冲数上传
packingdata (5)
backup (5)
trans_data
Text1.Text = Text1.Text + "收到C3信号，上传脉冲数" + Chr(13) + Chr(10)
filestr = Str(Now) + "收到C3信号，回应R3信号，上传脉冲数"
For i1 = 1 To chsum
viewgrid.TextMatrix(3, i1) = 0
viewgrid.TextMatrix(1, i1) = 0
viewgrid.TextMatrix(2, i1) = ndata(i1)
Next i1
Case &H43 '所有测量数据上传
packingdata (6)
backup (6)
trans_data
Text1.Text = Text1.Text + "收到C4信号，上传所有测量数据" + Chr(13) + Chr(10)
filestr = Str(Now) + "收到C4信号，回应R4信号，上传所有测量数据"
For i1 = 1 To chsum
viewgrid.TextMatrix(3, i1) = trouble(i1)
viewgrid.TextMatrix(1, i1) = pcdata(i1)
viewgrid.TextMatrix(2, i1) = ndata(i1)
Next i1
End Select
StatusBar.Caption(1) = " 数据报文: "
For i = 1 To yy1
StatusBar.Caption(1) = StatusBar.Caption(1) + Right(Hex(package(i)), 2) + " "
Next i
Else
If (code = 0) Then
filestr = Str(Now) + " 发生通讯故障！"
Else
filestr = Str(Now) + "通讯出错，发现无效数据包，将其丢弃"
End If
End If
End Sub
Private Sub packingdata(no As Integer)
Dim lhex As String
Dim hhex As String
Dim sump As Integer
Dim packlen As Integer
Dim reallen As Integer
For i = 0 To 76
package(i) = 0
Next i
'****************************************head
package(1) = &HEB
package(2) = &H90
package(3) = &HEB
package(4) = &H90
package(5) = &H2
'****************************************addr
package(6) = &H1
'****************************************info
package(8) = &H1
package(9) = &H1
'********************************************content
Select Case no
Case 1 '************************************************ack
package(7) = &H6
packlen = 13
code = package(7)
'ReDim Preserve package(packlen) As Byte
package(packlen - 3) = &H4
Case 2 '************************************************nck
package(7) = &H15
packlen = 13
code = package(7)
'ReDim Preserve package(packlen) As Byte
package(packlen - 3) = &H4
Case 3 '*************************************************trouble
package(7) = &H40
packlen = 13 + 1 + chsum
reallen = packlen - 9
code = package(7)
'ReDim Preserve package(packlen) As Byte
package(10) = reallen
package(11) = chsum
code = package(7)
For i = 12 To packlen - 3
package(i) = trouble(i - 11)
Next i
Case 4 '**************************************************pcdata
package(7) = &H41
packlen = 13 + 1 + 2 * chsum
reallen = packlen - 9
code = package(7)
'ReDim Preserve package(packlen) As Byte
package(10) = reallen
package(11) = chsum
l = 0
For i = 12 To packlen - 3 Step 2
l = l + 1
Call qvalue(package, (i), (l))
Next i
Case 5 '**************************************************ndata
package(7) = &H42
packlen = 13 + 1 + chsum
reallen = packlen - 9
code = package(7)
'ReDim Preserve package(packlen) As Byte
package(10) = reallen
package(11) = chsum
For i = 12 To packlen - 3
package(i) = ndata(i - 11)
Next i
Case 6 '***************************************************all
package(7) = &H43
packlen = 13 + 1 + chsum + 2 * chsum + chsum
reallen = packlen - 9
code = package(7)
'ReDim Preserve package(packlen) As Byte
package(10) = reallen
package(11) = chsum
For i = 12 To 12 + chsum - 1
package(i) = trouble(i - 11)
Next i
l = 0
For j = 12 + chsum To packlen - 3 - chsum Step 2
l = l + 1
Call qvalue(package, (j), (l))
Next j
For k = packlen - 2 - chsum To packlen - 3
package(k) = ndata(k - (packlen - 3 - chsum))
Next k
End Select
sump = sum_p(package, packlen)
sumstr = Right("0000" + Hex(sump), 4)
lhex = Right(sumstr, 2)
hhex = Left(sumstr, 2)
package(packlen - 2) = str_hex(lhex)
package(packlen - 1) = str_hex(hhex)
'****************************************************************end
package(packlen) = &H3
End Sub
Private Sub backup(no As Integer)
Dim lhex As String
Dim hhex As String
Dim sump As Integer
Dim packlen As Integer
Dim reallen As Integer
For i = 0 To 76
backdata(i) = 0
Next i
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -