frmmain.frm

西门子TC35源程序

    TC35SChangeStatus 7, Status
End Sub


Private Sub TC35S8_ChangeStatus(ByVal Status As EventStatus)
    TC35SChangeStatus 8, Status
End Sub

Private Sub bntOK_Click()
   Me.WindowState = 1
End Sub

Private Sub bntCancel_Click()
   Unload Me
End Sub

Private Sub bntDelete_Click()
  Dim s As String
  If Not ListView.SelectedItem Is Nothing Then
     If ShowYesNo("您真想删除你所选择中的记录！") Then
        OpenCN
        cn.Execute "delete from School_Tc35 where TC35ID=" & Mid(ListView.SelectedItem.Key, 3)
        CloseCN
        ListView.ListItems.Remove ListView.SelectedItem.Key
     End If
  End If
End Sub

Private Sub bntEdit_Click()
  Dim s As String
  If Not ListView.SelectedItem Is Nothing Then
     ShowTC35 CLng(Mid(ListView.SelectedItem.Key, 3))
  End If
End Sub

Private Sub bntNew_Click()
    ShowTC35
End Sub

Private Sub bntSend_Click()
   OkTC35Number = InitComm()
   
    SetTC35(1).Para1 = 392
    SetTC35(1).Para2 = 62
    SetTC35(1).Para3 = "WebSM"
    SetTC35(1).Telphone = "13480724365"
    SetTC35(1).Msg = "test"
    GroupSendSM SetTC35, 1, bExit
   
   If OkTC35Number > 0 Then
      'bntSend.Enabled = False
      SetSendStatus False
'      Timer.Interval = 5000 'GroupSendSM SetTC35, OkTC35Number, bExit '开始群发
      GroupSendSM SetTC35, OkTC35Number, bExit '开始群发
      setStatus "系统启动正常,等待调度...."
   End If
End Sub


'群发SM
Public Sub GroupSendSM(SetTC35() As TC35, ByVal nTC35 As Integer, bExit As Boolean)
   Dim i As Integer
   For i = 1 To nTC35
       DoEvents
       SetTC35(i).Send
       If bExit Then Exit For
   Next i
   
   If bExit Then
     For i = 1 To nTC35
            SetTC35(i).Break
     Next i
   End If
   
End Sub

Private Sub Init()
    
    Set TC35S1 = New TC35
    Set SetTC35(1) = TC35S1
    
    Set TC35S2 = New TC35
    Set SetTC35(2) = TC35S2
    
    Set TC35S3 = New TC35
    Set SetTC35(3) = TC35S3
    
    
    Set TC35S4 = New TC35
    Set SetTC35(4) = TC35S4
    
    
    Set TC35S5 = New TC35
    Set SetTC35(5) = TC35S5
    
    Set TC35S6 = New TC35
    Set SetTC35(6) = TC35S6
    
    Set TC35S7 = New TC35
    Set SetTC35(7) = TC35S7
    
    Set TC35S8 = New TC35
    Set SetTC35(8) = TC35S8
    
End Sub


Private Sub Form_Load()
   On Error GoTo laberr
   Dim s As String
   Dim n As Integer
   If Not isDebug Then
      AddToTray Me, menuTray
      SetTrayTip "校园安全管理短信发送服务程序 V1.0"
   End If
   
   Call Init
   
   bExit = True
   bInit = False
   If GetStr() = False Then '取得当前数据库连接的字符串信息
        setStatus "无法取得数据库连接信息,请运行连接设置程序，然后再执行本程序"
   Else
        n = LoadTC35()
        If n = 0 Then
            setStatus "系统当前没加入TC35短信发送终端设备信息"
        ElseIf n > 0 Then
            setStatus "系统初始化成功,请按下“发送”启动服务"
            bInit = True
        End If
   End If
   SetSendStatus bInit
   Exit Sub
laberr:
   ShowMsg "系统初始化出错，错误信息为 = " & Err.Description
   bInit = False
   SetSendStatus bInit
   bntSTOP.Enabled = False
