📄 frmcom.frm
字号:
VERSION 5.00
Object = "{648A5603-2C6E-101B-82B6-000000000014}#1.1#0"; "MSCOMM32.OCX"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmCom
BorderStyle = 3 'Fixed Dialog
Caption = "获取各机器拍照记录"
ClientHeight = 5925
ClientLeft = 45
ClientTop = 330
ClientWidth = 6930
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "frmCom.frx":0000
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 5925
ScaleWidth = 6930
ShowInTaskbar = 0 'False
StartUpPosition = 2 'CenterScreen
Begin MSComctlLib.ProgressBar prsFile
Height = 216
Left = 1476
TabIndex = 4
Top = 2100
Width = 5340
_ExtentX = 9419
_ExtentY = 370
_Version = 393216
Appearance = 1
End
Begin MSComctlLib.ListView lstRun
Height = 1944
Left = 1476
TabIndex = 3
Top = 120
Width = 5340
_ExtentX = 9419
_ExtentY = 3440
View = 3
LabelWrap = 0 'False
HideSelection = -1 'True
HideColumnHeaders= -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
NumItems = 0
End
Begin VB.CommandButton cmdGetData
Caption = "获取记录"
Height = 396
Left = 156
TabIndex = 2
Top = 1344
Width = 1140
End
Begin MSComctlLib.ListView lstViwCapture
Height = 3432
Left = 120
TabIndex = 1
Top = 2412
Width = 6696
_ExtentX = 11800
_ExtentY = 6059
LabelWrap = 0 'False
HideSelection = -1 'True
FullRowSelect = -1 'True
GridLines = -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
NumItems = 0
End
Begin VB.CommandButton cmdHide
Cancel = -1 'True
Caption = "退出"
Height = 396
Left = 156
TabIndex = 0
Top = 1848
Width = 1140
End
Begin VB.Timer timGetData
Enabled = 0 'False
Interval = 60000
Left = 876
Top = 2136
End
Begin MSCommLib.MSComm MSComm1
Left = 165
Top = 2070
_ExtentX = 1005
_ExtentY = 1005
_Version = 393216
CommPort = 4
DTREnable = -1 'True
Handshaking = 2
InBufferSize = 2048
OutBufferSize = 2048
RTSEnable = -1 'True
BaudRate = 56000
InputMode = 1
End
End
Attribute VB_Name = "frmCom"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As Long, ByVal bRevert As Long) As Long
Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Const MF_REMOVE = &H1000&
Private Const MF_BYPOSITION = &H400&
'与自动应答连OK
'收不到文件尾问题通过发送端文件尾数据发送后延时得以解决
'收到文件超长，通过从缓冲区中读定长数据方法得以解决
Public bCommSetOK As Boolean
'终端工作错误状态
Const WRONG_NET = 0
Const WRONG_V1 = 1
Const WRONG_V2 = 2
Const Wait = 30 '
Const SENDDATALENGTH = 768
Const GIVE_ME_DATA = "@G@"
Const GIVE_ME_REC = "@R@"
Const GIVE_ME_FILE = "@F@"
Const I_GET_IT = "@I@"
Const I_GET_ALL_REC = "@A@"
Const CHAREND = "&*@"
Dim nInterval As Integer
Dim nClientsCount As Integer '终端数量
Dim sClientNames() As String '终端电话
Dim sClientPhones() As String '各终端电话号码
Dim nCurrentClientNo As Integer
Dim JSFILEDATA As Variant
Dim JSARR() As Byte
Dim tmpARR() As Byte
Dim itemX As ListItem
'主动获取数据
Private Sub cmdGetData_Click()
'Call GetClientsData
ConnectClient "8056795"
Dim t As Single
Dim JSData As Variant, JSstring As String
'等待Wait 秒，如果无数据，则错误返回空字符串
JSstring = ""
t = Timer
Do While 1
If Timer > t + 5 Then
Exit Do
End If
If MSComm1.InBufferCount > 0 Then
MSComm1.InputLen = 0
JSData = MSComm1.Input
JSstring = JSstring & HandleData(JSData)
If InStr(1, JSstring, CHAREND) > 0 Then
Exit Do
End If
End If
DoEvents
Loop
MsgBox JSstring
End Sub
'隐藏窗体
Private Sub cmdHide_Click()
Me.Hide
End Sub
Private Sub Form_Load()
Call RemoveX(Me.hWnd)
'初始化端口
If InitComm = False Then
MsgBox "端口初始化错误！"
timGetData.Enabled = False
End If
Call InitLstViw
timGetData.Enabled = True
End Sub
' 初始化通讯端口
Private Function InitComm() As Boolean
Dim commSettings As String
Dim commPort As String
Dim commHandShaking As String
Dim an As Integer
Dim t As Single
On Error Resume Next
commSettings = GetSetting("通讯端口设置", "Properties", "Settings", "")
Do While commSettings = ""
Load frmCommProperties
Set frmCommProperties.frmComm = Me
Call frmCommProperties.LoadPropertySettings
frmCommProperties.Show vbModal
If bCommSetOK = False Then
an = MsgBox("您必须进行端口设置，否则程序无法运行" & vbCrLf & "重新设置吗？", vbYesNo + vbQuestion, "端口设置错误")
If an = vbNo Then
InitComm = False
Exit Function
End If
Else
Exit Do
End If
Loop
commSettings = GetSetting("通讯端口设置", "Properties", "Settings", "")
commPort = GetSetting("通讯端口设置", "Properties", "CommPort", "")
commHandShaking = GetSetting("通讯端口设置", "Properties", "Handshaking", "")
MSComm1.Settings = commSettings
MSComm1.commPort = commPort
MSComm1.Handshaking = commHandShaking
MSComm1.Settings = "56000,n,8,1"
MSComm1.commPort = 4
MSComm1.Handshaking = 2
MSComm1.RThreshold = 0
MSComm1.PortOpen = True
If Err = 0 Then
MSComm1.DTREnable = True
t = Timer
Do While 1
If Timer > t + Wait Then
Exit Do
ElseIf Timer < t And Timer > Wait Then
Exit Do
End If
If MSComm1.CTSHolding = True Then
Exit Do
End If
DoEvents
Loop
If MSComm1.CTSHolding = True Then
MSComm1.Output = "ATQ0" & vbCrLf ' 返回结果码
MSComm1.Output = "ATE1" & vbCrLf ' 开字符回应
MSComm1.Output = "ATM1" & vbCrLf ' 打开扬声器
' MSComm1.Output = "ATC1" & vbCrLf
InitComm = True
Else
InitComm = False
End If
Else
InitComm = False
End If
End Function
'单客户数据获取
Private Sub Image1_DblClick()
If cmdGetData.Enabled = False Then
'正在获取数据，不可
Else
End If
End Sub
Private Sub timGetData_Timer()
nInterval = nInterval + 1
If nInterval >= g_nGetDataInterval Then
Call GetClientsData
End If
End Sub
' 向各个终端要数据
Private Sub GetClientsData()
Dim i As Integer
cmdGetData.Enabled = False
'关闭要数据时钟
timGetData.Enabled = False
lstRun.ListItems.Clear
lstViwCapture.ListItems.Clear
prsFile.Value = 0
'设置终端数量和各个终端电话号码、名称
Call GetClientsSetting
'顺次获取各终端数据
nCurrentClientNo = 1
Do While nCurrentClientNo <= nClientsCount
Call GetClientData(sClientPhones(nCurrentClientNo))
Set itemX = lstRun.ListItems.Add(, , sClientPhones(nCurrentClientNo) & "数据接收完毕！")
itemX.EnsureVisible
DoEvents
Dim t As Single
t = Timer + 1#
Do While Timer < t
DoEvents
Loop
Call HangUp
Call InitComm
nCurrentClientNo = nCurrentClientNo + 1
Loop
Set itemX = lstRun.ListItems.Add(, , "所有数据接收完毕！")
itemX.EnsureVisible
lstRun.ListItems.Clear
'将记录数据发送到主窗体
Call SendRecToMain
'打开要数据时钟
cmdGetData.Enabled = True
timGetData.Enabled = True
g_nGetDataInterval = 0
End Sub
' 向单个终端要数据,对应电话号码为sPhone
Private Sub GetClientData(ByVal sClientPhone As String)
Dim sVideoandRecCount As String
Dim i As Integer, RecCount As Integer
Dim bV1 As Boolean, bV2 As Boolean
'与终端建立连接
If ConnectClient(sClientPhone) = False Then
'连接失败，则报警对应终端工作状态
Call WrongWorkClient(WRONG_NET)
Set itemX = lstRun.ListItems.Add(, , "连接失败")
itemX.EnsureVisible
Else
'连接成功，则发GIVE_ME_DATA命令
If SendChar(GIVE_ME_DATA) = False Then
Set itemX = lstRun.ListItems.Add(, , "发送GIVE_ME_DATA失败")
itemX.EnsureVisible
Else
'发送命令之后，接收视频和记录数
sVideoandRecCount = GetReChar()
If sVideoandRecCount = "" Then
Set itemX = lstRun.ListItems.Add(, , "获取视频和记录数失败")
itemX.EnsureVisible
Else '分析视频和记录数
'分析处理视频和记录数，返回记录数
Set itemX = lstRun.ListItems.Add(, , sVideoandRecCount)
itemX.EnsureVisible
RecCount = AnalyVandRecCount(sVideoandRecCount, bV1, bV2)
If bV1 = False Then
Call WrongWorkClient(WRONG_V1)
End If
If bV2 = False Then
Call WrongWorkClient(WRONG_V2)
End If
Set itemX = lstRun.ListItems.Add(, , "记录数为：" & Format(RecCount))
itemX.EnsureVisible
DoEvents
If RecCount > 0 Then
'逐条获取记录信息
For i = 1 To RecCount
Set itemX = lstRun.ListItems.Add(, , "获取第" & Format(i) & "条记录")
itemX.EnsureVisible
Call GetRec
Next i
End If
SendChar (I_GET_ALL_REC)
End If
End If
End If
End Sub
' 获取一条记录，包括文本和图片文件
Private Sub GetRec()
Dim FL As Long
Dim sFile As String
Dim sRecText As String
If SendChar(GIVE_ME_REC) = False Then
Set itemX = lstRun.ListItems.Add(, , "发送GIVE_ME_REC失败,记录获取失败")
itemX.EnsureVisible
Exit Sub
End If
'接收记录文本信息，并处理
sRecText = GetReChar()
If sRecText = "" Then
Set itemX = lstRun.ListItems.Add(, , "接收记录文本信息失败")
itemX.EnsureVisible
Exit Sub
End If
'分析记录文本信息，新增一条lstviwCapture列表项，并返回图片文件名
sFile = AnalyRecText(sRecText, FL)
If sFile <> "" Then '收到的记录文本信息正确
If GetFile(sFile, FL) = True Then
'文本和文件都接收正确，则形成一条拍照记录
Call AddNewRec
Else
lstViwCapture.ListItems.Remove lstViwCapture.SelectedItem.Index
Set itemX = lstRun.ListItems.Add(, , "接收记录图片文件失败")
itemX.EnsureVisible
End If
Else
Set itemX = lstRun.ListItems.Add(, , "接收记录文本信息失败")
itemX.EnsureVisible
End If
End Sub
'连接终端，号码为sPhone
'待试占线情况*****************
Private Function ConnectClient(ByVal sPhone As String) As Boolean
Dim t As Single
sPhone = Trim(sPhone)
If MSComm1.PortOpen = False Then
ConnectClient = False
Exit Function
End If
Set itemX = lstRun.ListItems.Add(, , "正在与" & sPhone & "连接...")
itemX.EnsureVisible
MSComm1.Output = "ATDT" & sPhone & vbCrLf
t = Timer
Do While 1
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -