www.pudn.com > gdqj1a302.zip > main.frm
VERSION 5.00
Object = "{648A5603-2C6E-101B-82B6-000000000014}#1.1#0"; "MSCOMM32.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "comctl32.ocx"
Begin VB.Form fmMain
AutoRedraw = -1 'True
BackColor = &H00C0C0C0&
Caption = "Gdqj 3.2"
ClientHeight = 8280
ClientLeft = 60
ClientTop = 630
ClientWidth = 11880
BeginProperty Font
Name = "Times New Roman"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "main.frx":0000
LinkTopic = "Form1"
Picture = "main.frx":0442
ScaleHeight = 8280
ScaleWidth = 11880
Begin ComctlLib.Toolbar toolbar1
Align = 1 'Align Top
Height = 420
Left = 0
TabIndex = 8
Top = 0
Width = 11880
_ExtentX = 20955
_ExtentY = 741
ButtonWidth = 635
ButtonHeight = 582
Appearance = 1
ImageList = "ImageList1"
_Version = 327682
BeginProperty Buttons {0713E452-850A-101B-AFC0-4210102A8DA7}
NumButtons = 11
BeginProperty Button1 {0713F354-850A-101B-AFC0-4210102A8DA7}
Key = ""
Object.ToolTipText = "X+"
Object.Tag = ""
ImageIndex = 1
EndProperty
BeginProperty Button2 {0713F354-850A-101B-AFC0-4210102A8DA7}
Key = ""
Object.ToolTipText = "X-"
Object.Tag = ""
ImageIndex = 2
EndProperty
BeginProperty Button3 {0713F354-850A-101B-AFC0-4210102A8DA7}
Key = ""
Object.ToolTipText = "Y+"
Object.Tag = ""
ImageIndex = 3
EndProperty
BeginProperty Button4 {0713F354-850A-101B-AFC0-4210102A8DA7}
Key = ""
Object.ToolTipText = "Y-"
Object.Tag = ""
ImageIndex = 4
EndProperty
BeginProperty Button5 {0713F354-850A-101B-AFC0-4210102A8DA7}
Key = ""
Object.ToolTipText = "全程显示"
Object.Tag = ""
ImageIndex = 5
EndProperty
BeginProperty Button6 {0713F354-850A-101B-AFC0-4210102A8DA7}
Key = ""
Object.ToolTipText = "初始形式"
Object.Tag = ""
ImageIndex = 6
EndProperty
BeginProperty Button7 {0713F354-850A-101B-AFC0-4210102A8DA7}
Key = ""
Object.ToolTipText = "偏移切换"
Object.Tag = ""
ImageIndex = 7
EndProperty
BeginProperty Button8 {0713F354-850A-101B-AFC0-4210102A8DA7}
Key = ""
Object.ToolTipText = "生成文本文件"
Object.Tag = ""
ImageIndex = 8
EndProperty
BeginProperty Button9 {0713F354-850A-101B-AFC0-4210102A8DA7}
Key = ""
Object.ToolTipText = "打印"
Object.Tag = ""
ImageIndex = 9
EndProperty
BeginProperty Button10 {0713F354-850A-101B-AFC0-4210102A8DA7}
Key = ""
Object.ToolTipText = "Y++"
Object.Tag = ""
ImageIndex = 10
EndProperty
BeginProperty Button11 {0713F354-850A-101B-AFC0-4210102A8DA7}
Key = ""
Object.ToolTipText = "Y--"
Object.Tag = ""
ImageIndex = 11
EndProperty
EndProperty
Begin ComctlLib.ImageList ImageList1
Left = 2130
Top = 60
_ExtentX = 1005
_ExtentY = 1005
BackColor = 16777215
ImageWidth = 16
ImageHeight = 16
MaskColor = 12632256
_Version = 327682
BeginProperty Images {0713E8C2-850A-101B-AFC0-4210102A8DA7}
NumListImages = 11
BeginProperty ListImage1 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "main.frx":18EC
Key = ""
EndProperty
BeginProperty ListImage2 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "main.frx":1E3E
Key = ""
EndProperty
BeginProperty ListImage3 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "main.frx":2390
Key = ""
EndProperty
BeginProperty ListImage4 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "main.frx":28E2
Key = ""
EndProperty
BeginProperty ListImage5 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "main.frx":2E34
Key = ""
EndProperty
BeginProperty ListImage6 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "main.frx":3386
Key = ""
EndProperty
BeginProperty ListImage7 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "main.frx":38D8
Key = ""
EndProperty
BeginProperty ListImage8 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "main.frx":3E2A
Key = ""
EndProperty
BeginProperty ListImage9 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "main.frx":4144
Key = ""
EndProperty
BeginProperty ListImage10 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "main.frx":4686
Key = ""
EndProperty
BeginProperty ListImage11 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "main.frx":4BD8
Key = ""
EndProperty
EndProperty
End
End
Begin VB.HScrollBar HScroll1
Height = 225
Left = 480
Max = 100
TabIndex = 10
Top = 8010
Width = 4725
End
Begin VB.ListBox List1
BackColor = &H0080FFFF&
BeginProperty Font
Name = "Courier New"
Size = 10.5
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FF0000&
Height = 6945
ItemData = "main.frx":512A
Left = 120
List = "main.frx":512C
TabIndex = 9
Top = 1020
Width = 11775
End
Begin VB.Timer Timer1
Enabled = 0 'False
Left = 9240
Top = 7620
End
Begin MSCommLib.MSComm MSComm1
Left = 10890
Top = 7530
_ExtentX = 1005
_ExtentY = 1005
_Version = 393216
DTREnable = -1 'True
InBufferSize = 2048
InputMode = 1
End
Begin VB.PictureBox Picture2
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 315
Left = 180
ScaleHeight = 255
ScaleWidth = 11715
TabIndex = 1
Top = 7650
Width = 11775
End
Begin MSComDlg.CommonDialog CommonDialog1
Left = 10140
Top = 7590
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.PictureBox Picture1
BackColor = &H80000004&
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 6600
Left = 180
ScaleHeight = 6540
ScaleWidth = 11715
TabIndex = 0
Top = 1080
Width = 11775
End
Begin VB.Label Label9
BackColor = &H00404040&
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "Times New Roman"
Size = 12
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H000000FF&
Height = 375
Left = 11130
TabIndex = 13
Top = 540
Width = 825
End
Begin VB.Label Label8
Caption = "Label8"
Height = 525
Left = 5580
TabIndex = 12
Top = 3900
Width = 1245
End
Begin VB.Label Label1
Caption = "Label1"
Height = 525
Left = 5580
TabIndex = 11
Top = 3900
Width = 1245
End
Begin VB.Label Label7
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "状态"
BeginProperty Font
Name = "Times New Roman"
Size = 9
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 225
Left = 180
TabIndex = 7
Top = 540
Width = 390
End
Begin VB.Label Label6
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "接收"
BeginProperty Font
Name = "Times New Roman"
Size = 9
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 225
Left = 8670
TabIndex = 6
Top = 8040
Width = 390
End
Begin VB.Label Label5
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "发送"
BeginProperty Font
Name = "Times New Roman"
Size = 9
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 225
Left = 5400
TabIndex = 5
Top = 8040
Width = 390
End
Begin VB.Label Label2
BackColor = &H00008080&
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "Times New Roman"
Size = 9
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H0000FF00&
Height = 315
Left = 5880
TabIndex = 4
Top = 7980
Width = 2325
End
Begin VB.Label Label3
BackColor = &H00008080&
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "Times New Roman"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H0000FF00&
Height = 345
Left = 9090
TabIndex = 3
Top = 7980
Width = 2595
End
Begin VB.Label Label4
BackColor = &H00008080&
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "Times New Roman"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H0000FF00&
Height = 585
Left = 660
TabIndex = 2
Top = 450
Width = 10275
End
Begin VB.Menu mnSta
Caption = "&S 状态"
Index = 0
Begin VB.Menu mnWay
Caption = "&1 仪器状态"
End
Begin VB.Menu mnTakeCtrl
Caption = "&2 转 监 控"
End
Begin VB.Menu mnGotoCtrl
Caption = "&3 强迫监控"
End
Begin VB.Menu mnDAQ
Caption = "&4 数据采集"
End
Begin VB.Menu mnFunc
Caption = "&5 功能检查"
End
Begin VB.Menu mnStatus
Caption = "&6 状态检查"
End
Begin VB.Menu mnVw
Caption = "&7 实时监视"
End
End
Begin VB.Menu mnPara
Caption = "&P 参数"
Index = 1
Begin VB.Menu mnParaDef
Caption = "&1 缺省设置"
End
Begin VB.Menu mnPara1
Caption = "&2 参数设置"
End
Begin VB.Menu mnParaWin
Caption = "&3 窗参数设置"
End
Begin VB.Menu mnWinDef
Caption = "&4 缺省窗参数"
End
Begin VB.Menu mnWinTime
Caption = "&5 显示窗时间"
End
Begin VB.Menu mnWinCopy
Caption = "&6 复制窗参数"
End
Begin VB.Menu mnSavePara
Caption = "&U 存储参数文件"
End
Begin VB.Menu mnLoadPara
Caption = "&D 装载参数文件"
End
Begin VB.Menu mnPswdChange
Caption = "&C 修改密码"
End
End
Begin VB.Menu mnTime
Caption = "&T 时间"
Index = 2
Begin VB.Menu mnTimeShow
Caption = "&D 显示时间"
End
Begin VB.Menu mnTimeSet
Caption = "&S 设置时间"
End
Begin VB.Menu mnTimeSyn
Caption = "&Y 同步时间"
End
End
Begin VB.Menu mnDat
Caption = "&M 文件"
Index = 3
Begin VB.Menu mnDirDat
Caption = "&1 读文件目录"
Index = 0
End
Begin VB.Menu mnMoreDat
Caption = "&2 读事件摘要"
Index = 1
End
Begin VB.Menu mnDelOneDat
Caption = "&3 删除一文件"
End
Begin VB.Menu mnDelAllDat
Caption = "&4 删全部文件"
End
Begin VB.Menu mnRcvDat
Caption = "&5 恢复一文件"
Index = 4
End
Begin VB.Menu mnOneDat
Caption = "&6 上传一文件"
End
Begin VB.Menu mnAllDat
Caption = "&7 传全部文件"
End
End
Begin VB.Menu mnShow
Caption = "&R 显示"
Index = 4
Begin VB.Menu mnShowWaves
Caption = "&1 数据波形"
Index = 2
End
Begin VB.Menu mnShowEvent
Caption = "&2 触发事件"
Index = 3
End
Begin VB.Menu mnShowHead
Caption = "&3 转储文本"
End
Begin VB.Menu mnShowPara
Caption = "&4 参数副本"
End
End
Begin VB.Menu mnComm
Caption = "&C 通信"
Index = 5
Begin VB.Menu mnDialModem
Caption = "&1拨号操作"
End
Begin VB.Menu mnAnswerModem
Caption = "&2等待应答"
End
End
Begin VB.Menu mnSys
Caption = "&Y 系统"
Index = 6
Begin VB.Menu mnQuit
Caption = "&Q 退回系统"
End
Begin VB.Menu mnSetting
Caption = "&M 方式设置"
End
End
Begin VB.Menu mnHelp
Caption = "&H 帮助"
Index = 7
Begin VB.Menu mnHelp1
Caption = "&1 文本帮助"
End
Begin VB.Menu mnAbout
Caption = "&2 关于系统"
End
End
End
Attribute VB_Name = "fmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'*******************************************************************************************
' Main.frm 主窗口
'*******************************************************************************************
Option Explicit
Dim sPathSir As String '数据文件当前路径
Dim sPathTxt As String '文本文件当前路径
Dim sIc2 As String '选择窗号
Dim flgModeSetting As Boolean 'modem
Dim sMenu As String '菜单选择记录标志
Dim flgBiasAC As Integer '曲线显示是否除去直流分量
Dim nMouseDown As Integer '鼠标右键按下的次数
Dim sNote As String '解释窗内容
Dim s46 As String '用于列表限制格式
Dim flgTest1 As Integer
' 初始化操作
Private Sub Form_Initialize()
sPath = App.path & "\" '当前目录
fmCover.Show 1 '封面显示
LoadInitFile '加载.ini
nNoteTrg = LoadNoteFile(sPath & "NoteTrg.dat", 15, sNoteTrg)
LoadParaDataFile sPath & "Pa1.dat", mPa1, mPs1, nPa1, nPs1 '加载.dat
If Dir(sPath & "sir", vbDirectory) = "" Then MkDir (sPath & "sir") '建立子目录
If Dir(sPath & "sip", vbDirectory) = "" Then MkDir (sPath & "sip")
If Dir(sPath & "txt", vbDirectory) = "" Then MkDir (sPath & "txt")
If Dir(sPath & "para", vbDirectory) = "" Then MkDir (sPath & "para")
End Sub
' 窗体加载操作
Private Sub Form_Load()
With MSComm1 '关闭串口
If .PortOpen Then .PortOpen = False
.InputMode = comInputModeText
End With
List1.Visible = False
With fmMain
.Top = 0: .Left = 0:
If .Width >= Screen.Width - 200 Then
.Width = Screen.Width: .Height = Screen.Height
End If
End With
Picture1.AutoRedraw = True
Picture2.AutoRedraw = True
FlatBar toolbar1
flgModeSetting = False
InitMenu 0
sMenu = "OO0"
End Sub
'窗体作用初始操作
Private Sub Form_Activate()
If flgModeSetting = False Then
flgModeSetting = True
Command1Click
End If
End Sub
'显示说明信息
Public Sub ShowNotes(sText As String)
Label4.Caption = sText
End Sub
'显示发送信息
Public Sub ShowSendMsg(sText As String)
Label2.Caption = sText
End Sub
'显示接收信息
Public Sub ShowRecvMsg(sText As String)
Label3.Caption = sText
End Sub
'**************************************************************************************************
' 基 本 监 控 功 能
'**************************************************************************************************
'基本命令操作
Private Function RunCmd1(STX As String, sNote As String, nSleep As Integer, nTmo As Long) As String
Dim size%, s$
MSComm1.InputMode = comInputModeText
Label2.Caption = "": Label3.Caption = "": Label4.Caption = ""
ShowNotes sNote & "操作"
s$ = STX & vbCr: Label2.Caption = s$: Label2.Refresh:
If SioTxString(MSComm1, s$) Then
ShowNotes "没有设置通信串口, 请设置通信串口 !"
Exit Function
End If
Sleep nSleep
s$ = ""
size% = SioRxLine(MSComm1, s$, SCR, nTmo)
Label3.Caption = s$: Label3.Refresh
If size% = -1 Then
ShowNotes sNote & "操作时间已到"
'Else
' Label4.Caption = sNote & "操作成功"
End If
RunCmd1 = s$
End Function
'长响应时间的命令操作
Private Function RunCmd2(sCmd As String, sNote As String, nSleep As Integer, nTmo As Long) As String
Dim s$
Dim size%, i%
Label3.Caption = "":
Label4.Caption = "执行命令: " & sNote
Label2.Caption = sCmd: Label2.Refresh:
SioTxString MSComm1, sCmd & vbCr
Sleep nSleep
size% = SioRxLine(MSComm1, s$, SCR, 1000)
Label3.Caption = s$: Label3.Refresh
If size% < 0 Then
Label4.Caption = "Timeout 功能检查"
Exit Function
End If
Sleep 22000
For i% = 0 To 10
size% = SioRxLine(MSComm1, s$, SCR, 1000)
Label3.Caption = s$
If size% > 0 Then
ShowNotes "功能检查结束"
Exit Function
End If
Next i%
Label4.Caption = "时间已到"
End Function
'多行响应的命令操作
Private Sub RunRecvLines(sCmd As String, sNote As String, nSleep As Integer, nTmo As Long, n As Integer)
Dim i%, size%, s$
'PubUserFile = ""
List1.Clear: List1.Visible = True
ShowNotes "执行查询命令：" & sNote
Label2.Caption = sCmd: Label2.Refresh:
SioTxString MSComm1, sCmd & vbCr
For i% = 0 To n%
size% = SioRxLine(MSComm1, s$, SCR, nTmo)
If s$ = "" Then
Exit For
Else
Label3.Caption = s$: Label3.Refresh
List1.AddItem Left(s$, Len(s$) - 1), i%
Sleep nSleep
End If
Next i%
End Sub
'显示监控状态
Private Sub ShowCtrl(status As Boolean)
If status <> 0 Then
Label9.Caption = "监控"
Else
Label9.Caption = "数采"
End If
End Sub
'核查是否在监控状态
Private Function CheckCtrl() As Integer
Dim s$
s$ = RunCmd1("S ", "短状态", 10, 3000)
While Mid(s$, 1, 1) <> "M"
If MsgBox("此操作需进入监控状态，OK ?", vbOKCancel) = vbOK Then
s$ = RunCmd1("/ ", "条件监控", 1000, 1000)
Else
ShowCtrl 0: CheckCtrl = 0
Exit Function
End If
Wend
ShowCtrl 1: CheckCtrl = 1
End Function
'**************************************************************************************************
' 状态操作
'**************************************************************************************************
'菜单选项: 短状态操作
Private Sub mnWay_Click()
Dim s$
sMenu = "SSt"
s$ = RunCmd1("S ", "短状态", 10, 3000)
If Len(s$) > 0 Then
ShowCtrl Mid(s$, 1, 1) = "M"
End If
ShowNotes "仪器状态:" & s$
End Sub
'菜单选项: 条件监控
Private Sub mnTakeCtrl_Click()
Dim s$
sMenu = "STc"
s$ = RunCmd1("/ ", "条件监控", 1000, 1000)
If Len(s$) > 0 Then
ShowCtrl Mid(s$, 1, 1) = "M"
End If
ShowNotes "条件监控:" & s$
End Sub
'菜单选项: 强迫监控
Private Sub mnGotoCtrl_Click()
Dim s$
sMenu = "SGc"
s$ = RunCmd1("\ ", "强迫监控", 0, 1000)
If Len(s$) > 0 Then
ShowCtrl Mid(s$, 1, 1) = "M"
End If
ShowNotes "强迫监控:" & s$
End Sub
'菜单选项: 数据采集
Private Sub mnDaq_Click()
Dim s$
sMenu = "SDac"
s$ = RunCmd1("AQ", "数采状态", 1000, 1000)
If Len(s$) > 0 Then
ShowCtrl Mid(s$, 1, 1) <> "A"
End If
ShowNotes "数采状态:" & s$
End Sub
'菜单选项：功能检查
Private Sub mnFunc_Click()
Dim s$, s1$, i%, size%
sMenu = "SFu"
If CheckCtrl = 0 Then
Exit Sub
End If
s1$ = RunCmd1("FT", "启动功能检查", 0, 1000)
If s1$ <> "" Then
For i% = 0 To 35
size% = SioRxLine(MSComm1, s$, SCR, 1000)
If size% > 0 Then
ShowRecvMsg s$
ShowNotes "功能检查完成"
Exit Sub
Else
ShowRecvMsg Format(i%, "0")
End If
Next i%
ShowNotes "功能检查规定时间已到"
End If
End Sub
'菜单选项：状态检查
Private Sub mnStatus_Click()
sMenu = "SCS"
RunRecvLines "ST", "状态检查", 1000, 3000, 5
End Sub
'**************************************************************************************************
' 参数设置
'**************************************************************************************************
'全部参数存入PC文件
Private Sub mnSavePara_Click()
Dim i%, s$, s1$, fname$
sMenu = "Txt"
ShowNotes "仪器 => 保存参数 => PC文件"
CommonDialog1.FileName = ""
CommonDialog1.Filter = "Parameter File(*.prm)|*.prm"
CommonDialog1.InitDir = sPath & "para\"
CommonDialog1.Action = 1
fname$ = CommonDialog1.FileName
If fname$ = "" Then
Exit Sub
End If
On Error GoTo lb1
Open fname$ For Output As #1
For i% = 0 To 41
s$ = "EX " & Format(i% + 1, "0")
s1$ = RunCmd1(s$, "", 200, 2000)
Print #1, s1$
Next i%
lb1:
Close #1
End Sub
'全部参数加载仪器
Private Sub mnLoadPara_click()
Dim i%, s$, s1$, s2$, fname$
sMenu = "Txt"
ShowNotes "PC文件 => 加载参数 => 仪器"
CommonDialog1.FileName = ""
CommonDialog1.Filter = "Parameter File(*.prm)|*.prm"
CommonDialog1.InitDir = sPath & "para\"
CommonDialog1.Action = 1
fname$ = CommonDialog1.FileName
If fname$ = "" Then
Exit Sub
End If
If CheckCtrl = 0 Then
Exit Sub
End If
On Error GoTo lb1
Open fname$ For Input As #1
For i% = 0 To 41
Line Input #1, s1$
If i = 21 Then
s1$ = Mid(s1$, 1, 1)
End If
If i > 8 Then
s$ = "SE " & Format(i% + 1, "0") & " " & s1$
s2$ = RunCmd1(s$, "", 200, 2000)
If s2$ <> "OK" Then
Close #1
Exit Sub
End If
End If
Next i%
lb1:
Close #1
End Sub
'菜单选项: 缺省设置
Private Sub mnParaDef_Click()
If CheckCtrl = 0 Then
Exit Sub
End If
sMenu = "PMD"
RunCmd1 "DE", "参数缺省设置", 1000, 1000
End Sub
'菜单选项: 一类参数
Private Sub mnPara1_Click()
Dim i%, s$, s1$
List1.Clear: List1.Visible = True
' For i% = 0 To 20 '21 => 20
For i% = 0 To 23
s$ = "EX " & Format(i% + 1, "0")
s1$ = RunCmd1(s$, " 参数设置:" & mPa1(i%).sName, 200, 2000)
s46 = mPa1(i%).sName
List1.AddItem s46 & " = " & LTrim(s1$)
Next i%
For i% = 25 To 39
s$ = mPa1(2 + i%).sName '30 => 28
s1$ = RunCmd1("EX " & Format(4 + i%, "00"), "参数设置: " & s$, 0, 1000)
s46 = s$: List1.AddItem s46 & " = " & s1$
Next i%
sMenu = "PR1"
End Sub
'菜单选项: 二类参数
Private Sub mnPara2_Click()
Dim i%, s$, s1$
sMenu = "PR2"
List1.Clear: List1.Visible = True
For i% = 0 To 3
s$ = mPa1(21 + i%).sName '22 => 21
s1$ = RunCmd1("EX " & Format(21 + 1 + i%, "0"), " 二类参数: " & s$, 0, 1000)
s46 = s$: List1.AddItem s46 & " = " & s1$
Next i%
End Sub
'菜单选项: 三类参数
Private Sub mnPara3_Click()
Dim i%, s$, s1$
List1.Clear: List1.Visible = True
For i% = 0 To 14
s$ = mPa1(28 + i%).sName '30 => 28
s1$ = RunCmd1("EX " & Format(28 + 1 + i%, "00"), "三类参数: " & s$, 0, 1000)
s46 = s$: List1.AddItem s46 & " = " & s1$
Next i%
If i% > 14 Then
sMenu = "PR3"
End If
End Sub
'菜单选项: 窗参数
Private Sub mnParaWin_Click()
Dim i%, s$, s1$
List1.Clear: List1.Visible = True
sIc2 = GetNum3(1, 0, 7, "选择参数窗的窗号", ",")
If sIc2 = "" Then
Label4.Caption = "放弃设置窗参数 ！"
Exit Sub
End If
sIc2 = Format(sIc2, "0")
For i% = 0 To 6
's$ = "窗参数：" &
s$ = mPa1(14 + i%).sName '15 => 14
s1$ = RunCmd1("WX " & sIc2 & SP & Format(i% + 14 + 1, "00"), s$, 0, 1000)
s46 = s$: List1.AddItem s46 & " = " & s1$
Next i%
For i% = 7 To 24 '26 => 25
s$ = mPa1(17 + i%).sName
s1$ = RunCmd1("WX " & sIc2 & SP & Format(i% + 18 + 1, "00"), s$, 0, 1000)
s46 = s$: List1.AddItem s46 & "= " & s1$
Next i%
If i% >= 25 Then
sMenu = "PR4"
End If
End Sub
'编辑操作
Private Sub List1_DblClick()
Dim STX$, k1%, k2%, s$, s1$, i%
If Mid(sMenu, 1, 2) <> "PR" Then
Exit Sub
End If
If CheckCtrl = 0 Then
Exit Sub
End If
i% = Val(Mid(sMenu, 3, 1))
k1% = List1.ListIndex
Select Case i%
Case 1: k2% = k1%: If k1% > 23 Then k2% = k1% + 3 '一类参数
Case 2: k2% = k1% + 21
Case 3: k2% = k1% + 28
Case 4:
If k1% < 4 Then
k2 = k1 + 14
Else
k2% = k1% + 17
End If
End Select
s1$ = ParaEditRun(mPa1(k2%).cType, "请输入" & mPa1(k2%).sName, _
mPa1(k2%).nP, mPa1(k2%).ns, mPa1(k2%).V1, mPa1(k2%).V2)
If s1$ = "" Then Exit Sub
Select Case i%
Case 1: '一类参数
If k2% < 24 Then
s$ = "SE " & k2% + 1 & SP & s1$
Else
s$ = "SE " & k2% + 2 & SP & s1$
End If
Case 2: '二类参数
s$ = "SE " & k2% + 1 & " " & s1$
Case 3: '三类参数
s$ = "SE " & k2% + 1 & " " & s1$
Case 4: '窗参数
If k2% < 24 Then
s$ = "WS " & sIc2 & SP & k2% + 1 & SP & s1$
Else
s$ = "WS " & sIc2 & SP & k2% + 2 & SP & s1$
End If
End Select
If RunCmd1(s$, "设置参数：", 0, 1000) = "OK" Then
List1.RemoveItem k1%:
s46 = mPa1(k2%).sName: List1.AddItem s46 & " = " & s1$, k1%: List1.ListIndex = k1%
End If
End Sub
'菜单选项: 复制窗参数
Private Sub mnWinCopy_Click()
Dim s1$
sMenu = "WnC"
Label2.Caption = "": Label3.Caption = "": Label4.Caption = " 复制窗参数"
s1$ = GetNum3(2, 0, 7, "选择复制窗的窗号", " ")
If s1$ = "" Then
ShowNotes "放弃复制窗"
Else
RunCmd1 "WM " & s1$, "复制窗参数 ", 1000, 1000
End If
End Sub
'菜单选项: 缺省窗参数
Private Sub mnWinDef_Click()
Dim s1$
sMenu = "WnO"
ShowNotes "设置缺省窗参数"
s1$ = GetNum3(1, 0, 7, "选择缺省窗参数的窗号", " ")
If s1$ = "" Then
Label4.Caption = "放弃设置窗参数 ！"
Else
RunCmd1 "WC " & s1$, "设置缺省窗参数", 1000, 1000
End If
End Sub
'**************************************************************************************************
' 时间设置
'**************************************************************************************************
'菜单选项: 显示窗时间
Private Sub mnWinTime_Click()
Dim i%, size%, s$
'RunCmd1 "WT", "显示窗时间", 1000, 2500
sMenu = "WnD"
List1.Clear: List1.Visible = True
s$ = "WT" & vbCr: Label2.Caption = s$: Label2.Refresh: SioTxString MSComm1, s$
Sleep 1000
For i% = 0 To 7
size% = SioRxLine(MSComm1, s$, SCR, 2500)
If size% < 0 Then
ShowNotes "结束接收窗时间 " & i%
Exit For
Else
ShowNotes "正在接收窗时间 " & i%
End If
ShowRecvMsg s$:
List1.AddItem s$
Next i%
End Sub
'菜单选项: 显示时间
Private Sub mnTimeShow_Click()
Dim s$
sMenu = "TmD"
s$ = RunCmd1("TC", "显示仪器标准时间", 1000, 1000)
ShowNotes s$
End Sub
'菜单选项: 设置时间
Private Sub mnTimeSet_Click()
Dim s$, s1$
FlagInit = 4
sMenu = "TmD"
s$ = RunCmd1("TC", "读取仪器时间", 1000, 1000)
s1$ = GetDateTime
If s1$ = "" Then
ShowNotes "放弃设置时间"
Else
's$ = RunCmd1("SC " & s1$, "设置标准时间", 1000, 15000)
s$ = "SC " & s1$ & vbCr: Label2.Caption = s$: SioTxString MSComm1, s$: Delay 1000
End If
End Sub
'菜单选项: 建立同步时间
Private Sub mnTimeSyn_Click()
Dim i%, j%, n%, size%, s$
sMenu = "TmS"
List1.Clear: List1.Visible = True
s$ = RunCmd1("TS", "读取同步方式", 0, 1000)
If s$ <> "" Then
Select Case Asc(s$)
Case 71: n% = 420 'GPS
Case 73: n% = 20 'IRIG
Case Else: n% = 0 'No Syn Time device
End Select
End If
j% = 1
For i% = 0 To n%
Label2.Caption = "Waitting : " & i%: Label2.Refresh
If MSComm1.InBufferCount > 0 Then
size% = SioRxLine(MSComm1, s$, SCR, 1000): Label3.Caption = s$: Label3.Refresh
List1.AddItem s$
j% = j% + 1
Else
Sleep 1000
End If
If j% > 3 Then
ShowNotes "同步操作结束"
Exit Sub
End If
Next i%
ShowNotes "同步操作时间已到"
End Sub
'**************************************************************************************************
' 存储操作
'**************************************************************************************************
'菜单选项: 文件目录
Private Sub mnDirDat_Click(Index As Integer)
sMenu = "Dir"
RunRecvLines "FD", "DIR 文件目录", 50, 1000, 200
End Sub
'菜单选项: 文件目录索引
Private Sub mnMoreDat_Click(Index As Integer)
sMenu = "Idx"
RunRecvLines "SU", "获取事件文件摘要", 50, 1000, 200
End Sub
'菜单选项: 删除某一文件数据
Private Sub mnDelOneDat_Click()
Dim s1$
sMenu = "Del"
Label2.Caption = "": Label3.Caption = "": Label4.Caption = ""
If CheckCtrl = 0 Then
Exit Sub
End If
s1$ = InputBox("请输入欲删除的文件号")
If s1$ = "" Then
ShowNotes "放弃删除文件！"
Else
RunCmd1 "EF " & s1$, "删除指定仪器存储文件", 0, 1000
End If
End Sub
'菜单选项: 删除全部文件数据
Private Sub mnDelAllDat_Click()
sMenu = "DeA"
If CheckCtrl = 0 Then
Exit Sub
End If
If MsgBox("真要删除仪器中的全部文件吗 ？", vbOKCancel) = vbOK Then
RunCmd1 "EM", "删除全部文件", 0, 1000
End If
End Sub
'菜单选项: 恢复已删除的文件数据
Private Sub mnRcvDat_Click(Index As Integer)
Dim s1$
sMenu = "Rcv"
s1$ = InputBox("请输入欲恢复的文件号")
If s1$ = "" Then
ShowNotes "放弃文件恢复"
Else
RunCmd1 "UF " & s1$, "恢复指定仪器存储文件", 0, 1000
End If
End Sub
'菜单选项：某一单个文件接收
Private Sub mnOneDat_Click()
Dim sb1() As Byte, ss1() As Byte, sa() As Byte, sb() As Byte, sc() As Byte, sd(2) As Byte
Dim i%, j%, n%, n1%, ik%, size%, s$, s1$
Dim c, crc%
Dim jj As Byte
sMenu = "Rf1"
Label2.Caption = "": Label3.Caption = "": Label4.Caption = "": Label4.Refresh
If CheckCtrl = 0 Then
Exit Sub
End If
fmFname1.List1.Clear
SioTxString MSComm1, "FD" & vbCr
For i% = 0 To 200
size% = SioRxLine(MSComm1, s$, SCR, 1000)
If s$ = "" Then
Exit For
Else
j% = InStr(s$, " "): s$ = Mid(s$, j% + 1)
j% = InStr(s$, " "): s$ = Mid(s$, 1, j% - 1)
fmFname1.List1.AddItem LTrim(s$), i%
Sleep 50
End If
Next i%
fmFname1.nList = i% - 1
fmFname1.Show 1
s1$ = fmFname1.sNoFile
If s1$ = "" Or fmFname1.sFname = "" Then
ShowNotes "放弃操作"
GoTo lb1
End If
s$ = sPath & "SIR\" & fmFname1.sFname & Format(s1$, "0") & ".SIR"
Open s$ For Binary As #1
If Err Then
MsgBox "文件不能打开 !!"
MSComm1.InputMode = comInputModeText
Exit Sub
End If
With MSComm1
.InBufferCount = 0
.OutBufferCount = 0
.InputMode = comInputModeBinary
End With
n% = 0
s$ = "TX " & s1$ & vbCr: Label2.Caption = s$
SioTxString MSComm1, s$
ShowNotes "准备，接收数据文件... "
For i% = 0 To 15
Label2.Caption = " NAK = " & NAK
SioTxString MSComm1, Chr(NAK)
Sleep 1000
size% = SioRxData(MSComm1, sb, 1, 1000)
If size% > 0 Then
Exit For
End If
Label3.Caption = i%
Next i%
If i% >= 15 Then
Label4.Caption = "无响应，检查有无文件！！!": Label4.Refresh
GoTo lb1
End If
j% = 1
Do
For i% = 0 To 2 '三次
c = sb(0)
Select Case c
Case SOH: n1% = 128: s$ = "小包"
Case STX: n1% = 1024: s$ = "大包"
Case EOT:
ShowNotes "收到文件结束标志，发ACK"
ShowSendMsg "ACK = " & ACK
SioTxString MSComm1, Chr(ACK)
Exit Do
Case Else:
ShowNotes "非要求命令，请确认监控状态!!!"
GoTo lb1
End Select
size% = SioRxData(MSComm1, sa, 2, 1000)
If size% < 0 Then
ShowNotes "读取包号超时，退出 ！"
Exit Do
End If
If SioRxData(MSComm1, ss1, n1%, 2000) < 0 Then
ShowNotes "读包数据内容超时，退出"
Exit Do
End If
If SioRxData(MSComm1, sc, 2, 1000) < 0 Then
ShowNotes "未读到数据包的CRC校验字，退出"
Exit Do
End If
ShowRecvMsg sa(0) & ":" & sa(1) & ", " & sc(0) & ":" & sc(1): Label3.Refresh
crc% = 0
For ik% = 0 To n1% - 1
crc% = UpdateCRC(crc%, ss1(ik%))
Next ik%
IToC2 crc%, sd(0), sd(1)
ShowNotes "读数据包: " & j%
jj = j% Mod 256
If sa(0) = jj And sd(0) = sc(0) And sd(1) = sc(1) Then
Put #1, , ss1
Label2.Caption = " ACK= " & Chr(ACK)
SioTxString MSComm1, Chr(ACK)
If SioRxData(MSComm1, sb, 1, 10000) < 0 Then
ShowNotes "未收到下一个命令符 ！！！"
GoTo lb1
End If
Exit For
Else
ShowNotes "CRC校验出错，请求重发": Label2.Caption = " NAK= " & Chr(NAK)
SioTxString MSComm1, Chr(NAK)
If SioRxData(MSComm1, sb, 1, 10000) < 0 Then
ShowNotes "未收到下一个命令符 ！！！"
GoTo lb1
End If
End If
Next i%
If i% >= 3 Then
ShowNotes "已试三次，退出"
GoTo lb1
End If
j% = j% + 1
Loop
ShowNotes "数据接收结束"
lb1:
Close #1
MSComm1.InputMode = comInputModeText
End Sub
'菜单选项: 全部文件接收
Private Sub mnAllDat_Click()
Dim Files$, filenames$, s$
Dim i%, j%, size%, m1%, crc%, n1%, ik%
Dim sb1() As Byte, ss1() As Byte, sa() As Byte, sb() As Byte, sc() As Byte, sd(2) As Byte
Dim c
sMenu = "RfA"
Label2.Caption = "": Label3.Caption = "": Label4.Caption = ""
If CheckCtrl = 0 Then
Exit Sub
End If
fmFname.Label1.Caption = "选择保存全部仪器文件的PC文件名"
fmFname.Combo1.Enabled = False
fmFname.Dir1.path = sPath & "sir"
fmFname.Text1.Text = ""
fmFname.Show 1
If fmFname.FullPath.Text = "" Then
fmFname.Combo1.Enabled = True
Exit Sub
End If
Files$ = fmFname.FullPath.Text
With MSComm1
.InBufferCount = 0
.OutBufferCount = 0
.InputMode = comInputModeBinary
End With
List1.Clear: List1.Visible = True
s$ = "TM" & vbCr: Label2.Caption = s$
SioTxString MSComm1, s$
Label4.Caption = "正在... 发送= " & s$: Label4.Refresh
Do
For i% = 0 To 20
SioTxString MSComm1, Chr(NAK)
Label2.Caption = " NAK = " & NAK: Label4.Caption = " ... 发送 NAK " & i%: Label4.Refresh
size% = SioRxData(MSComm1, sb, 1, 3000)
If size% > 0 Then
Label3.Caption = "sb(0)= " & sb(0): Label3.Refresh
c = sb(0)
Select Case c
Case BOF:
Label4.Caption = "串行通信... 返回 BOF= " & Str(sb(0)): Label4.Refresh
Exit For
Case CAN:
s$ = Chr(ACK)
Label2.Caption = s$
SioTxString MSComm1, s$
Label4.Caption = "接收文件结束": Label4.Refresh
GoTo lb1 'Exit Sub
End Select
End If
Label4.Caption = "第" & i% & "号读取超时": Label4.Refresh
If i% >= 20 Then
Label4.Caption = " 请 切 换 到 监 控 状 态 !!!": Label4.Refresh
GoTo lb1 'MSComm1.InputMode = comInputModeText: Exit Sub
End If
Next i%
size% = SioRxData(MSComm1, sb, 2, 1000)
If size% < 0 Then
Label4.Caption = " 接收文件退出 !!!"
GoTo lb1 'Exit Sub
End If
m1% = sb(0) * 256 + sb(1)
Label3.Caption = "File code:" & m1%
filenames$ = Files$ & m1% & ".SIR"
Open filenames$ For Binary As #1
If Err Then
MsgBox "File can not open !!"
GoTo lb1
End If
List1.AddItem filenames$
ShowNotes " 文件：" & filenames$: Label4.Refresh
For i% = 0 To 15
SioTxString MSComm1, Chr(NAK): Label2.Caption = " NAK = " & i%: Label2.Refresh
size% = SioRxData(MSComm1, sb, 1, 3000)
If size% > 0 Then Exit For
Next i%
If i% >= 15 Then
Label4.Caption = " 读包退出 !!!": Label4.Refresh
GoTo lb1
End If
Label3.Caption = sb(0): Label3.Refresh
j% = 1
Do
For i% = 0 To 2
c = sb(0): Label3.Caption = "Command Code:" & c
Select Case c
Case SOH: n1% = 128
Case STX: n1% = 1024
Case CAN: Exit Do
Case EOT:
Label4.Caption = "接收全部文件结束": Label4.Refresh
Label2.Caption = ""
SioTxString MSComm1, Chr(ACK)
Exit Do
Case Else
Label4.Caption = "接收字符出错, 文件名为:" & filenames
GoTo lb1
End Select
If SioRxData(MSComm1, sa, 2, 1000) < 0 Then
Label4.Caption = "无包号数据 !!!"
GoTo lb1
End If
Label3.Caption = "packge:" & Str(sa(0))
Label4.Caption = "正在接收文件... ": Label4.Refresh
If SioRxData(MSComm1, ss1, n1%, 3000) < 0 Then
Label4.Caption = "无包内数据 !!!"
GoTo lb1
End If
If SioRxData(MSComm1, sc, 2, 1000) < 0 Then
Label4.Caption = "无校验数据 !!!"
GoTo lb1
End If
crc% = 0
For ik% = 0 To n1% - 1
crc% = UpdateCRC(crc%, ss1(ik%))
Next ik%
IToC2 crc%, sd(0), sd(1)
If sd(0) = sc(0) And sd(1) = sc(1) Then
Put #1, , ss1
Label2.Caption = ""
SioTxString MSComm1, Chr(ACK)
If SioRxData(MSComm1, sb, 1, 10000) < 0 Then
Label4.Caption = "无命令出现 !!!"
GoTo lb1 'Exit Do
End If
Exit For
Else
Label2.Caption = ""
SioTxString MSComm1, Chr(NAK)
If SioRxData(MSComm1, sb, 1, 10000) < 0 Then
Label4.Caption = "无命令出现 !!!"
GoTo lb1 'Exit Do
End If
End If
Label3.Caption = sb(0)
Next i%
j% = j% + 1
Loop
Close #1
Loop
lb1:
MSComm1.InputMode = comInputModeText
fmFname.Combo1.Enabled = True
End Sub
'*************************************************************************************************
' 文件显示
'*************************************************************************************************
'菜单选项：转存的文本文件显示
Private Sub mnShowHead_Click()
Dim b1 As Byte, i%, i2%, n%
Dim fname$, s$, s2$
sMenu = "LTxt"
CommonDialog1.FileName = ""
CommonDialog1.Filter = "All Files (*.*)|*.*| Head File(*.hd)|*.hd| Trig File(*.sip)|*.sip| Data File(*.x)|*.?"
CommonDialog1.InitDir = sPath & "txt\"
CommonDialog1.Flags = OFN_READONLY
CommonDialog1.Action = 1
fname$ = CommonDialog1.FileName
ShowNotes "显示转储的文本文件 " & fname$
If fname$ = "" Then
Exit Sub
End If
On Error Resume Next
Open fname$ For Input As #1
If Err Then
ShowNotes "无文件调用！"
Close #1
Exit Sub
End If
List1.Clear
Do While Not EOF(1)
Line Input #1, s$
List1.AddItem s$
Loop
List1.Visible = True
List1.Refresh
Close 1#
End Sub
'菜单选项：读参数文件
Private Sub mnShowPara_click()
Dim i%, s$, s1$, fname$
sMenu = "LTxt"
ShowNotes "从PC文件读取参数"
List1.Clear: List1.Visible = True
CommonDialog1.FileName = ""
CommonDialog1.Filter = "Parameter File(*.prm)|*.prm"
CommonDialog1.InitDir = sPath & "para\"
CommonDialog1.DefaultExt = 1
CommonDialog1.ShowOpen
fname$ = CommonDialog1.FileName
If fname$ = "" Then
Exit Sub
End If
On Error GoTo lb1
Open fname$ For Input As #1
For i% = 0 To 41
Line Input #1, s1$
List1.AddItem mPa1(i%).sName & " : " & s1$
Next i%
Close #1
Exit Sub
lb1: ShowNotes "文件不存在"
End Sub
'菜单选项：触发文件显示
Private Sub mnShowEvent_Click(Index As Integer)
Dim m_Str2(20) As m_String2
Dim b1 As Byte, i%, i2%, n%
Dim filenames$, s$, s2$
sMenu = "LTrg"
CommonDialog1.FileName = ""
CommonDialog1.Filter = "All Files|*.SIP"
CommonDialog1.InitDir = sPath & "SIP\"
CommonDialog1.Flags = OFN_READONLY
CommonDialog1.Action = 1
filenames$ = CommonDialog1.FileName
If filenames$ = "" Then
Exit Sub
End If
On Error Resume Next
Open filenames$ For Input As #1
If Err Then
ShowNotes "无文件调用！"
Close #1
Exit Sub
End If
Line Input #1, s$
Close 1#
If s$ = "" Then
ShowNotes "文件类型不匹配或损坏."
Exit Sub
End If
s2$ = ""
List1.Clear: List1.Visible = True
i% = 0: n% = 0: i2% = 0
Do
n% = InStr(s$, ",")
m_Str2(i%).StrX = Left(s$, n% - 1)
s$ = Mid(s$, n% + 1)
i% = i% + 1
Loop Until i% >= 19
n% = InStr(s$, "!")
m_Str2(i%).StrX = Left(s$, n% - 1)
s$ = filenames$
n% = InStr(s$, "\")
While n% <> 0
s$ = Mid(s$, n% + 1)
n% = InStr(s$, "\")
Wend
List1.AddItem " The Record File Name is: " & s$
List1.AddItem " Unit Serial Number is: " & m_Str2(18).StrX
List1.AddItem " Channel 1 Pos. Max Value is: " & m_Str2(0).StrX & " gal. Received time is: " & m_Str2(6).StrX
List1.AddItem " Channel 1 Neg. Max Value is: " & m_Str2(1).StrX & " gal. Received time is: " & m_Str2(7).StrX
List1.AddItem " Channel 2 Pos. Max Value is: " & m_Str2(2).StrX & " gal. Received time is: " & m_Str2(8).StrX
List1.AddItem " Channel 2 Neg. Max Value is: " & m_Str2(3).StrX & " gal. Received time is: " & m_Str2(9).StrX
List1.AddItem " Channel 3 Pos. Max Value is: " & m_Str2(4).StrX & " gal. Received time is: " & m_Str2(10).StrX
List1.AddItem " Channel 3 Neg. Max Value is: " & m_Str2(5).StrX & " gal. Received time is: " & m_Str2(11).StrX
List1.AddItem " The Main Frequency is: " & Val(m_Str2(12).StrX) * 0.01 & " Hz"
List1.AddItem " The Duration Time is: " & m_Str2(13).StrX & " ms."
List1.AddItem " The 1st Frequency response sprectrum Max Value is: " & m_Str2(14).StrX & " gal."
List1.AddItem " The 2nd Frequency response sprectrum Max Value is: " & m_Str2(15).StrX & " gal."
List1.AddItem " The 3nd Frequency response sprectrum Max Value is: " & m_Str2(16).StrX & " gal."
List1.AddItem " The 4nd Frequency response sprectrum Max Value is: " & m_Str2(17).StrX & " gal."
List1.AddItem " The Refernce Intention is: " & m_Str2(19).StrX & " ."
ShowNotes "显示触发文件 " & filenames$
End Sub
' 打印列表
Sub Print_List()
Dim i%, s$
Printer.PrintQuality = -4
For i% = 0 To List1.ListCount - 1
s$ = List1.List(i)
Printer.Print s$
Next i%
Printer.EndDoc
End Sub
'菜单选项：图形显示
Private Sub mnShowWaves_Click(Index As Integer)
Dim filenames As String
Dim l As Long, s$, s0$, s1$, s2$, n%, i%
List1.Clear: List1.Visible = False
Label1.Caption = "": Label2.Caption = "": Label3.Caption = "":
ShowNotes " 图形显示"
CommonDialog1.FileName = ""
CommonDialog1.Filter = "All Files|*.SIR"
CommonDialog1.InitDir = sPath & "SIR\"
CommonDialog1.Flags = OFN_READONLY
CommonDialog1.ShowOpen
s$ = CommonDialog1.FileTitle
n% = InStr(s$, ".")
If n% <= 0 Then
ShowNotes "非适当文件名, 重选"
Exit Sub
End If
sPathTxt = sPath & "txt\" & Left(s$, n% - 1)
sPathSir = CommonDialog1.FileName
filenames = sPathSir
If filenames = "" Then
ShowNotes "非适当文件名, 重选"
Exit Sub
End If
l = filelen(filenames)
If l < 100 Then
ShowNotes "非适当文件, 重选"
Exit Sub
End If
If LoadDataFile(filenames) < 0 Then
Exit Sub
End If
With m_Head
s2$ = ""
For i% = 1 To 32
s2$ = s2$ & Chr(.hcmnt(i))
Next i%
s1$ = "仪器号：" & .hsnum & " 文件名：" & s$ & " 用户注释：" & s2$
s$ = "触发时间：" & yyyy$ & "年 " & .start_time(2) & "月 " & .start_time(3) & "日 "
s$ = s$ & .start_time(4) & "时 " & .start_time(5) & "分 " & .start_time(6) & "秒"
s$ = s$ & " 经度：" & Chr(.EW) & .hlgdeg & "度 " & .hlgmin & "分 " & .hlgsec & "秒"
s$ = s$ & " 纬度：" & Chr(.ns) & .hltdeg & "度 " & .hltmin & "分 " & .hltsec & "秒"
ShowNotes s1$ & Chr(13) & s$
sNote = s1$ & vbCr & s$
End With
If m_Head.hazm1 > 0 Then
s$ = " 偏" & Format(m_Head.hazm1, "0") & "度"
Else
s$ = ""
End If
w.Init 3, nData, yData, Ts
w.SetColorFont RGB(64, 64, 64), RGB(192, 192, 192), RGB(192, 192, 192)
w.SetColorLine RGB(192, 192, 192), vbRed, vbMagenta
w.SetColorWaveCh 0, vbGreen
w.SetColorWaveCh 1, RGB(255, 255, 0)
w.SetColorWaveCh 2, RGB(127, 127, 255)
w.SetChannel 0, "Ch1:垂直" & "", vbGreen, sUnit
w.SetChannel 1, "Ch2:北南" & s$, vbGreen, sUnit
w.SetChannel 2, "Ch3:东西" & s$, vbGreen, sUnit
w.Run Picture1, yData
w.RunIRIG Picture2, IRIG
sMenu = "Wave"
End Sub
' 波形 X 轴方向滚动
Private Sub HScroll1_Change()
Dim r#
If sMenu <> "Wave" Then Exit Sub
r# = HScroll1.Value / HScroll1.Max
w.SetStartX 0, r#, Picture1, yData
w.RunIRIG Picture2, IRIG
End Sub
'鼠标点动
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim k1 As Long
If sMenu <> "Wave" Then Exit Sub
If Button = 1 Then
w.ShowCursor Picture1, yData, x
Else
k1 = w.ShowLocal(Picture1, yData, x, nMouseDown)
If nMouseDown < 2 Then
nMouseDown = nMouseDown + 1
Else
nMouseDown = 0
w.RunIRIG Picture2, IRIG
HScroll1.Value = (k1 / nData) * HScroll1.Max
End If
End If
End Sub
Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If sMenu <> "Wave" Then Exit Sub
If Button = 1 Then
w.ShowCursor Picture1, yData, x
End If
End Sub
Private Sub Text1_Change()
End Sub
'**************************************************************************************************
'工具栏操作
'**************************************************************************************************
Private Sub Toolbar1_ButtonClick(ByVal Button As ComctlLib.Button)
Dim i%, b(10) As Single
If Button.Index = 9 Then
CommonDialog1.PrinterDefault = True
CommonDialog1.CancelError = True
CommonDialog1.Flags = ALLPAGES
CommonDialog1.ShowPrinter
If Err Then Exit Sub
If Mid(sMenu, 1, 1) = "L" Then
ShowNotes "打印列表 ..."
Print_List
End If
If Mid(sMenu, 1, 1) = "W" Then
ShowNotes "打印波形 ... "
w.RunPrn Printer, yData, IRIG, sNote
End If
Printer.EndDoc
End If
If sMenu <> "Wave" Then Exit Sub
Select Case Button.Index
Case 1: w.SetScaleX 1, 0.8, Picture1, yData
w.RunIRIG Picture2, IRIG
Case 2: w.SetScaleX 1, 1.25, Picture1, yData
w.RunIRIG Picture2, IRIG
Case 3: w.SetScaleY 1, 0.8, Picture1, yData
Case 4: w.SetScaleY 1, 1.25, Picture1, yData
Case 10: w.SetScaleY 1, 0.5, Picture1, yData
Case 11: w.SetScaleY 1, 2#, Picture1, yData
Case 5: 'Curve_Init
HScroll1.Value = 0
w.SetScaleX 0, nData, Picture1, yData
w.RunIRIG Picture2, IRIG
Case 6: '恢复初始
HScroll1.Value = 0
w.SetScale0
w.Run Picture1, yData
w.RunIRIG Picture2, IRIG
Case 7: '直流偏移
If flgBiasAC = 0 Then
flgBiasAC = 1
For i% = 0 To nCh - 1
b(i%) = dAve(i%)
Next i%
Else
flgBiasAC = 0
For i% = 0 To nCh - 1
b(i%) = 0
Next i%
End If
w.SetBias nCh, b, Picture1, yData
Case 8: '文件
Beep
If sPathSir <> "" Then
SaveTextFile sPathSir, sPathTxt
ShowNotes "从数据文件生成文本文件(.sir => .hd, .xx, .sip)"
Else
ShowNotes "请执行图形显示,以确定数据文件"
End If
End Select
End Sub
'**************************************************************************************************
'菜单屏蔽
'**************************************************************************************************
Sub InitMenu(bl As Byte)
Select Case bl
Case 1:
mnSta(0).Enabled = True
mnPara(1).Enabled = True
mnTime(2).Enabled = True
mnDat(3).Enabled = True
Case 0:
mnSta(0).Enabled = False
mnPara(1).Enabled = False
mnTime(2).Enabled = False
mnDat(3).Enabled = False
End Select
If flgMode = 0 Then
mnComm(5).Enabled = False
Else
mnComm(5).Enabled = True
End If
End Sub
'调试时用于显示菜单
Private Sub Label7_DblClick()
mnSta(0).Enabled = True
mnPara(1).Enabled = True
mnTime(2).Enabled = True
mnDat(3).Enabled = True
mnComm(5).Enabled = True
flgTest1 = 1
End Sub
'**************************************************************************************************
' 求助操作
'**************************************************************************************************
'菜单选项: 求助-文本
Private Sub mnHelp1_Click()
sMenu = "Hlp"
Shell "c:\windows\winhelp " & sPath & "gdqj.hlp", 1
End Sub
'菜单选项: 求助-关于
Private Sub mnAbout_Click()
sMenu = "Abt"
fmMark.Label1 = "GDQJ-1A-V3.0 for Windows 地震动强度远程采集系统"
fmMark.Label2 = "国家地震局 哈尔滨工程力学研究所"
'fmMark.Picture1.Picture = "gdqj2.bmp"
fmMark.Show 1
End Sub
'**************************************************************************************************
' 菜 单 选 项 操 作
'**************************************************************************************************
'菜单选项: 系统操作
Private Sub mnQuit_Click()
If flgMode = 0 Then
SioTxString MSComm1, "QT" & vbCr
End If
If MSComm1.PortOpen Then
MSComm1.PortOpen = False
End If
SaveInitFile
End
End Sub
'菜单选项: 系统-方式设置
Private Sub mnSetting_Click()
Command1Click
End Sub
Private Sub Command1Click()
Label2.Caption = "": Label3.Caption = "": Label4 = "": Label4.Refresh
DelAA
If flgMode = 1 Then
HandleOff
End If
fmSetComm.Show 1
If fmSetComm.flgChange = 0 Then
Label4.Caption = "放弃串口设置"
Exit Sub
End If
CommInit MSComm1, CommPort, CommSetting
Label2.Caption = CommPort & ", " & CommSetting: Label2.Refresh
Sleep 1000
Label4.Caption = "设置串口和调制解调器 !": Label4.Refresh
flgConn = 0: flgDial = 0
If flgMode = 1 Then
If SetupModem = 0 Then
SetAA
flgConn = 1
InitMenu 0
Label4.Caption = "公用电话网络方式: 自动应答状态"
Else
Sleep 1500
InitMenu 0: 'mnComm(6).Enabled = False
Label4.Caption = "公用电话网络方式: 设置失败状态"
End If
Else
If CheckPassword = 0 Then '检查口令
InitMenu 1
Label4.Caption = "串口直接连接方式: 连接成功状态(口令通过)"
Else
Sleep 1500
InitMenu 0
Label4.Caption = "串口直接连接方式: 设置失败状态(重设串口或口令)"
End If
End If
' flgDial = 0: flgConn = 0
End Sub
Sub Command2Click()
SetupModem
End Sub
'建立调制解调器, 设置在自动应答状态
Function SetupModem()
Dim i%, size%, s$
Label2.Caption = "": Label3 = "": Label4 = ""
If Not MSComm1.PortOpen Then
Label4.Caption = " 请设置串口！": Label4.Refresh
SetupModem = -1
Exit Function
End If
Label4.Caption = "初始化Modem": Label4.Refresh
MSComm1.DTREnable = True
MSComm1.RTSEnable = True
s$ = "ATE0S7=60S11=60V1Q0S0=1" & vbCr
Label2.Caption = s$: Label2.Refresh
SioTxString MSComm1, s$: Sleep 300:
For i% = 0 To 2
s$ = ""
size% = SioRxLine(MSComm1, s$, SCR, 3000)
Label3.Caption = s$: Label3.Refresh
If size% < 0 Then
Exit For
End If
If InStr(s$, "OK") > 0 Then
Label4.Caption = "调制解调器设置成功 !!"
SetupModem = 0
Exit Function
End If
Next i%
Label4.Caption = "调制解调器设置失败 !!!": Label4.Refresh
SetupModem = -2
End Function
' 通讯设置与操作
'菜单选项: 通信-拨号方式
Private Sub mnDialModem_Click()
Command3Click
End Sub
Sub Command3Click()
MSComm1.InputMode = comInputModeText
flgDial = 1
If flgMode = 0 Then
Label4.Caption = " 直接连接方式不需要拨号 ！": Label4.Refresh
Exit Sub
End If
DelAA
If flgConn > 0 Then
Sleep 2000: flgConn = 0 '2000/11/26
Label4.Caption = " 请先挂机后再拨号 ！": Label4.Refresh
HandleOff
flgConn = 0: flgDial = 0
End If
If RunDial = 0 Then '拨号
flgConn = 1 '1/12
Sleep 500
If CheckPassword = 0 Then '检查口令
InitMenu 1
Exit Sub
End If
End If
Sleep 2000
InitMenu 0
flgConn = 0: flgDial = 0
HandleOff '挂机
End Sub
'拨号操作
Function RunDial()
Dim size%, s$, s1$
Label2.Caption = "": Label3.Caption = "": Label4.Caption = " 启动Modem"
fmSelPhone.Show 1
s$ = sPhoneNum
If s$ = "" Or flgCancel = True Then
Label4.Caption = "放弃拨号 :": Label4.Refresh
RunDial = -1
Exit Function
End If
Label4.Caption = " 正在拨号 " & s$: Label4.Refresh
s1$ = "AT DT" & s$ & vbCr: Label2.Caption = s1$: Label2.Refresh
SioTxString MSComm1, s1$: 'Sleep 5000
size% = SioRxLine(MSComm1, s$, SCR, 40000)
Label3.Caption = s$: Label3.Refresh
' SioFlush MSComm1
If size% < 0 Then
Label4.Caption = "拨号超时, 连接失败 !": Label4.Refresh
RunDial = -2
Exit Function
End If
If InStr(s$, "CONNECT") <= 0 Then
Label4.Caption = "无拨号音, 或占线!!!": Label4.Refresh
RunDial = -3
Exit Function
End If
lb1:
Label4.Caption = "话路连接成功 !!": Label4.Refresh
RunDial = 0
End Function
'检查口令
Function CheckPassword()
Dim s$, s1$, s2$, i%, n%, size%
Label4.Caption = "检查口令!!": Label4.Refresh
SioTxString MSComm1, vbCr: Sleep 3000
s$ = "": s2$ = ""
For i% = 0 To 5
size% = SioRxString0(MSComm1, s1$, 0, 2000)
s$ = s$ & s1$
n% = InStr(s1$, vbCr)
While n% > 0
s2$ = s2$ & Left(s1$, n% - 1) & ""
s1$ = Mid(s1$, n% + 1)
n% = InStr(s1$, vbCr)
Wend
s2$ = s2$ & s1$ & ":" & i%
Label2.Caption = s$
Label3.Caption = s2$: Label3.Refresh
If InStr(s$, "PASSWORD") > 0 Then
fmPswd.Show 1 's1$ = "IEM9804" & vbCR
Label2.Caption = sPassword: Label2.Refresh
If sPassword = "" Or flgCancel = True Then
GoTo lb1
End If
SioTxString MSComm1, sPassword & vbCr: Sleep 500
size% = SioRxString(MSComm1, s$, 1, 1000)
Label3.Caption = s$: Label3.Refresh:
's$ = Chr(6)
If Asc(s$) = 6 Then
Label4.Caption = "口令正确, 通信联接成功 !": Label4.Refresh
If flgKeepPwd = 0 Then
sPassword = ""
End If
SioFlush MSComm1
CheckPassword = 0
Exit Function
End If
Label4.Caption = "口令不正确 ! "
sPassword = ""
End If
Next i%
Label4.Caption = "通信联接未成功, 超时退出 !"
lb1:
s$ = "QT" & vbCr: Label2.Caption = s$
SioTxString MSComm1, s$
CheckPassword = -1
End Function
'挂机操作
Sub HandleOff()
Dim size%, s$
Label4.Caption = "正在挂机...请稍候": Label4.Refresh
Sleep 100: MSComm1.DTREnable = True
Sleep 100: MSComm1.DTREnable = False
Sleep 500: MSComm1.DTREnable = True
s$ = "AT H0": Label2.Caption = s$: Label2.Refresh:
SioTxString MSComm1, s$ & vbCr
Sleep 1000
size% = SioRxLine(MSComm1, s$, SCR, 2000)
Label3.Caption = s$: Label4.Caption = "挂机": Label4.Refresh
End Sub
'菜单选项: 通信-应答方式
Private Sub mnAnswerModem_Click()
Dim s$
MSComm1.InputMode = comInputModeText
Label2.Caption = "": Label3.Caption = "": Label4.Caption = ""
If flgMode = 1 Then
Label4.Caption = "结束通信，发结束信号": Label4.Refresh
s$ = "QT" & vbCr: Label2.Caption = s$
SioTxString MSComm1, s$
Sleep 500
End If
InitMenu 0
flgConn = 0: flgDial = 0
HandleOff
Sleep 1000
SetAA
End Sub
'等待连接事件, 自动应答
Public Sub MSComm1_OnComm()
If flgConn <= 0 Then
Exit Sub
End If
Select Case MSComm1.CommEvent
' Events
Case comEvCD ' Change in the CD line.
'MsgBox "RunAA"
' flgConn = 2
DelAA ' : RunAA : SetAA
HandleOff
flgConn = 0
' flgDial = 0
End Select
End Sub
'设置自动应答
Sub SetAA()
If flgMode = 1 And flgConn = 0 And flgDial = 0 Then
Timer1.Interval = 5000
Timer1.Enabled = True
MSComm1.InBufferCount = 0
End If
End Sub
'取消自动应答
Sub DelAA()
'If flgMode = 1 Then
Timer1.Enabled = 0
MSComm1.RThreshold = 0
MSComm1.InBufferCount = 0
'End If
End Sub
'自动应答操作
Sub RunAA()
Dim MyData, MyTime, iRec As Integer, cRec(256) As Byte
Dim ib As Boolean, c
Dim n%, m%, d%, h%, nbuf%, s$, s1$, s2$
Dim sb1() As Byte, ss1() As Byte, sa() As Byte, sb() As Byte, sc() As Byte, sd(2) As Byte
Dim size%, yq1%, mi%, se%, n1%, i%, j%, crc%, ik%
Dim jj As Byte
Dim stotal&, filenames$
Label2.Caption = "": Label3.Caption = "": Label4.Caption = ""
InitMenu 0
Label4.Caption = " 等待 CONNECT, 可通过菜单退出！": Label4.Refresh
s1$ = ""
Do
nbuf% = MSComm1.InBufferCount
If nbuf% > 0 Then
Sleep 20
s$ = MSComm1.Input
s1$ = s1$ & s$
Label3.Caption = s1$ & "," & nbuf%: Label3.Refresh
If InStr(s1$, "CONNECT") > 0 Then
Label4.Caption = "通信连接成功 !!!": Label4.Refresh
SioFlush MSComm1
Exit Do
End If
End If
DoEvents
Loop
MSComm1.InputMode = comInputModeBinary
SioTxString MSComm1, Chr(ACK)
MSComm1.InputMode = comInputModeText
size% = SioRxLine(MSComm1, s$, SCR, 10000)
SioFlush MSComm1
MSComm1.InputMode = comInputModeBinary
n% = 0
Sleep 500
Do
Label2.Caption = "NAK => " & n%: Label2.Refresh: 'Sleep 1000
SioTxString MSComm1, Chr(NAK)
size% = SioRxData(MSComm1, sb, 1, 10000)
n% = n% + 1
If n% >= 15 Then GoTo lb1
DoEvents
Loop Until size% > 0
MyData = Now
yq1% = Year(MyData) - 1998: m% = Month(MyData): d% = Day(MyData)
MyTime = Time
h% = Hour(MyTime): mi% = Minute(MyTime): se% = Second(MyTime)
stotal& = (yq1% * 12& + m%) * 31& + d%
stotal& = ((stotal& * 24& + CLng(h%)) * 60 + CLng(mi%)) * 60 + CLng(se%)
filenames$ = sPath & "SIP\" & stotal& & ".SIR"
Open filenames$ For Binary As #1
j% = 1
Do
For i% = 0 To 2 '三次
c = sb(0)
Select Case c
Case SOH: n1% = 128: s$ = "小包"
Case STX: n1% = 1024: s$ = "大包"
Case EOT:
ShowNotes "收到文件结束标志，发ACK"
ShowSendMsg "ACK = " & ACK
SioTxString MSComm1, Chr(ACK)
Exit Do
Case Else:
ShowNotes "非要求命令，请确认监控状态!!!"
GoTo lb1
End Select
size% = SioRxData(MSComm1, sa, 2, 1000)
If size% < 0 Then
ShowNotes "读取包号超时，退出 ！"
Exit Do
End If
If SioRxData(MSComm1, ss1, n1%, 2000) < 0 Then
ShowNotes "读包数据内容超时，退出"
Exit Do
End If
If SioRxData(MSComm1, sc, 2, 1000) < 0 Then
ShowNotes "未读到数据包的CRC校验字，退出"
Exit Do
End If
ShowRecvMsg sa(0) & ":" & sa(1) & ", " & sc(0) & ":" & sc(1): Label3.Refresh
crc% = 0
For ik% = 0 To n1% - 1
crc% = UpdateCRC(crc%, ss1(ik%))
Next ik%
IToC2 crc%, sd(0), sd(1)
ShowNotes "读数据包: " & j%
jj = j% Mod 256
If sa(0) = jj And sd(0) = sc(0) And sd(1) = sc(1) Then
Put #1, , ss1
Label2.Caption = " ACK= " & Chr(ACK)
SioTxString MSComm1, Chr(ACK)
If SioRxData(MSComm1, sb, 1, 10000) < 0 Then
ShowNotes "未收到下一个命令符 ！！！"
GoTo lb1
End If
Exit For
Else
ShowNotes "CRC校验出错，请求重发": Label2.Caption = " NAK= " & Chr(NAK)
SioTxString MSComm1, Chr(NAK)
If SioRxData(MSComm1, sb, 1, 10000) < 0 Then
ShowNotes "未收到下一个命令符 ！！！"
GoTo lb1
End If
End If
Next i%
If i% >= 3 Then
ShowNotes "已试三次，退出"
GoTo lb1
End If
j% = j% + 1
Loop
ShowNotes "数据接收结束"
lb1:
Close #1
MSComm1.InputMode = comInputModeText
s$ = "QT" & vbCr: Label2.Caption = s$
SioTxString MSComm1, s$:
Sleep 500 '1000
HandleOff
End Sub
'定时查询
Private Sub Timer1_Timer()
Dim nbuf%
Timer1.Enabled = 0
nbuf% = MSComm1.InBufferCount
Label2.Caption = "": Label3.Caption = ""
Label3.Caption = nbuf%
Label4.Caption = "等待站点信息 ! " & Format(Time, "hh:nn:ss")
If nbuf% > 6 Then
Beep
DelAA
RunAA
SetAA
End If
Timer1.Enabled = True
End Sub
'菜单选项: 修改密码
Private Sub mnPswdChange_Click()
Dim s$, s1$, n%
fmPswdC.Show 1
n% = Len(fmPswdC.sPswd1)
If n% > 0 Then
s$ = "NP " & Format(n, "0") & fmPswdC.sPswd1 '& "," & fmpswd1.sPswd0
s1$ = RunCmd1(s$, "修改密码", 1000, 1000)
ShowNotes "修改密码:" & s1$
If s1$ = "Ok" Then
MsgBox "修改密码成功！"
End If
End If
End Sub
'菜单选项: 实时监控
Private Sub mnVw_Click()
Static ndata0 As Long
Dim kk1%, kk2%, r#, ich%, l As Long
Dim sb1() As Byte, ss1() As Byte, sa() As Byte, sb() As Byte, sc() As Byte, sd() As Byte
Dim i%, j%, n%, n1%, ik%, size%, s$, s1$
Dim c, crc%
Dim jj As Byte
Dim size1%, size2%, size3%
Dim ndata11 As Long
Dim yyData() As Single
List1.Clear: List1.Visible = False
Label1.Caption = "": Label2.Caption = "": Label3.Caption = "":
Label4.Caption = "实时监视"
ndata0 = 0
nData = 0
Ts = 0.02
w.Init 3, nData, yData, Ts
w.SetColorFont RGB(64, 64, 64), RGB(192, 192, 192), RGB(192, 192, 192)
w.SetColorLine RGB(192, 192, 192), vbRed, vbMagenta
w.SetColorWaveCh 0, vbGreen
w.SetColorWaveCh 1, RGB(255, 255, 0)
w.SetColorWaveCh 2, RGB(127, 127, 255)
w.SetChannel 0, "Ch1:垂直" & "", vbGreen, sUnit
w.SetChannel 1, "Ch2:北南" & s$, vbGreen, sUnit
w.SetChannel 2, "Ch3:东西" & s$, vbGreen, sUnit
w.RunStep Picture1, yData, ndata0, nData
w.SetScaleY 1, 32#, Picture1, yData
With MSComm1
.InBufferCount = 0
.OutBufferCount = 0
.InputMode = comInputModeBinary
End With
sMenu = "SVw"
s$ = "VW" & vbCr: Label2.Caption = s$: Label2.Refresh:
SioTxString MSComm1, s$
Sleep 1000
flgTest1 = 0
If flgTest1 = 1 Then
GoTo t1
End If
nData = 0
For i% = 0 To 15
Label2.Caption = " NAK = " & NAK
SioTxString MSComm1, Chr(NAK)
Sleep 1000
size% = SioRxData(MSComm1, sb, 1, 1000)
If size% > 0 Then
Exit For
End If
Label3.Caption = i%
Next i%
If i% >= 15 Then
Label4.Caption = "无响应，检查有无文件！！!": Label4.Refresh
GoTo lb1
End If
t1:
j% = 1
Do
' For i% = 0 To 2 '三次
If flgTest1 = 1 Then
ReDim ss1(200)
For kk1% = 0 To 60
ss1(kk1% + kk1%) = Cos(kk1% / 10 * 3.1415926) * 10 + 20
ss1(kk1% + kk1% + 1) = 128
Next kk1%
GoTo t2
End If
c = sb(0)
Select Case c
Case SOH: n1% = 6: s$ = "小包"
Case EOT:
ShowNotes "收到文件结束标志，发ACK"
ShowSendMsg "ACK = " & ACK
SioTxString MSComm1, Chr(ACK)
Exit Do
Case Else:
ShowNotes "非要求命令，请确认监控状态!!!"
GoTo lb1
End Select
' size1% = SioRxData(MSComm1, sa, 2, 1000)
' If size1% < 0 Then
' ShowNotes "读取包号超时，退出 ！"
' GoTo lb1
' End If
size2% = SioRxData(MSComm1, ss1, n1%, 1000)
If size2% < 0 Then
ShowNotes "读包数据内容超时，退出"
GoTo lb1
End If
' size3% = SioRxData(MSComm1, sc, 2, 1000)
' If size3% < 0 Then
' ShowNotes "未读到数据包的CRC校验字，退出"
' GoTo lb1
' End If
' ShowRecvMsg sa(0) & ":" & sa(1) & ", " & sc(0) & ":" & sc(1): Label3.Refresh
' crc% = 0
' For ik% = 0 To n1% - 1
' crc% = UpdateCRC(crc%, ss1(ik%))
' Next ik%
' IToC2 crc%, sd(0), sd(1)
' ShowNotes "读数据包: " & j%
' jj = j% Mod 256
' If 0 = 0 Then 'sa(0) = jj And sd(0) = sc(0) And sd(1) = sc(1) Then
t2:
r# = 2500# / 32768
kk2% = 0
' ReDim Preserve yData(3, nData + 20)
' ReDim Preserve IRIG(nData + 20)
ReDim Preserve yData(3, nData + 1)
ReDim Preserve yyData(3, nData + 1)
ReDim Preserve IRIG(nData + 1)
ndata11 = nData Mod 800
' For kk1% = 0 To 19 '获取数据
For ich% = 0 To 2
l = ss1(kk2%) + 256& * ss1(kk2% + 1)
yData(ich%, nData) = (l - 32768) * r# 'HfscdHead(ich%)
yyData(ich%, ndata11) = yData(ich%, nData)
kk2% = kk2% + 2
Next ich%
IRIG(0) = 1
nData = nData + 1
' Next kk1%
'If flgTest1 = 1 Then
' GoTo t5
'End If
Label2.Caption = " ACK= " & Chr(ACK)
SioTxString MSComm1, Chr(ACK)
If SioRxData(MSComm1, sb, 1, 4000) < 0 Then
ShowNotes "未收到下一个命令符 ！！！"
GoTo lb1
End If
't5:
' Exit For
' Else
' ShowNotes "CRC校验出错，请求重发": Label2.Caption = " NAK= " & Chr(NAK)
' SioTxString MSComm1, Chr(NAK)
' If SioRxData(MSComm1, sb, 1, 4000) < 0 Then
' ShowNotes "未收到下一个命令符 ！！！"
' GoTo lb1
' End If
' End If
' Next i%
' If i% >= 3 Then
' ShowNotes "已试三次，退出"
' GoTo lb1
' End If
' w.RunStep Picture1, yData, ndata0, nData
ndata0 = ndata0 Mod 800
If (nData Mod 20) = 0 Then
w.RunStep Picture1, yyData, ndata0, ndata11
w.Run Picture1, yyData
End If
ndata0 = nData
j% = j% + 1
DoEvents
Loop
' Loop Until nData >= 1500
ShowNotes "实时监视结束"
sMenu = "Wave"
w.RunStep Picture1, yData, ndata0, nData
w.Run Picture1, yData
GoTo lb2
lb1:
ShowNotes "退出实时监视"
lb2:
' sMenu = "Wave"
' w.Run Picture1, yData
MSComm1.InputMode = comInputModeText
End Sub
'***程序结束*********************************************************************************