formmain.frm

Fix通用外接报表程序,读取fix中的实时数据 生成相关报表曲线

VERSION 5.00
Begin VB.Form FormMain 
   Caption         =   "数据采集窗体"
   ClientHeight    =   1170
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   2775
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   ScaleHeight     =   1170
   ScaleWidth      =   2775
   StartUpPosition =   3  '窗口缺省
   Begin VB.Timer TimerSaveDate 
      Enabled         =   0   'False
      Interval        =   100
      Left            =   1560
      Top             =   240
   End
   Begin VB.Timer TimerChkDDE 
      Enabled         =   0   'False
      Interval        =   1000
      Left            =   1080
      Top             =   240
   End
   Begin GetDataFromFix.DbText DbText 
      Height          =   495
      Index           =   0
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Width           =   855
      _ExtentX        =   1508
      _ExtentY        =   873
      Text1           =   "说明"
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      FontSize        =   9
      FontSize        =   9
      TextTitle       =   "0号点"
   End
   Begin VB.Menu file 
      Caption         =   "popup"
      Visible         =   0   'False
      Begin VB.Menu mnuOpen 
         Caption         =   "开始监视"
         Enabled         =   0   'False
      End
      Begin VB.Menu mnuClose 
         Caption         =   "停止监视"
         Enabled         =   0   'False
      End
      Begin VB.Menu line1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuExit 
         Caption         =   "退出程序"
      End
   End
End
Attribute VB_Name = "FormMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim iCol As Integer, iRow As Integer
Dim iFormX As Single, iFormY As Single
Dim isInitSize As Boolean '是否第一次启动

Dim iTimerSecond As Integer



Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    Dim ShiftDown, AltDown, CtrlDown
    ShiftDown = (Shift And vbShiftMask) > 0
    AltDown = (Shift And vbAltMask) > 0
    CtrlDown = (Shift And vbCtrlMask) > 0
    
    If CtrlDown Then
        If KeyCode = vbKeyS Then
            FormSetupDb.Show
        End If
        
        If KeyCode = vbKeyT Then
            Call testDDE
        End If
    End If
End Sub

Private Sub Form_Load()
    If App.PrevInstance = True Then End
    
    Dim sCommand As String
    
    sCommand = Command
    If sCommand = "hide" Then Me.Hide
    iCol = 5
    iRow = 7
    
    ReDim isWrong(iCol * iRow - 1)            '重定义错误序列
    ReDim sDotInfo(iCol * iRow - 1, 1 To 2)   '重定义点信息序列
    ReDim isUseDot(iCol * iRow - 1)           '重定义点使用状态序列
    
    DbText(0).Move 120, 120, 1815, 615
    Me.Move Screen.Width / 2 - 7590 / 2, Screen.Height / 2 - 4320 / 2, 300 + iCol * DbText(0).Width, 350 + 240 + iRow * DbText(0).Height
    
    For x = 1 To iCol * iRow - 1
        Load DbText(x)
        DbText(x).TextTitle = CStr(x) & "号点"
        DbText(x).Visible = True
        DbText(x).Locked = True
    Next
    DbText(0).Locked = True
    
    For x = 0 To iRow - 1
        For y = 0 To iCol - 1
            DbText(x * iCol + y).Move 120 + y * DbText(0).Width, 120 + x * DbText(0).Height
        Next
    Next
    
    If Dir(App.path & "\setup.ini") <> "" Then
        Call LoadSetup
    Else
        Call InitIni
        Call LoadSetup
    End If
    
    Call uDb.initObject '初始化数据连接
    uDb.openConn
    If uDb.MyState <> 1 Then
        MsgBox "无法连接数据库，请设置！"
        isDataBaseErr = True
        FormSetupDb.Show 1
    End If
    
    Call SaveNodeToDb
    Call InitDDE
    
    Call ResizeInit(Me)
    isInitSize = True
    TimerSaveDate = True
    TimerChkDDE = True
    
End Sub

Private Sub Form_Resize()
    If isInitSize Then
        Call ResizeForm(Me)
    End If
End Sub
Sub testDDE()
    DbText(20).LinkTopic = "Excel|Sheet1"
    DbText(20).LinkItem = "R1C1"
    DbText(20).LinkMode = 1
    
    DbText(21).LinkTopic = "Excel|Sheet1"
    DbText(21).LinkItem = "R1C2"
    DbText(21).LinkMode = 1
    
    DbText(22).LinkTopic = "Excel|Sheet1"
    DbText(22).LinkItem = "R2C1"
    DbText(22).LinkMode = 1
    
    DbText(23).LinkTopic = "Excel|Sheet1"
    DbText(23).LinkItem = "R2C2"
    DbText(23).LinkMode = 1
