cdatabaseopr.cls

与西门子PLC通讯的程序,经工业现场测试没有问题

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cDataBaseOPR"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

' @@@@@@@@    说明    @@@@@@@@
' 数据库的设置发生了改变，所有的实时数据都写在一个表单之中，便于操作。
' 一共有4个数据表单:RealTimeData,History_1M,History_20M,History_60M

' @@@@@@@@  调用方法  @@@@@@@@

' 定义通讯串口号            setComPort
' 定义通讯串口设置          setComSet
' 实例化MSCOMM控件          setMSCOMMOCX
' 实例化Timer控件           setTimerOCX
' 初始化                    Initialization
' 开始通讯                  DoCommunication
' 在需要写数据的时候设置    setWriteOrder
' 关闭时销毁所有实例，调用  Termination

'--------- 求 RealTimeData 、History_1M 、History_20M 表单中的平均值、最大值
Private Const strSQLAVGALL As String = "Select AVG(pv_wt01),AVG(pv_wt02),AVG(pv_wt03),AVG(pv_wt04),AVG(pv_st01),AVG(pv_st02),AVG(pv_st03),AVG(pv_st04),AVG(pv_st05),AVG(pv_st06)," _
            & "AVG(pv_stx01),AVG(pv_stx02),AVG(pv_stx03),AVG(pv_stx04),AVG(pv_stx05),AVG(pv_stx06),AVG(pv_prst),AVG(pv_prsub),AVG(pv_prneg),AVG(pv_prma),AVG(pv_vac),AVG(pv_tpma)," _
            & "AVG(pv_spmap),AVG(pv_spmaw),AVG(pv_cura),AVG(pv_curb),AVG(pv_curc),AVG(pv_pow),Max(pv_status),Max(pv_switch),AVG(pv_vlv),Max(pv_alarm),Max(pv_nost),Max(pv_nopr)," _
            & "Max(sv_wt02),Max(sv_wt03),Max(sv_wt04),Max(sv_st01),Max(sv_st02),Max(sv_st04),Max(sv_st06),Max(sv_prsub),Max(sv_spma),Max(sv_tmht),Max(set_frh)," _
            & "Max(set_frl),Max(set_frmax),Max(set_vlvmax),Max(set_k),Max(sum_bc),Max(sum_allp),Max(sum_allw),Max(sum_work),Max(sum_tmht),Max(pv_rvtst) From "
            

Private WithEvents priTMRHISTORY As Timer
Attribute priTMRHISTORY.VB_VarHelpID = -1

Private priLocalServerName As String        '服务器名
Private priLocalDataBaseName As String      '数据库名
Private priLocalDataBaseUser As String      '数据库用户名
Private priLocalDataBasePSW As String       '数据库密码

Private pricnnLocalCNN As ADODB.Connection

'--------------------------------------------------------------------------------------
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'-------------- 定义属性 --------------------------------------------------------------

Public Property Let setServerName(ByVal lNewValue As String)                '服务器名
    priLocalServerName = lNewValue
End Property

Public Property Let setDataBaseName(ByVal lNewValue As String)              '数据库名
    priLocalDataBaseName = lNewValue
End Property

Public Property Let setDataBaseUser(ByVal lNewValue As String)              '数据库用户名
    priLocalDataBaseUser = lNewValue
End Property

Public Property Let setDataBasePassword(ByVal lNewValue As String)          '数据库密码
    priLocalDataBasePSW = lNewValue
End Property

Public Property Let setTimerOCX(ByRef lTimer As Timer)
    Set priTMRHISTORY = lTimer
End Property

'-------------- 结束属性定义 ----------------------------------------------------------
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'--------------------------------------------------------------------------------------

Public Sub Initialization()         '进行初始化
    
    On Local Error GoTo ErrOPR
        '---------------------- 打开数据库 -------------------
        Set pricnnLocalCNN = New ADODB.Connection
        Dim strCNNSTR$
        strCNNSTR = "Provider=SQLOLEDB.1;Persist Security Info=False;" _
            & "User ID=" & priLocalDataBaseUser _
            & ";Password=" & priLocalDataBasePSW _
            & ";Initial Catalog=" & priLocalDataBaseName _
            & ";Data Source=" & priLocalServerName
        If pricnnLocalCNN.State = adStateOpen Then
            Exit Sub
        End If
        With pricnnLocalCNN
            .ConnectionString = strCNNSTR
            .ConnectionTimeout = 15
            .CursorLocation = adUseClient
            .Open
        End With
        
        
        '--------------------- 定义定时器 --------------------
        With priTMRHISTORY
            .Interval = 5000    '5 s 一次已经足够
            .Enabled = True
        End With
    Exit Sub
ErrOPR:
    
End Sub

Public Sub GetWriteRecord(ByVal lTableName As String, ByRef lDate As Date, ByRef lOrder As String)
    
    On Local Error GoTo ErrOPR
        Dim tSQL As String
        Dim tRST As ADODB.Recordset
        Set tRST = New ADODB.Recordset
        tSQL = "Select Top 1 RealTime,Mdfy_Order From " & lTableName & " Order By RealTime Desc"
        Set tRST = pricnnLocalCNN.Execute(tSQL)
        lDate = CDate(Trim(tRST(0).Value))
        lOrder = Trim(tRST(1).Value)
        Set tRST = Nothing
    Exit Sub
ErrOPR:

End Sub

Public Sub Termination()            '结束


    On Local Error GoTo ErrOPR
        priTMRHISTORY.Enabled = False
        If pricnnLocalCNN.State = adStateClosed Then
            Exit Sub
        End If
        pricnnLocalCNN.Close
        Set pricnnLocalCNN = Nothing
        
    Exit Sub