End Sub


Private Sub Form_Resize()
   If Me.WindowState = 1 Then
        If Not isDebug Then menuTray_Hide_Click
        Exit Sub
    End If
    LastStatus = Me.WindowState
End Sub

Private Sub menuSYS_Set_Click()
   frmSet.Show 1
End Sub



Private Sub ListView_DblClick()
    bntEdit_Click
End Sub

Private Sub menuTC35_Add_Click()
    bntNew_Click
End Sub

Private Sub menuTC35_Delete_Click()
    bntDelete_Click
End Sub

Private Sub menuTC35_Edit_Click()
    If bntEdit.Enabled Then
        bntEdit_Click
    End If
End Sub

Private Sub menuTray_Hide_Click()
   Me.Visible = False
   menuTray_Hide.Enabled = False
   menuTray_Open.Enabled = True
   Me.WindowState = LastStatus
End Sub


'初始化各端口
Private Function InitComm() As Integer
   Dim li As ListItem
   Dim n As Integer
   Dim i As Integer
   Dim s As String
   With ListView.ListItems
      For i = 1 To .Count
          Set li = .Item(i)
          li.Bold = False
          li.SubItems(2) = "正初始化..."
          If SetTC35(i).Init(MSComm(i), li.Text, li.SubItems(1)) = True Then
              SetTC35(i).Key = li.Key
              li.SubItems(2) = "初始化成功"
              'li.SubItems(3) = SetTC35(i).ErrMsg
              li.Bold = True
              n = n + 1
          Else
              li.SubItems(2) = "初始化失败"
              'li.SubItems(3) = SetTC35(i).ErrMsg
          End If
      Next i
   End With
   If n = 0 Then
        s = "无法从当前的设备当中启动一个用于发送短信"
        setStatus s
        ShowMsg s
   End If
   InitComm = n
   Exit Function
laberr:
    s = "初始化各通讯端口时出错,错误信息为:" & Err.Description
    setStatus s
    ShowMsg s
    InitComm = -1
End Function

'关闭端口
Private Sub CloseComm()
   Dim li As ListItem
   Dim i As Integer
   With ListView.ListItems
      For i = 1 To .Count
          Set SetTC35(i) = Nothing
      Next i
   End With
End Sub


Private Sub menuTray_Open_Click()
   Me.Visible = True
   menuTray_Hide.Enabled = True
   menuTray_Open.Enabled = False
End Sub


Private Function StrLen(ByVal s As String) As Integer
   Dim i As Integer
   Dim n As Integer
   n = 0
   For i = 1 To Len(s)
      If Asc(Mid(s, i, 1)) < 0 Then
         n = n + 2
      Else
         n = n + 1
      End If
   Next i
   StrLen = n
End Function

Private Sub Form_Unload(Cancel As Integer)
   bExit = ShowYesNo("系统正在发送SM，如果你退出，则内部待处理的SM无法发送学生家长手中，你确认?")
   Cancel = Not bExit
   If Not Cancel Then
      If Not isDebug Then RemoveFromTray
   End If
End Sub


Private Sub menuExit_Click()
    bntCancel_Click
End Sub



