frmmain1.frm

VISUAL BASIC 6 实现的自动化控制系统程序. 里面包含了好几个OCX源代码.我5年前的作品.现在看起来有点垃圾了.

         Begin VB.Menu mnuValveMonth 
            Caption         =   "阀月统计（&M）"
         End
         Begin VB.Menu mnuValveYear 
            Caption         =   "阀年统计（&Y）"
         End
      End
      Begin VB.Menu MnuInfPump 
         Caption         =   "泵灌溉信息统计（&T）"
         Begin VB.Menu mmuPumpDay 
            Caption         =   "泵日统计（&D）"
         End
         Begin VB.Menu mmuPumpMonth 
            Caption         =   "泵月统计（&M）"
         End
         Begin VB.Menu mnuPumpYear 
            Caption         =   "泵年统计（&Y）"
         End
      End
   End
   Begin VB.Menu MnuInduc 
      Caption         =   "系统介绍（&I）"
   End
   Begin VB.Menu MnuValveControl 
      Caption         =   "阀控制"
      Visible         =   0   'False
      Begin VB.Menu MnuCurrVL 
         Caption         =   "当前流量"
      End
   End
   Begin VB.Menu MnuPumpControl 
      Caption         =   "泵控制"
      Visible         =   0   'False
      Begin VB.Menu MnuOpenPump 
         Caption         =   "开泵操作"
      End
      Begin VB.Menu MnuClosePump 
         Caption         =   "关泵操作"
      End
      Begin VB.Menu MnuSeparatorPL3 
         Caption         =   "-"
      End
      Begin VB.Menu MnuContLP 
         Caption         =   "流量统计"
      End
   End
   Begin VB.Menu mnuSystem2 
      Caption         =   "系统控制（&S）"
      Visible         =   0   'False
      Begin VB.Menu mnuRecordSheach2 
         Caption         =   "记录查询（&V）"
         Begin VB.Menu MnuCurrRecordV2 
            Caption         =   "阀当前记录查询（&V）"
         End
         Begin VB.Menu MnuCurrRecordP2 
            Caption         =   "泵当前记录查询（&P）"
         End
      End
      Begin VB.Menu MnuCont2 
         Caption         =   "数据统计（&D）"
         Begin VB.Menu mnuValve2 
            Caption         =   "阀灌溉信息统计（&S）"
         End
         Begin VB.Menu MnuPump2 
            Caption         =   "泵灌溉信息统计（&T）"
         End
      End
      Begin VB.Menu MnuOptions2 
         Caption         =   "选项（&O）…"
      End
      Begin VB.Menu MnuSeparatorPL2 
         Caption         =   "-"
      End
      Begin VB.Menu mnuRefresh 
         Caption         =   "刷新（&R）"
      End
      Begin VB.Menu MnuSeparatorP2 
         Caption         =   "-"
      End
      Begin VB.Menu MnuExit2 
         Caption         =   "退出系统（&E）"
      End
   End
End
Attribute VB_Name = "FrmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

''ZheJiang RuiAn Irrigated Farming Project
'Design by SALLY CO.,LTD. —— Qianliyong 2001

Option Explicit
Private 通讯计数器 As Integer
Private ComPortID As Integer
Private CommEr As Boolean
Private 动态显示管路 As Boolean     '管路动态显示
Private strTitl As String
Dim myInfrm As Form

Private Sub Form_Activate()
Me.Refresh
End Sub

'系统初始化
Private Sub Form_Initialize()

Dim I As Integer
Dim myBoolean As Boolean
Dim MapImagePath As String

Open "d:\Runlog.log" For Append As #1
Write #1, Now & "系统启动。"
Close (1)

On Error GoTo ErrH:
AdoPump.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=D:\vb98\SL_QLY_RuiAn.mdb;Persist Security Info=False"
StrQuery = "select VID,器件名,开启时间,关闭时间,日期,用水量,费用,[备   注],已统计 from DBTabValve WHERE 已统计 = 0 "
AdoValve.ConnectionString = "FILE NAME=D:\vb98\SL_QLY_RuiAn.UDL"
AdoValve.RecordSource = StrQuery
AdoValve.Refresh

StrQuery = "select PID,器件名,开启时间,关闭时间,日期,用水量,费用,[备   注],已统计 from DBTabPump WHERE 已统计 = 0 "
AdoPump.RecordSource = StrQuery
AdoPump.Refresh

strTitl = "瑞安市场桥农田灌溉自动化控制系统信息中心*********************************************************************"
For I = 0 To 2
    MyPump(I).IndexID = I
    MyPump(I).TitlName = GetSetting("SL_RASCQ", "NAME", "TitlNamePump" & I + 1, I + 1 & "号泵")
    MyPump(I).IsChange = False
    MyPump(I).PopuMnuAble = True
