frmsysgl.frm

来自「VB与欧姆龙PLC通过RS-232串口通讯 的上位机程序」· FRM 代码 · 共 618 行 · 第 1/2 页

Dim retn As String, pth As String, pthdef As String
Private Sub cbtype_Change()
If Trim(cbtype.Text) <> "干料报表" And Trim(cbtype.Text) <> "沥青报表" And Trim(cbtype.Text) <> "请选择报表类型" Then
MsgBox "请选择正确的报表类型！", vbOKOnly + vbCritical, "错误提示"
cbtype.Clear
cbtype.AddItem "请选择报表类型"
cbtype.AddItem "干料报表"
cbtype.AddItem "沥青报表"
cbtype.Text = "请选择报表类型"
cmbc.Clear: cmbd.Clear
Exit Sub
Else
Exit Sub
End If
End Sub

Private Sub cbtype_Click()
cmbc.Clear: cmbd.Clear
If Trim(cbtype.Text) = "干料报表" Then
Set delrst = dbrpt.OpenRecordset("select distinct 日期 from Glreport order by 日期 asc", dbOpenDynaset)
If delrst.RecordCount > 0 Then
cmbc.AddItem delrst.Fields(0)
cmbc.Text = Trim(delrst.Fields(0))
delrst.MoveNext
While Not delrst.EOF
cmbc.AddItem delrst.Fields(0)
delrst.MoveNext
Wend
End If
delrst.Close
Set delrst = dbrpt.OpenRecordset("select distinct 日期 from Glreport order by 日期 asc", dbOpenDynaset)
If delrst.RecordCount > 0 Then
cmbd.AddItem delrst.Fields(0)
cmbd.Text = Trim(delrst.Fields(0))
delrst.MoveNext
While Not delrst.EOF
cmbd.AddItem delrst.Fields(0)
delrst.MoveNext
Wend
End If
delrst.Close
ElseIf Trim(cbtype.Text) = "沥青报表" Then
Set delrst = dbrpt.OpenRecordset("select distinct 日期 from Lqreport order by 日期 asc", dbOpenDynaset)
If delrst.RecordCount > 0 Then
cmbc.AddItem delrst.Fields(0)
cmbc.Text = Trim(delrst.Fields(0))
delrst.MoveNext
While Not delrst.EOF
cmbc.AddItem delrst.Fields(0)
delrst.MoveNext
Wend
End If
delrst.Close
Set delrst = dbrpt.OpenRecordset("select distinct 日期 from Lqreport order by 日期 asc", dbOpenDynaset)
If delrst.RecordCount > 0 Then
cmbd.AddItem delrst.Fields(0)
cmbd.Text = Trim(delrst.Fields(0))
delrst.MoveNext
While Not delrst.EOF
cmbd.AddItem delrst.Fields(0)
delrst.MoveNext
Wend
End If
delrst.Close
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
End If
End Sub
Private Sub cmddel_Click()
ret = MsgBox("确认要删除数据吗？", vbQuestion + vbOKCancel + 256, "信息提示")
If Trim(cbtype.Text) = "干料报表" Then
If ret = vbOK Then
Screen.MousePointer = vbHourglass
dbrpt.Execute "delete from Glreport where 日期 between '" + Trim(cmbc.Text) + "' and '" + Trim(cmbd.Text) + "'"
cmbc.Clear: cmbd.Clear
Set delrst = dbrpt.OpenRecordset("select distinct 日期 from Glreport order by 日期 asc", dbOpenDynaset)
If delrst.RecordCount > 0 Then
cmbc.AddItem delrst.Fields(0)
delrst.MoveNext
While Not delrst.EOF
cmbc.AddItem delrst.Fields(0)
delrst.MoveNext
Wend
End If
delrst.Close
Set delrst = dbrpt.OpenRecordset("select distinct 日期 from Glreport order by 日期 asc", dbOpenDynaset)
If delrst.RecordCount > 0 Then
cmbd.AddItem delrst.Fields(0)
delrst.MoveNext
While Not delrst.EOF
cmbd.AddItem delrst.Fields(0)
delrst.MoveNext
Wend
End If
delrst.Close
dbrpt.Close
DBEngine.CompactDatabase App.Path & "\report\report.mdb", App.Path & "\report\reportnew.mdb"
FileCopy App.Path & "\report\reportnew.mdb", App.Path & "\report\report.mdb"
Kill App.Path & "\report\reportnew.mdb"
Set dbrpt = ws.OpenDatabase(App.Path & "\Report\report.mdb")
Set glrpt = dbrpt.OpenRecordset("Glreport", dbOpenDynaset)
Set lqrpt = dbrpt.OpenRecordset("Lqreport", dbOpenDynaset)
Set txrst = dbrpt.OpenRecordset("txb", dbOpenDynaset)
Screen.MousePointer = vbDefault
MsgBox "干料数据删除完成！", vbExclamation + vbOKOnly, "信息提示"
Else
Exit Sub
End If
ElseIf Trim(cbtype.Text) = "沥青报表" Then
If ret = vbOK Then
Screen.MousePointer = vbHourglass
dbrpt.Execute "delete from Lqreport where 日期 between '" + Trim(cmbc.Text) + "' and '" + Trim(cmbd.Text) + "'"
cmbc.Clear: cmbd.Clear
Set delrst = dbrpt.OpenRecordset("select distinct 日期 from Lqreport order by 日期 asc", dbOpenDynaset)
If delrst.RecordCount > 0 Then
cmbc.AddItem delrst.Fields(0)
delrst.MoveNext
While Not delrst.EOF
cmbc.AddItem delrst.Fields(0)
delrst.MoveNext
Wend
End If
delrst.Close
Set delrst = dbrpt.OpenRecordset("select distinct 日期 from Lqreport order by 日期 asc", dbOpenDynaset)
If delrst.RecordCount > 0 Then
cmbd.AddItem delrst.Fields(0)
delrst.MoveNext
While Not delrst.EOF
cmbd.AddItem delrst.Fields(0)
delrst.MoveNext
Wend
End If
delrst.Close
dbrpt.Close
DBEngine.CompactDatabase App.Path & "\report\report.mdb", App.Path & "\report\reportnew.mdb"
FileCopy App.Path & "\report\reportnew.mdb", App.Path & "\report\report.mdb"
Kill App.Path & "\report\reportnew.mdb"
Set dbrpt = ws.OpenDatabase(App.Path & "\Report\report.mdb")
Set glrpt = dbrpt.OpenRecordset("Glreport", dbOpenDynaset)
Set lqrpt = dbrpt.OpenRecordset("Lqreport", dbOpenDynaset)
Set txrst = dbrpt.OpenRecordset("txb", dbOpenDynaset)
Screen.MousePointer = vbDefault
MsgBox "沥青数据删除完成！", vbExclamation + vbOKOnly, "信息提示"
Else
Exit Sub
End If
Else
MsgBox "请选择正确的删除期间范围！", vbExclamation + vbOKOnly, "信息提示"
Exit Sub
End If
End Sub
Private Sub cmdexit_Click()
If comm.PortOpen = True Then comm.PortOpen = False
stopflat = False: sendflat = False: time_on = False: Timersend.Enabled = False
Screen.MousePointer = vbDefault
Unload Me
End Sub
Private Sub cmdgb_Click()
If comm.PortOpen = True Then comm.PortOpen = False
stopflat = False: sendflat = False: time_on = False: Timersend.Enabled = False
Screen.MousePointer = vbDefault
Unload Me
End Sub