ErrOPR:
    

End Sub

Public Sub SaveRealData(ByRef lArrData() As Double)     '储存实时数据（直接调用这个过程，就存储一条记录）
    
    On Local Error GoTo ErrOPR
        Dim i%, s$, tSQL$, tTime$
        For i = 1 To 55
            s = s & CStr(lArrData(i)) & ","
        Next
        s = Left(s, Len(s) - 1)                 '去掉最后的一个逗号 ","
        tTime = CStr(Format(Now, "yyyy-mm-dd hh:mm:ss"))
        tSQL = "Insert Into RealTimeData Values('" & tTime & "'," & s & ")"
        Dim tRS As New ADODB.Recordset
        Set tRS = pricnnLocalCNN.Execute(tSQL)  ' 插入一条记录
        
        Dim nCount As Integer
        Set tRS = pricnnLocalCNN.Execute("Select * from RealTimeData")
        nCount = tRS.RecordCount
        If nCount > 300 Then
            tSQL = "Delete from RealTimeData Where RealTime In " _
                & "(Select Top " & nCount - 300 & " RealTime From RealTimeData Order By Realtime)"
            pricnnLocalCNN.Execute tSQL         '删除大于300条的记录
        End If
        Set tRS = Nothing
        
        
    Exit Sub
ErrOPR:
     
End Sub


Private Sub GetHistoryData(ByVal lFromTable As String, ByVal lToTable As String, ByVal lOPRType As String)
   
'    On Local Error GoTo ErrOPR
        
        Dim tmN As Date, tmP As Date, tmW As Date
        Dim strAverDataString As String
        Dim i%
        tmN = Now
        tmN = Format(tmN, "yyyy-mm-dd hh:mm")
        
        Select Case lOPRType
            Case "1M"
                tmP = tmN - CDate("00:01")
                tmW = tmP
            Case "20M"
                Dim tA%
                tA = Minute(tmN)
                tA = (tA \ 20) * 20
                tmN = CDate(Year(tmN) & "-" & Month(tmN) & "-" & Day(tmN) & " " & Hour(tmN) & ":" & Format(tA, "00"))
                tmP = tmN - CDate("00:20")
                tmW = tmN
            Case "60M"
                tmN = CDate(Year(tmN) & "-" & Month(tmN) & "-" & Day(tmN) & " " & Hour(tmN) & ":00:00")
                tmP = tmN - CDate("01:00")
                tmW = tmN
        End Select
        tmN = Format(tmN, "yyyy-mm-dd hh:mm:ss")
        tmP = Format(tmP, "yyyy-mm-dd hh:mm:ss")
        
        Dim strSQL As String
        Dim RS As New ADODB.Recordset
        strSQL = "Select * From " & lToTable & " Where RealTime = '" & tmW & "'"
        Set RS = pricnnLocalCNN.Execute(strSQL)
        If RS.RecordCount > 0 Then
            Set RS = Nothing
            Exit Sub
        End If
        

        '-------- 计算平均值
        strSQL = strSQLAVGALL & lFromTable & " Where RealTime Between '" & tmP & "' And '" & tmN & "'"
        Set RS = pricnnLocalCNN.Execute(strSQL)
        strAverDataString = ""
        Dim tFields
        For i = 0 To RS.Fields.Count - 1
            tFields = RS.Fields(i)
            If tFields & " " = " " Then tFields = 0
            tFields = Val(tFields)
            strAverDataString = strAverDataString & tFields & ","               '添加一个字段的值到 strAverDataString
        Next
        Set RS = Nothing
        
        '-------- 存储 History_XM 的所有值
        strAverDataString = Left(strAverDataString, Len(strAverDataString) - 1) '去掉最后一个 ","
        strSQL = "Insert Into " & lToTable & " Values('" & tmW & "'," & strAverDataString & ")"
        pricnnLocalCNN.Execute strSQL
        
    Exit Sub
ErrOPR:


End Sub

Public Sub getItemsValue(ByVal lSQLString As String, ByRef lItems() As Variant)

    Dim tRST As ADODB.Recordset
    Set tRST = New ADODB.Recordset
    Set tRST = pricnnLocalCNN.Execute(lSQLString)
    Dim i%
    For i = 0 To tRST.Fields.Count - 1
        lItems(i) = IIf(tRST(i).Value & "" = "", 0, Val(Trim(tRST(i).Value)))
    Next
    Set tRST = Nothing
    
End Sub

Public Sub SaveAlertValue(ByVal lSQLString As String)

    On Local Error GoTo ErrOPR
    
        pricnnLocalCNN.Execute lSQLString
        Dim nCount As Integer
        Dim tSQL As String
        Dim tRST As ADODB.Recordset
        Set tRST = New ADODB.Recordset
        Set tRST = pricnnLocalCNN.Execute("Select * from AlertInfo")
        nCount = tRST.RecordCount
        If nCount > 300 Then
            tSQL = "Delete from AlertInfo Where RealTime In " _
                & "(Select Top " & nCount - 300 & " RealTime From AlertInfo Order By Realtime)"
            pricnnLocalCNN.Execute tSQL
        End If
        Set tRST = Nothing
    Exit Sub
ErrOPR:
    
End Sub

Private Sub priTMRHISTORY_Timer()
    
    Call GetHistoryData("RealTimeData", "History_1M", "1M")
    Call GetHistoryData("History_1M", "History_20M", "20M")
    Call GetHistoryData("History_20M", "History_60M", "60M")
    
End Sub