End Sub

Private Sub DbText_DblClick(Index As Integer)
    iCurrentDot = Index
    FormSetup.Show 1, Me
End Sub

Private Sub DbText_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 2 Then
        iCurrentDot = Index
        DbText(Index).Enabled = False
        PopupMenu file
        DbText(Index).Enabled = True
    End If
End Sub


Sub InitDDE()
    Dim x As Integer
    
    For x = 0 To iCol * iRow - 1
        If sDotInfo(x, 2) <> "" Then DbText(x).Text1 = sDotInfo(x, 2)
        If isUseDot(x) Then
            Call ConnDDE(x)
        End If
    Next
End Sub

Sub ConnDDE(Index As Integer, Optional sCommand As String = "OPEN")
    On Error GoTo Errr
    
    If IsExeRuning("dmdde.exe") = False Then
        isWrong(Index) = True
        'Shell "c:\fix32\dmdde.exe", vbMinimizedNoFocus
        Exit Sub
    End If
    
    If sCommand = "OPEN" Then
        DbText(Index).LinkTopic = "DMDDE|DATA"
        DbText(Index).LinkItem = sDotInfo(Index, 1)
        DbText(Index).LinkMode = 1
        
        isWrong(Index) = False
    Else
        DbText(Index).LinkMode = 0
    End If
    
    If DbText(Index).Text2 = "error" Then err.Raise 282
    Exit Sub
Errr:
    isWrong(Index) = True
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Call SaveSetup
    Cancel = True
'    Call SaveSetup
'
'    uDb.closeConn
'    uDb.UnObject
End Sub

Private Sub mnuClose_Click()
    If Trim(sDotInfo(iCurrentDot, 1)) <> "" Then
        Call ConnDDE(iCurrentDot, "CLOSE")
        isUseDot(iCurrentDot) = False
    End If
End Sub

Private Sub mnuExit_Click()
    If MsgBox("确认退出程序吗？退出后数据将不在报表数据监控范围之内！", vbYesNo) = vbYes Then
        Call SaveSetup
    
        uDb.closeConn
        uDb.UnObject
        End
    End If
End Sub

Private Sub mnuOpen_Click()
    If Trim(sDotInfo(iCurrentDot, 1)) <> "" Then
        Call ConnDDE(iCurrentDot)
        isUseDot(iCurrentDot) = True
    End If
End Sub
Sub InitIni()
    Open App.path & "\setup.ini" For Output As #1
        Print #1, "[系统设置]"
        Print #1, "保存数据时间间隔=10"
        Print #1, "是否使用服务器时间=True"
        Print #1, "默认节点=Fix"
        Print #1, "默认域=F_CV"
        Print #1, "启用点=0"
        Print #1, "Fix目录"
        Print #1, "[数据库]"
        Print #1, "服务器地址="
        Print #1, "数据库名="
        Print #1, "用户名="
        Print #1, "密码="
        Print #1, "Access文件="
        Print #1, "是否加密Access文件=False"
        Print #1, "是否使用SqlServer=True"
        Print #1, "[数据连接设置]"
        Print #1, "0="
        For x = 1 To iCol * iRow - 1
            Print #1, CStr(x) & "="
        Next
        Print #1, "[数据点说明]"
        Print #1, "0="
        For x = 1 To iCol * iRow - 1
            Print #1, CStr(x) & "="
        Next
    Close #1
End Sub

Sub LoadSetup()
    Dim sTemp As String
    
    sNode = Replace(rini("系统设置", "默认节点"), Chr(0), "")
    sLand = Replace(rini("系统设置", "默认域"), Chr(0), "")
    sTemp = Replace(rini("系统设置", "启用点"), Chr(0), "")
    iSaveInteval = Replace(rini("系统设置", "保存数据时间间隔"), Chr(0), "")
    isUseServerTime = rini("系统设置", "是否使用服务器时间")
    sFixPath = rini("系统设置", "Fix目录")
    
    For x = 0 To iCol * iRow - 1
        sDotInfo(x, 1) = rini("数据连接设置", CStr(x))
        sDotInfo(x, 2) = Replace(rini("数据点说明", CStr(x)), Chr(0), "")
        isUseDot(x) = IIf(InStr(1, sTemp, "," & CStr(x) & ",") > 0, True, False)
    Next
    
    With uDb
        .dbFile = rini("数据库", "Access文件")
        If .dbFile = "report.mdb" Then .dbFile = App.path & "\report.mdb"
        .isEncry = rini("数据库", "是否加密Access文件")
        .dbServer = rini("数据库", "服务器地址")
        .dbName = rini("数据库", "数据库名")
        .dbUser = rini("数据库", "用户名")
        .dbPass = rini("数据库", "密码")
        .isSql = rini("数据库", "是否使用SqlServer")
    End With