Next
For I = 0 To 9
    MyValve(I).TitlName = GetSetting("SL_RASCQ", "NAME", "TitlNameValve" & I, I + 1 & "号阀")
    MyValve(I).IsChange = False
    MyValve(I).IndexID = I
    MyValve(I).InCyc = False
    MyValve(I).PopuMnuAble = True
    MyValve(I).SetAmount = 0
    MyValve(I).AddAmount = 0
    MyValve(I).ToolTipText = MyValve(I).TitlName
    TxtFluxV(I).ToolTipText = MyValve(I).TitlName & "当前流速"
Next

'总用水量和总用电量
TotalWater = GetSetting("SL_RASCQ", "SAVE", "TotalWater", 0)
TotalElect = GetSetting("SL_RASCQ", "SAVE", "TotalElect", 0)
'每吨水价格
WaterPrice = GetSetting("SL_RASCQ", "SETTING", "WaterPrice", 0.5)
'初始化界面
MainMap.Top = -150
MainMap.Left = -500
QuitEnAble = False
'道路
LineRoadH(0).Visible = GetSetting("SL_RASCQ", "SETTING", "AppearRoad ", 1)
LineRoadH(0).BorderColor = GetSetting("SL_RASCQ", "SETTING", "RoadColor ", &HFFFF&)
LineRoadH(0).BorderWidth = GetSetting("SL_RASCQ", "SETTING", "RoadWidth ", 1)

'管路
PipeLine(0).Visible = GetSetting("SL_RASCQ", "SETTING", "AppearPipe ", 1)
PipeLine(0).BorderColor = GetSetting("SL_RASCQ", "SETTING", "PipeColor ", &HFF0000)
PipeLine(0).BorderWidth = GetSetting("SL_RASCQ", "SETTING", "PipeWidth ", 1)

'河道
LineRive1.Visible = GetSetting("SL_RASCQ", "SETTING", "AppearRive ", 1)
LineRive1.BorderColor = GetSetting("SL_RASCQ", "SETTING", "RiveColor ", &HFF0000)
LineRive1.BorderWidth = GetSetting("SL_RASCQ", "SETTING", "RiveWidth ", 10)

'操作站
myBoolean = CBool(GetSetting("SL_RASCQ", "SETTING", "AppearFFO ", 1))
For I = 0 To 4
    FFOTitl(I).Visible = myBoolean
    FFOTitl(I).ToolTipText = I + 1 & "#操作站"
Next

'各阀流量显示
myBoolean = GetSetting("SL_RASCQ", "SETTING", "AppearFlux", 1)
ShowFlux myBoolean

'地图背景
IsColorSelect = GetSetting("SL_RASCQ", "SETTING", "ColorSelect", 0)
If IsColorSelect = True Then
    MainMap.BackColor = GetSetting("SL_RASCQ", "SETTING", "MapBackColor ", 1)
    Mapshow   '修改阀、泵底色
    MainMap.Picture = Nothing
Else
    '保存背景图片
    MapImagePath = GetSetting("SL_RASCQ", "SETTING", "MapBackImage", "c:\windows\Internet Explorer 墙纸.bmp")
    '地图背景图片
    MainMap.Picture = LoadPicture(MapImagePath)
End If
I = GetSetting("SL_RASCQ", "SETTING", "MovieSpeed", 200)
ShowMovieSpeed I

'道路
MapLineShow LineRoadH(0).Visible, LineRoadH(0).BorderWidth
MapLineColor LineRoadH(0).BorderColor

'管路
PipeLineShow PipeLine(0).Visible, PipeLine(0).BorderWidth
PipeLineColor PipeLine(0).BorderColor

'河道
RiveLineShow LineRive1.Visible, LineRive1.BorderWidth
RiveLineColor LineRive1.BorderColor
Exit Sub
ErrH:
MsgBox "错误" & Err.Number & "  " & Err.Description & "！"
Select Case Err.Number
Case 481
 MainMap.Picture = LoadPicture("d:\Image\28010.jpg")
End Select
End Sub
'流量仪2*2+田间操作站5*2+阀10/8（2）=16
'首字节“A”末校正字节（2）
'共向下位机接收16+2=18 字节。
Private Sub CommConnSet()
Dim Response
Dim BTryed As Boolean
    ComPortID = GetSetting("SL_RASCQ", "SETTING", "ComPortID", "1")
    ComPortID = 1 '//
    On Error GoTo ErrH:
LB:     With MSComm1
        .CommPort = ComPortID
        'PLC- 波特率 9600,无奇偶校验,每字附8位,一个停止位。
        '计算机-波特率 9600，无奇偶校验检查，8 个数据位，1 个停止位：
        .Settings = "9600,N,8,1"
        .Handshaking = comNone
        .InputMode = comInputModeBinary  '必须
        .PortOpen = True
        .RThreshold = 18        '接收18个字节的数据。产生MSOnComm事件。
        .InputLen = 0           '读入整个缓冲区
    End With
    Exit Sub
ErrH:
    If BTryed = False Then      '检查闲余通讯端口
        If Err.Number = 8005 And ComPortID = 1 Then
            ComPortID = 2
            SaveSetting "SL_RASCQ", "SETTING", "ComPortID", "2"
        ElseIf Err.Number = 8005 And ComPortID = 2 Then
            ComPortID = 1
            SaveSetting "SL_RASCQ", "SETTING", "ComPortID", "1"
        End If
        BTryed = True
        GoTo LB
    Else
        Response = MsgBox("通讯端口已经打开，请关闭所有应用程序后再重试。是否退出重试？", vbApplicationModal + vbYesNo + vbInformation)
        If Response = vbYes Then   ' 用户按下“是”。
            For Each myInfrm In Forms
               Unload myInfrm
            Next
            End
        Else                     ' 用户按下“否”。
            CommEnable = False
        End If
    End If
End Sub

Private Sub Form_Load()
    Call CommConnSet    '通讯测试
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Dim I As Integer
On Error GoTo ErrH:
Open "d:\Runlog.log" For Append As #1
Print #1, Now & "系统关闭。"
Close (1)
For I = 0 To 9
    If MyValve(I).Runing = True Then        '保存灌量
        MyValve_IsClose I, 0
    End If
Next
If MyPump(0).Runing = True Then Call MyPump_IsClose(0)  '保存灌量
If MyPump(1).Runing = True Then Call MyPump_IsClose(1)  '保存灌量

'保存总用水量和总用电量
If MSComm1.PortOpen = True Then MSComm1.PortOpen = False
SaveSetting "SL_RASCQ", "SAVE", "TotalWater", TotalWater
SaveSetting "SL_RASCQ", "SAVE", "TotalElect", TotalElect
QuitEnAble = True
For Each myInfrm In Forms
   Unload myInfrm
Next
Exit Sub
ErrH:
    MsgBox Err.Number & Err.Description
End Sub

Private Sub Form_Unload(Cancel As Integer)
End
End Sub
Private Sub MainMap_MouseDown(Button As Integer, Shift As Integer, X As Single, y As Single)
Select Case Button
Case 1
Me.Refresh
Case 2
    PopupMenu mnuSystem2
End Select
End Sub

Private Sub mmuPumpDay_Click()
SelectCountIndex = 0
    frm泵日表.Show
End Sub

Private Sub mmuPumpMonth_Click()
SelectCountIndex = 1
    frm泵日表.Show
End Sub

Private Sub MnuChangFee_Click()

Dim InputString As String
UserPassWord = GetSetting("SL_RASCQ", "SAVE", "PassWord", 888)
    InputString = InputBox("请输入管理员密码", "水价修改")
P:
    If InputString = "" Then Exit Sub
    If InputString = UserPassWord Then
        InputString = InputBox("请输入每 吨（立方米）水的价格", "水价修改", 0.5)
        If InputString <> "" Then
            WaterPrice = CSng(InputString)
            SaveSetting "SL_RASCQ", "SETTING", "WaterPrice", WaterPrice
        Else
            Exit Sub
        End If
    Else
        InputString = InputBox("密码错误！请重输管理员密码", "水价修改")
        GoTo P:
    End If
End Sub

Private Sub MnuCommDisplay_Click()      '&&&
    DigCommState.Show
End Sub


Private Sub MnuCurrRecord_Click()
frmDBTabValve.Show
End Sub

Private Sub MnuCurrRecordP_Click()
    frmDBTabPump.Show
End Sub

Private Sub MnuCurrRecordP2_Click()
    MnuCurrRecordP_Click
End Sub

Private Sub MnuCurrRecordV2_Click()
    MnuCurrRecord_Click
End Sub

Private Sub MnuExit_Click()
    End
 End Sub

Private Sub MnuExit2_Click()
 MnuExit_Click
End Sub

Private Sub MnuInduc_Click() '系统介绍
Dim RetVal
On Error GoTo ErrH
'RetVal = Shell("explorer d:\站点\new_page_1.htm", vbMaximizedFocus)
RetVal = Shell("explorer D:\Myweb\Index.htm", vbMaximizedFocus)
Exit Sub
ErrH:
End Sub

Private Sub MnuOpen_Click()
DigCyc.Show
End Sub

Private Sub MnuOptions_Click()
frmOptions.Show
End Sub

Private Sub MnuOptions2_Click()
    MnuOptions_Click
End Sub