frmsendinfo.frm

<Visual Basic 数据库开发实例精粹（第二版）>一书首先介绍了Visual Basic(简称VB)开发的技巧和重点技术

         Style           =   1  'Checkbox
         TabIndex        =   10
         Top             =   540
         Width           =   2115
      End
      Begin VB.Label lbl 
         AutoSize        =   -1  'True
         Caption         =   "请选择接收本信息的部门"
         Height          =   180
         Index           =   7
         Left            =   240
         TabIndex        =   25
         Top             =   240
         Width           =   1980
      End
   End
   Begin VB.Menu mnuOperate 
      Caption         =   "操作(&O)"
      Begin VB.Menu mnuSendInfo 
         Caption         =   "立即发送(&S)"
         Shortcut        =   ^S
      End
      Begin VB.Menu ln1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuReturn 
         Caption         =   "返回(&R)"
         Shortcut        =   ^R
      End
   End
   Begin VB.Menu mnuHelp 
      Caption         =   "帮助(&H)"
      Begin VB.Menu mnuHelpInfo 
         Caption         =   "帮助文档(&H)"
         Shortcut        =   ^H
      End
   End
End
Attribute VB_Name = "frmSendInfo"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'****************************************
'*      企业内部业务联系系统 1.0版      *
'*                                      *
'*  作者：郭文云(云南电信昭通分公司)    *
'*  日期：2004年8月                     *
'*  版权：Terrificsoft                  *
'*          版权所有  侵权必究          *
'****************************************

Option Explicit

'设置收件部门文本框的提示
Private Sub cmdAllSelected_Click()
  Dim i As Long
  For i = 0 To lstDept.ListCount - 1
      lstDept.Selected(i) = True
  Next i
  lstDept.ListIndex = -1
  txt(6) = "发送广播 [共发往 " & lstDept.ListCount & " 个部门]"
End Sub

Private Sub cmdCancel_Click()
  Unload Me
End Sub

'设置收件部门文本框的提示
Private Sub cmdNoneSelected_Click()
  Dim i As Long
  For i = 0 To lstDept.ListCount - 1
      lstDept.Selected(i) = False
  Next i
  lstDept.ListIndex = -1
  txt(6).Text = "发送广播 [共发往 0 个部门]"
End Sub

'发送信息菜单单击事件
Private Sub cmdSend_Click()
  mnuSendInfo_Click
End Sub

'初始化窗体
Private Sub Form_Load()
  txt(4) = Format(Now, "yyyy-mm-dd hh:mm")
  AddComboItems cboDept
  AddListItems lstDept
End Sub

Private Sub mnuHelpInfo_Click()
  ShellExecute Me.hwnd, "open", App.Path & "\readme.txt", "", "", SW_SHOW
End Sub

'设置收件部门文本框的提示
Private Sub lstDept_ItemCheck(Item As Integer)
  Dim DeptNum As Integer
  Dim i As Long
  '根据lstDept的选择计算发送要广播的部门数
  For i = 0 To lstDept.ListCount - 1
      If lstDept.Selected(i) = True Then DeptNum = DeptNum + 1
  Next i
  txt(6) = "发送广播 [共发往 " & DeptNum & " 个部门]"
  txt(6).Visible = True
End Sub

Private Sub mnuReturn_Click()
  Unload Me
End Sub

'发送信息，包括发送新信息，回复信息和发送广播
Private Sub mnuSendInfo_Click()
  On Error GoTo ErrorHandler
  Dim i As Long
  For i = 0 To 5
      If txt(i) = "" Then
         MsgBox "请将每一项目都填写完整。", vbInformation, Me.Caption
         Exit Sub
      End If
  Next i
  frmPrompt.lbl = "请稍候，正在发送信息......"
  frmPrompt.Show vbModeless, Me
  DoEvents
  '发送新信息
  If Me.Caption = "新信息" Then NewInfo
  '回复信息
  If Me.Caption = "回复信息" Then ReplyInfo
  '发送广播信息
  If Me.Caption = "发送广播" Then
    '判断是否至少选择了一个接收部门
    Dim CanBeSent As Boolean
    For i = 0 To lstDept.ListCount - 1
        If lstDept.Selected(i) = True Then CanBeSent = True
    Next i
    If CanBeSent = False Then
       MsgBox "请至少选择一个部门进行发送。", vbInformation, "发送广播"
       Unload frmPrompt
       Exit Sub
    End If
    BroadcastInfo
  End If
  TimeDelay 1000
  Unload frmPrompt
  MsgBox "信息已经成功发送！", vbInformation, Me.Caption
  Exit Sub
ErrorHandler:
  Unload frmPrompt
  MsgBox Err.Description, vbCritical, "出现错误"
  MsgBox "信息发送失败！", vbCritical, "出现错误"
  Exit Sub
End Sub