Private Sub cmdport_Change()
If cmdport.Text <> "1" And cmdport.Text <> "2" And cmdport.Text <> "3" And cmdport.Text <> "4" And cmdport.Text <> "5" And cmdport.Text <> "6" Then
MsgBox "请输入1-6之间的数字！", vbOKOnly + vbCritical, "错误提示"
cmdport.Clear
cmdport.AddItem "1"
cmdport.AddItem "2"
cmdport.AddItem "3"
cmdport.AddItem "4"
cmdport.AddItem "5"
cmdport.AddItem "6"
End If
End Sub
Private Sub cmdreset_Click()
ret = MsgBox("真的要复位PLC吗?", vbQuestion + vbOKCancel + 256, "信息提示")
If ret = vbOK Then
Screen.MousePointer = vbHourglass
If comm.PortOpen = True Then
comm.PortOpen = False
End If
Timersend.Enabled = True
comm.CommPort = dkh
comm.Settings = btl
comm.PortOpen = True
reset = comm.Input
reset = "@00SC02"
reset = reset + fscset(reset) + "*" + Chr(13)
reset = sedrcv(reset, 10)
pl = "@00WD00510100"
pl = pl + fscset(pl) + "*" + Chr(13)
pl = sedrcv(pl, 10)
pl = "@00WD00520800"
pl = pl + fscset(pl) + "*" + Chr(13)
pl = sedrcv(pl, 10)
pl = "@00WD0100FFFF"
pl = pl + fscset(pl) + "*" + Chr(13)
pl = sedrcv(pl, 10)
pl = "@00WD0800FFFF"
pl = pl + fscset(pl) + "*" + Chr(13)
pl = sedrcv(pl, 10)
DoEvents
Screen.MousePointer = vbDefault
If comm.PortOpen = True Then comm.PortOpen = False
stopflat = False: sendflat = False: time_on = False: Timersend.Enabled = False
MsgBox "PLC复位完成!", vbExclamation + vbOKOnly, "信息提示"
Exit Sub
Else
Screen.MousePointer = vbDefault
If comm.PortOpen = True Then comm.PortOpen = False
stopflat = False: sendflat = False: time_on = False: Timersend.Enabled = False
Exit Sub
End If
End Sub
Private Sub cmdtx_Click()
If cmdtx.Caption = "通讯设置(&T)" Then
cmdtx.Caption = "保存更改(&S)"
cmdport.Enabled = True
txttx.Text = btl
chktx.Value = 0
chktx.Enabled = True
cmdport.SetFocus
Exit Sub
End If
If cmdtx.Caption = "保存更改(&S)" And chktx.Value = 1 Then
dbrpt.Execute "update txb set port = '" + Trim(cmdport.Text) + "',baud = '" + Trim(txttx.Text) + "',dft = 'Y'"
Set txrst = dbrpt.OpenRecordset("txb", dbOpenDynaset)
dkh = txrst.Fields(0)
btl = txrst.Fields(1)
cmdport.Text = Trim(dkh)
txttx.Text = Trim(btl)
txrst.Close
cmdtx.Caption = "通讯设置(&T)"
cmdport.Enabled = False
txttx.Enabled = False
chktx.Enabled = False
MsgBox "通讯参数更改完成！", vbExclamation + vbOKOnly, "信息提示"
Exit Sub
Else
MsgBox "请设置为默认！", vbExclamation + vbOKOnly, "信息提示"
chktx.SetFocus
Exit Sub
End If
End Sub
Private Sub Form_Load()
cmdport.AddItem "1": cmdport.AddItem "2": cmdport.AddItem "3": cmdport.AddItem "4":  cmdport.AddItem "5": cmdport.AddItem "6": cmdport.Text = dkh: cmdport.Enabled = False
txttx.Text = btl
txttx.Enabled = False
chktx.Value = 1
chktx.Enabled = False
cbtype.AddItem "请选择报表类型"
cbtype.AddItem "干料报表"
cbtype.AddItem "沥青报表"
cbtype.Text = "请选择报表类型"
Screen.MousePointer = vbDefault
End Sub
Private Function sedrcv(sed As String, lensend As Integer) As String
Dim online As Boolean
Dim times As Integer
Dim dummy As Integer
Dim instring As String
Dim rig As Boolean
Dim wrongsend As Boolean
online = False
rig = True
wrongsend = True
times = 0
loop1: Do
comm.InputLen = 0
If comm.PortOpen = False Then
comm.PortOpen = True
End If
comm.Output = sed
Timersend.Interval = 200
time_on = False
Timersend.Enabled = True
loop2:  Do
dummy = DoEvents()
Loop Until (comm.InBufferCount > lensend) Or (time_on = True)
Timersend.Enabled = False
If time_on = True Then
times = times + 1
GoTo hab1
End If
online = True
instring = comm.Input
rig = fsccheck(instring)
If rig = False Then
times = times + 1
GoTo hab1
End If
wrongsend = True
If Mid(instring, 6, 2) <> "00" Then
wrongsend = False
times = times + 1
GoTo hab1
End If
hab1:   Loop While (times <= 10) And (online = False Or rig = False Or wrongsend = False)
If times > 10 Then
'End If
Else: sedrcv = instring
End If
End Function

Private Sub Timersend_Timer()
time_on = True
End Sub