frmmain.frm

为程口编程源码

   Call initcom
    
'    初始化并口
'
'    If InitializeWinIo = False Then
'                MsgBox "Whoops ! There is a problem with InitializeWinIo.", vbOKOnly + vbCritical, frmMain.Caption
'                mAction = False
'    End If
'
   Call getLpt   '从数据库中得到可以使用的并口编号，并赋予数组lptPort
End Sub
Private Sub getLpt()
Dim r As ADODB.Recordset
Dim s As String

Set r = New ADODB.Recordset
    
    s = "select distinct number from bufangset where porperty='并口' and promote=true"
    r.Open s, cn, adOpenStatic, adLockOptimistic
  '若在布防设置表中select出的并口项数量为零则判断系统不使用并口，反之使用。
    If r.RecordCount = 0 Then
                   lptInbf = False
    Else
                    lptInbf = True
    '若有并口则开一个并口端口数组
    '并给数组赋值
    ReDim lptPort(1 To r.RecordCount)
    
Dim i As Integer
        i = 0
       While Not r.EOF
              i = i + 1
              lptPort(i) = r!Number
              r.MoveNext
        Wend
     End If
End Sub

'初始化COM口
Private Sub initcom()
'初始化处警拨号使用的com口(控件：mscomm1)
Dim r As ADODB.Recordset
Dim str As String
        Set r = New ADODB.Recordset
        str = "select distinct number from chujingset where porperty='串口'"
        r.Open str, cn, adOpenStatic, adLockOptimistic
Dim commPort As Integer
        commPort = r!Number              '处警表里面使用的com口端口号
        r.Close
Dim commSettings As String
Dim commHandShaking As String

On Error Resume Next
                    
       commSettings = GetSetting("通讯端口设置", "Com" & CStr(commPort) & "性质", "Settings", "")
       commHandShaking = GetSetting("通讯端口设置", "Com" & CStr(commPort) & "性质", "Handshaking", "")
       
    Do While commSettings = "" Or commHandShaking = ""
        frmCommProperties.Label2.Caption = commPort
        Load frmCommProperties
        Set frmCommProperties.frmComm = Me
        Call frmCommProperties.LoadPropertySettings
        
        frmCommProperties.Show vbModal
        commSettings = GetSetting("通讯端口设置", "Com" & CStr(commPort) & "性质", "Settings", "")
        commHandShaking = GetSetting("通讯端口设置", "Com" & CStr(commPort) & "性质", "Handshaking", "")
    Loop
    
        MSComm1.commPort = commPort
        MSComm1.Settings = commSettings
        MSComm1.handshaking = commHandShaking
        MSComm1.PortOpen = True
        
    Set r = New ADODB.Recordset
    str = "select distinct number from bufangset where porperty='串口'"
    r.Open str, cn, adOpenStatic, adLockOptimistic
'如果布防设置中使用到com口的话,则初始化该com口
'控件:mscomm2
    If r.RecordCount = 1 Then
            comInbf = True
            commPort = r!Number
            
            commSettings = GetSetting("通讯端口设置", "Com" & CStr(commPort) & "性质", "Settings", "")
            commHandShaking = GetSetting("通讯端口设置", "Com" & CStr(commPort) & "性质", "Handshaking", "")
       
       Do While commSettings = "" Or commHandShaking = ""
             frmCommProperties.Label2.Caption = commPort
             Load frmCommProperties
             Set frmCommProperties.frmComm = Me
             Call frmCommProperties.LoadPropertySettings
        
             frmCommProperties.Show vbModal
             commSettings = GetSetting("通讯端口设置", "Com" & CStr(commPort) & "性质", "Settings", "")
             commHandShaking = GetSetting("通讯端口设置", "Com" & CStr(commPort) & "性质", "Handshaking", "")
       Loop
    
          MSComm2.commPort = commPort
          MSComm2.Settings = commSettings
          MSComm2.handshaking = commHandShaking
          MSComm2.PortOpen = True
          MSComm2.InputMode = comInputModeBinary
    Else
          comInbf = False
    End If
    
        
End Sub

Private Sub MSComm2_OnComm()
    Select Case MSComm2.CommEvent
       
           Case comEvReceive
                    Dim buffer As Variant
                    buffer = MSComm2.Input
                    Call processLook(CByte(buffer), True)
                    MSComm2.InBufferCount = 0
            Case Else
           
    End Select
End Sub

Private Sub Timer1_Timer()
   If mAction = True Then
       Call spyOn              '对布防设置进行监控
       Call updateLog          '更新日志
   End If
End Sub
Private Sub updateLog()
'触发器源+事件+处警动作
'子程序：日志更新
   '打开log记录集
         Dim str As String
        str = "select * from Log where date >= #" & sysdate & "#;"
         Dim r As ADODB.Recordset
      Set r = New ADODB.Recordset
         r.Open str, cn, adOpenStatic, adLockOptimistic
              
      If r.RecordCount <> cntLog Then
          '如果日志数目有变化则更新lvwlog
            cntLog = r.RecordCount
            lvwLog.ListItems.Clear
            Call showLog(r)
      End If
      
   r.Close
   
End Sub
 '当日纪录显示日志表
Private Sub showLog(rs As ADODB.Recordset)
  If rs.EOF Or rs.BOF Then Exit Sub
  
     rs.MoveFirst
     
  While Not rs.EOF And Not rs.BOF
     Dim str1, str2, str3 As String
         str1 = rs!bfname
         str2 = rs!Date & Space(1) & rs!Time
         str3 = rs!cjname
     