'发送新信息
Private Sub NewInfo()
  Dim strSQL As String
  Set RsAdo = New ADODB.Recordset
  '构造SQL语句（不要忘记过滤单引号）
  strSQL = "INSERT INTO tblInfo(DeptSend,DeptRecieve,Addresser,"
  strSQL = strSQL & "AddresserTel,ProcTimeLimit,SendTime,InfoContent,Processed)"
  strSQL = strSQL & "VALUES ('"
  strSQL = strSQL & RealString(txt(0)) & "','"          '发件部门
  strSQL = strSQL & RealString(cboDept.Text) & "','"    '收件部门
  strSQL = strSQL & RealString(txt(1)) & "','"          '发件人
  strSQL = strSQL & RealString(txt(2)) & "','"          '发件人电话
  strSQL = strSQL & RealString(txt(3)) & "','"          '处理时限
  strSQL = strSQL & RealString(txt(4)) & "','"          '发送时间
  strSQL = strSQL & RealString(txt(5)) & "',"           '联系内容
  strSQL = strSQL & "0)"                                '是否已处理
  RsAdo.Open strSQL, AdoCon, adOpenStatic, adLockReadOnly
  CloseRsAdo
End Sub

'回复信息
Private Sub ReplyInfo()
  Dim strSQL As String
  Set RsAdo = New ADODB.Recordset
  '构造SQL语句（不要忘记过滤单引号）
  strSQL = "UPDATE tblInfo SET Processed=1,"
  strSQL = strSQL & "Replyer='" & RealString(txt(1))
  strSQL = strSQL & "',ReplyerTel='" & RealString(txt(2))
  strSQL = strSQL & "',ReplyTime='" & RealString(txt(4))
  strSQL = strSQL & "',ReplyContent='" & RealString(txt(5))
  strSQL = strSQL & "' WHERE InfoID='"
  strSQL = strSQL & frmMain.lsvInfo.ListItems(frmMain.CurrentItemNumber).Text & "'"
  RsAdo.Open strSQL, AdoCon, adOpenStatic, adLockReadOnly
  CloseRsAdo
  '处理信息列表的信息图标
  frmMain.lsvInfo.ListItems(frmMain.CurrentItemNumber).SmallIcon = 4
  '处理部门数的节点图标
  trvIconProc
End Sub

'发送广播
Private Sub BroadcastInfo()
  Dim i As Long
  Dim strSQL As String
  For i = 0 To lstDept.ListCount - 1
    If lstDept.Selected(i) = True Then
       Set RsAdo = New ADODB.Recordset
       '构造SQL语句（不要忘记过滤单引号）
       strSQL = "INSERT INTO tblInfo(DeptSend,DeptRecieve,Addresser,"
       strSQL = strSQL & "AddresserTel,ProcTimeLimit,SendTime,InfoContent,Processed)"
       strSQL = strSQL & "VALUES ('"
       strSQL = strSQL & RealString(txt(0)) & "','"          '发件部门
       strSQL = strSQL & RealString(lstDept.List(i)) & "','" '收件部门
       strSQL = strSQL & RealString(txt(1)) & "','"          '发件人
       strSQL = strSQL & RealString(txt(2)) & "','"          '发件人电话
       strSQL = strSQL & RealString(txt(3)) & "','"          '处理时限
       strSQL = strSQL & RealString(txt(4)) & "','"          '发送时间
       strSQL = strSQL & RealString(txt(5)) & "',"           '联系内容
       strSQL = strSQL & "0)"                                '是否已处理
       RsAdo.Open strSQL, AdoCon, adOpenStatic, adLockReadOnly
    End If
  Next i
  CloseRsAdo
End Sub

'处理根节点及其一级子节点
Private Sub trvIconProc()
  Dim i As Long
  Dim NewInboxInfo As Boolean, NewOutBoxInfo As Boolean
  NewInboxInfo = True
  NewOutBoxInfo = True
  '由信息列表的信息图标决定部门树的部门节点图标
  If frmMain.lsvInfo.ColumnHeaders.Count < 7 Then
     frmMain.trvDept.SelectedItem.Image = 4
     If frmMain.lsvInfo.ListItems.Count > 1 Then
        For i = 1 To frmMain.lsvInfo.ListItems.Count
            If frmMain.lsvInfo.ListItems(i).SmallIcon <> 4 Then
               frmMain.trvDept.SelectedItem.Image = 3
               Exit For
            End If
        Next i
     End If
  End If
  '判断“收件箱”中是否还有未处理信息
  For i = 4 To 8
      If frmMain.trvDept.Nodes(i).Image <> 4 Then
         NewInboxInfo = False
         Exit For
      End If
  Next i
  '判断“发件箱”中是否还有未处理信息
  For i = 9 To 13
      If frmMain.trvDept.Nodes(i).Image <> 4 Then
         NewOutBoxInfo = False
         Exit For
      End If
  Next i
  '“收件箱”节点
  If NewInboxInfo Then frmMain.trvDept.Nodes(2).Image = 4
  '“发件箱”节点
  If NewOutBoxInfo Then frmMain.trvDept.Nodes(3).Image = 4
  '根节点
  If NewInboxInfo And NewOutBoxInfo Then frmMain.trvDept.Nodes(1).Image = 2
End Sub

'同步发送时间文本框的时间
Private Sub Tmr_Timer()
  txt(4) = Format(Now, "yyyy-mm-dd hh:mm")
End Sub

'文本框被激活时，选定所有文本
Private Sub txt_GotFocus(Index As Integer)
  txt(Index).SelStart = 0
  txt(Index).SelLength = Len(txt(Index))
End Sub