Private Sub Timer_Timer()
  'On Error GoTo laberr
  Dim UserID As String
  Dim Mobile As String
  Dim Msg As String
  
  Dim AttendItemID As Long
  Dim ToUserName As String
  Dim ErrMsg As String
  Dim n As Long
  Dim SMID As Long
  Dim SMItemID As Long
  Dim nWebSm As Long
  Dim tn As Integer
  
  If bInit = False Then Timer.Interval = 0: Exit Sub
     
  OpenCN
  Set rs = cn.Execute("select isnull(count(*),0) from VIEW_WaitingSendSM")
  n = rs(0)
  CloseRS rs
  Set rs = cn.Execute("select isnull(count(*),0) from VIEW_SM")
  nWebSm = rs(0)
  CloseRS rs
  setWebSM nWebSm
  setSysSM n
  CloseCN
     
  If n + nWebSm = 0 Then
  
     setStatus "系统暂无待发送的短信内容"
     Exit Sub
  End If
  
 
  
  bExit = False
  If n > 0 And chkSendAttend.Value = 1 Then
        
        setStatus "正在读取需要发送的考勤短信...."
        OpenCN
        Set rs = cn.Execute("select Top " & OkTC35Number & " * from VIEW_WaitingSendSM order by dtCreate desc")
        tn = 0
        Do While Not bExit And Not rs.EOF
               tn = tn + 1
               SetTC35(tn).Para1 = rs("AttendItemID")
               SetTC35(tn).Para2 = rs("PaterName")
               SetTC35(tn).Para3 = "SysSM"
               SetTC35(tn).Telphone = rs("Mobile")
               SetTC35(tn).Msg = rs("Msg")
               DoEvents
               rs.MoveNext
               If bExit Then Exit Do
        Loop
        CloseRS rs
        CloseCN
        
        If Not bExit And tn > 0 Then
           setStatus "正在发送考勤短信...."
           GroupSendSM SetTC35, tn, bExit
        End If
        
  
  End If
  
  If nWebSm > 0 And chkSendWebSM.Value = 1 And bExit = False Then
        OpenCN
        Set rs = cn.Execute("select Top " & OkTC35Number & " * from VIEW_SM")
        setStatus "正在读取需要发送的WEB短信..."
        tn = 0
        Do While Not rs.EOF And Not bExit
               tn = tn + 1
               SetTC35(tn).Para1 = rs("SMItemID")   '392
               SetTC35(tn).Para2 = rs("SMID")   '62
               SetTC35(tn).Para3 = "WebSM"
               SetTC35(tn).Telphone = rs("ToMobile")  '13148839934
               SetTC35(tn).Msg = rs("Msg") 'test
               DoEvents
               rs.MoveNext
               If bExit Then Exit Do
        Loop
        CloseRS rs
        CloseCN
        
        If Not bExit And tn > 0 Then
            setStatus "正在发送WEB短信..."
            GroupSendSM SetTC35, tn, bExit
        End If
        
  End If
  
  '当前被中断
  If bExit = True Then Call SetSendStatus(True)
  Exit Sub

laberr:
  setStatus "出错:" & Err.Description
  bInit = False
  CloseCN

End Sub


Private Sub setStatus(ByVal s As String)
   StatusBar.Panels(3).Text = "状态：" & s
End Sub

Private Sub setWebSM(ByVal s As String)
   StatusBar.Panels(1).Text = "网络短信：" & s
End Sub


Private Sub setSysSM(ByVal s As String)
   StatusBar.Panels(2).Text = "考勤短信：" & s
End Sub

'从系统数据中装入TC35设备信息
Private Function LoadTC35() As Integer
   Dim rs As ADODB.Recordset
   Dim li As ListItem
   Dim n As Integer
   n = 0
   OpenCN
   Set rs = cn.Execute("select top 8 * from view_TC35")
   With ListView
       .ListItems.Clear
       While Not rs.EOF
             Set li = .ListItems.Add(, "T_" & rs("tc35id"), rs("Port"))
             li.SubItems(1) = rs("ServiceTelphone")
             li.SubItems(3) = rs("SpKind")
             li.SubItems(4) = rs("Prex")
             rs.MoveNext
             n = n + 1
       Wend
   End With
   CloseRS rs
   CloseCN
   LoadTC35 = n
   Exit Function
laberr:
   If Not rs Is Nothing Then CloseRS rs
   CloseCN
   LoadTC35 = -1
   setStatus "装入TC设备信息出错," & Err.Description
End Function

Private Sub SetSendStatus(ByVal b As Boolean)
   
   bntSend.Enabled = b
   bntSTOP.Enabled = Not b
   bntNew.Enabled = b
   bntEdit.Enabled = b
   bntDelete.Enabled = b
   
   menuTC35_Add.Enabled = b
   menuTC35_Edit.Enabled = b
   menuTC35_Delete.Enabled = b
End Sub