'     If IsNull(str1) Then
'           MsgBox ("此纪录无主键")
'           Exit Sub
'     End If
     
     Set mLogItem = lvwLog.ListItems.Add(Text:=str1)
         mLogItem.ListSubItems.Add Text:=str2
         mLogItem.ListSubItems.Add Text:=str3
         rs.MoveNext
  Wend
 End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
    Select Case Button.index
      Case 1
          Call mnuOperateAct_Click  '与启动安防检测子菜单相对应
          If mAction Then
             Call spyOn         '执行监控任务
             Call updateLog     '更新日志
          Else
             'undo
          End If
      Case 3
         Call mnuOperateSetting_Click
      Case 5
         Call mnuOperateMaglog_Click
      Case 7
         Call mnuExit_Click
    End Select
End Sub
'监控子程序:从各监控端口取数据
'判断触发事件是否发生，并给以
'处警
Private Sub spyOn()

On Error Resume Next
    
'如果布防设置里面使用了并口，则检测该端口输入
    If lptInbf Then

      Dim i As Integer
    
        For i = 1 To UBound(lptPort)
              
              Dim Result As Boolean
              Dim PhysVal As Long
               
               Result = GetPortVal(Val("&H" + lptPort(i)), PhysVal, 1)
               Result = True
              
              If (Result = False) Then
                     MsgBox "Whoops ! There is a proble m with GetPhysLong.", vbOKOnly + vbCritical, "VBDumpPhys32"
              Else
                     Call processLook(CByte(PhysVal), False)
                     'debug
'                    Dim num As String
'                    num = InputBox$("请输入事件编码:", "编码", 0)
'                    Call processLook(CByte(num), False)
              End If
              
         Next i
    
     End If
    
End Sub
'提取端口内容,判断触发事件的发生,
'找出对应设置
'响应,并记录入日志
Private Sub processLook(br As Byte, c As Boolean)
Dim s1 As String
          
          Select Case c
             
             Case True
                  s1 = "select * from bufangset where porperty='串口'"
             Case False
                  s1 = "select * from bufangset where porperty='并口'"
          End Select
          
Dim r, r1 As ADODB.Recordset
    
    Set r = New ADODB.Recordset
                   
               r.Open s1, cn, adOpenStatic, adLockOptimistic
               r.MoveFirst
             
             While Not r.EOF
                 '若有事件发生,则响应该触发事件
                 If (br And r!bfcode = br) Then
                     
                     '找出对应处警设置
                     Set r1 = New ADODB.Recordset
                     s1 = "select cjname from  bftocj where bfname = '" & r!bfname & "';"
                     r1.Open s1, cn, adOpenStatic, adLockOptimistic
                     
                     Dim x, y As Integer
                     x = analystRs(r1!cjname)
                     
                     '记入日志
                     Dim r2 As ADODB.Recordset
                     Set r2 = New ADODB.Recordset
                     Dim s2 As String
                     s2 = "select * from log"
                     r2.Open s2, cn, adOpenDynamic, adLockOptimistic
                   r2.AddNew
                      r2!bfname = r!bfname
                      r2!Date = FormatDateTime(Now, vbLongDate)
                      r2!Time = FormatDateTime(Now, vbLongTime)
                      r2!cjname = r1!cjname
                   r2.Update
                     r2.Close
                     
                     r1.Close
                                         
                     
                     '予以处警响应
                     For y = 0 To x - 1
                     
                         Set r1 = New ADODB.Recordset
                         s1 = "select * from chujingset where cjname = '" & strcj(y) & "';"
                         r1.Open s1, cn, adOpenStatic, adLockOptimistic
                        
                        While Not r1.EOF
                           
                           Select Case r1!porperty
                              
                                Case "串口"
                                     If MSComm1.PortOpen = True Then
                                           MSComm1.Output = "ATDT" & r1!telnumber & vbCrLf
                                     End If
'                                       MsgBox ("拨号:" & r1!telnumber)
                                Case "并口"
                                       Dim Result As Boolean
                                       
                                       If r1!typeact = "拨号" Then
                                            Result = SetPortVal(Val("&H" + r1!Number), Val("&H" + r1!telnumber), 1)
'                                            MsgBox ("拨号:" & r1!telnumber)
                                       Else
                                            Result = SetPortVal(Val("&H" + r1!Number), Val("&H" + r1!infocode), 1)
'                                            MsgBox ("发码:" & r1!infocode)
                                       End If
                                       
                                       If Result = False Then
                                              MsgBox "Whoops ! There is a problem with SetPhysLong.", vbOKOnly + vbCritical, "VBDumpPhys32"
                                       End If
                            End Select
                                          
                            r1.MoveNext
                        
                        Wend
                            r1.Close
                            
                     Next y
                                           
                 End If
                 
                  r.MoveNext
                  
             Wend
            r.Close
            
   Dim m As Integer
   For m = 0 To 99
     strcj(m) = ""
   Next m
End Sub
'cjname分析
Private Function analystRs(s As String) As Integer
   Dim i As Integer
   Dim count As Integer '纪录获取的字符串个数
   count = 0
   For i = 1 To Len(s)
      If Mid(s, i, 1) = "@" Then
                count = count + 1
      Else
                strcj(count) = strcj(count) & Mid(s, i, 1)
      End If
   Next i
   analystRs = count
End Function