End Sub

Sub SaveSetup()
    Dim sTemp As String
    
    Call wini("系统设置", "默认节点", sNode)
    Call wini("系统设置", "默认域", sLand)
    Call wini("系统设置", "保存数据时间间隔", CStr(iSaveInteval))
    Call wini("系统设置", "是否使用服务器时间", CStr(isUseServerTime))
    Call wini("系统设置", "Fix目录", sFixPath)
    
    For x = 0 To iCol * iRow - 1
        Call wini("数据连接设置", CStr(x), sDotInfo(x, 1))
        Call wini("数据点说明", CStr(x), sDotInfo(x, 2))
        If isUseDot(x) = True Then
           sTemp = sTemp & "," & CStr(x) & ","
        End If
    Next
    
'    If sTemp <> "" Then
'        sTemp = Mid(sTemp, 2, Len(sTemp) - 1)
'    End If
    Call wini("系统设置", "启用点", sTemp)
    
    With uDb
        Call wini("数据库", "Access文件", .dbFile)
        Call wini("数据库", "是否加密Access文件", .isEncry)
        Call wini("数据库", "服务器地址", .dbServer)
        Call wini("数据库", "数据库名", .dbName)
        Call wini("数据库", "用户名", .dbUser)
        Call wini("数据库", "密码", .dbPass)
        Call wini("数据库", "是否使用SqlServer", .isSql)
    End With
End Sub

Sub SaveNodeToDb()
    On Error GoTo Errr
    
    Dim x As Integer
    Dim iRe As Integer
    Dim sSql As String
    
    For x = 0 To iCol * iRow - 1
        iRe = uDb.rsData("select * from DataType where nodeid=" & x)
        If iRe > 0 Then
            sSql = "update DataType set nodeinfo='" & sDotInfo(x, 1) & "',explain='" & sDotInfo(x, 2) & "',inUse='" & Abs(Int(isUseDot(x))) & "' where nodeid=" & x
        Else
            sSql = "insert into DataType (nodeid,nodeinfo,explain,inUse) values(" & x & ",'" & sDotInfo(x, 1) & "','" & sDotInfo(x, 2) & "','" & Abs(Int(isUseDot(x))) & "')"
        End If
        iRe = uDb.rsData(sSql)
    Next
    Exit Sub
Errr:
    MsgBox "数据库不正确~！"
End Sub


'Private Sub DbText_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, Y As Single)
'    If Button = 1 Then
'        iFormX = x
'        iFormY = Y
'    End If
'End Sub
'
'Private Sub DbText_MouseMove(Index As Integer, Button As Integer, Shift As Integer, x As Single, Y As Single)
'    If Button = 1 Then
'        DbText(Index).Left = DbText(Index).Left - (iFormX - x)
'        DbText(Index).Top = DbText(Index).Top - (iFormY - Y)
'    End If
'End Sub
Private Sub TimerChkDDE_Timer()
    On Error Resume Next
    
    Dim x As Integer
    
    If IsExeRuning("dmdde.exe") = False Then
        'Shell "c:\fix32\dmdde.exe", vbMinimizedNoFocus
        Exit Sub
    End If
    
    For x = 0 To iCol * iRow - 1
        If isUseDot(x) = True And isWrong(x) = True Then
            Call ConnDDE(x)
        End If
    Next
    
End Sub

Private Sub TimerSaveDate_Timer()
    On Error Resume Next
    
    Dim x As Integer
    Dim sReDb As String
    Dim sTemp As String
    
    iTimerSecond = iTimerSecond + 1
    If iTimerSecond < iSaveInteval Then
        Exit Sub
    Else
        iTimerSecond = 0
    End If
    
    For x = 0 To iCol * iRow - 1
        If isUseDot(x) = True And isWrong(x) = False Then
            sTemp = Trim(Replace(Replace(DbText(x).Text2, Chr(0), ""), Chr(13), ""))
            sReDb = uDb.exeData("insert into fixdata (nodeid,[value]) values(" & x & "," & sTemp & ")")
            If sReDb = "ok" Then
                
            Else
                'MsgBox "error"
            End If
        ElseIf isUseDot(x) = True And isWrong(x) = True Then
            sReDb = uDb.exeData("insert into fixdata (nodeid,[value]) values(" & x & ",0)")
        End If
    Next
End Sub