frmmain.frm

完成企业内部部门人员的联系

      End
      Begin VB.Menu mnuReplyInfo 
         Caption         =   "回复信息(&R)"
         Shortcut        =   ^R
      End
      Begin VB.Menu mnuGetInfo 
         Caption         =   "提取信息(&O)"
         Shortcut        =   ^O
      End
      Begin VB.Menu mnuInfoQuery 
         Caption         =   "查询信息(&Q)"
         Shortcut        =   ^Q
      End
      Begin VB.Menu mnuDelInfo 
         Caption         =   "删除信息(&D)"
         Shortcut        =   ^D
      End
      Begin VB.Menu ln3 
         Caption         =   "-"
      End
      Begin VB.Menu mnuInfoBroardcast 
         Caption         =   "发送广播(&B)"
         Shortcut        =   ^B
      End
   End
   Begin VB.Menu mnuHelp 
      Caption         =   "帮助(&H)"
      Begin VB.Menu mnuHelpCHM 
         Caption         =   "使用帮助(&H)"
         Shortcut        =   ^H
      End
      Begin VB.Menu ln4 
         Caption         =   "-"
      End
      Begin VB.Menu mnuAbout 
         Caption         =   "关于(&A)"
         Shortcut        =   ^A
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'****************************************
'*      企业内部业务联系系统 1.0版      *
'*                                      *
'*  作者：郭文云(云南电信昭通分公司)    *
'*  日期：2004年8月                     *
'*  版权：Terrificsoft                  *
'*          版权所有  侵权必究          *
'****************************************

Option Explicit
Public CurrentItemNumber As Integer

'强制收发件部门必有一个为本部门
Private Sub cboDept_click(Index As Integer)
  Dim i As Long
  If UserDept <> "系统管理员" Then
     Select Case Index
     Case 0:
       '如果发件部门不是本部门则设置收件部门为本部门
       If cboDept(Index).Text <> UserDept Then
          For i = 0 To cboDept(1).ListCount - 1
              If cboDept(1).List(i) = UserDept Then cboDept(1).ListIndex = i: Exit For
          Next i
       End If
     Case 1:
       '如果收件部门不是本部门则设置发件部门为本部门
       If cboDept(Index).Text <> UserDept Then
          For i = 0 To cboDept(0).ListCount - 1
              If cboDept(0).List(i) = UserDept Then cboDept(0).ListIndex = i: Exit For
          Next i
       End If
     End Select
  End If
End Sub

'组合条件的选择
Private Sub chkQuery_Click(Index As Integer)
  Select Case Index
    Case 0:
      '强制用户同时选择发件和收件部门
      If UserDept <> "系统管理员" Then chkQuery(1).Value = chkQuery(0).Value
      '根据用户选择启用相应控件
      If chkQuery(Index).Value = 1 Then
         cboDept(0).Enabled = True
      Else: cboDept(0).Enabled = False
      End If
    Case 1:
      If UserDept <> "系统管理员" Then chkQuery(0).Value = chkQuery(1).Value
      If chkQuery(Index).Value = 1 Then
         cboDept(1).Enabled = True
      Else: cboDept(1).Enabled = False
      End If
    Case 2:
      If UserDept <> "系统管理员" Then chkQuery(3).Value = chkQuery(2).Value
      If chkQuery(Index).Value = 1 Then
         txt(6).Enabled = True
         txt(6).SetFocus
      Else: txt(6).Enabled = False
      End If
    Case 3:
      If UserDept <> "系统管理员" Then chkQuery(2).Value = chkQuery(3).Value
      If chkQuery(Index).Value = 1 Then
         txt(7).Enabled = True
         txt(7).SetFocus
      Else: txt(7).Enabled = False
      End If
  End Select
End Sub

'在信息列表显示部门树的某部门信息
Private Sub trvDept_NodeClick(ByVal Node As MSComctlLib.Node)
  On Error GoTo ErrorHandler
  Dim Item As ListItem
  Dim Dept As String, strSQL As String
  Dim icon As Integer, i As Long
  lbl(5) = "发件部门："
  lbl(6) = "发件人："
  lbl(7) = "发件人电话："
  lbl(8) = "发件时间："
  lbl(9) = "处理时限："
  SBar.Panels(1).Text = "获取" & trvDept.SelectedItem.Text & "的信息"
  '节点不能是根节点及其一级子节点
  If trvDept.SelectedItem.Index <> 1 And trvDept.SelectedItem.Index <> 2 And trvDept.SelectedItem.Index <> 3 Then
     If GotInfo = False Then MsgBox "请先提取信息", vbInformation, "查看信息": Exit Sub
     For i = 0 To 5
       txt(i) = ""
     Next i
     ctlEnabled False
     lbl(0) = "请稍后，正在获取" & trvDept.SelectedItem.Text & "的信息..."
     Picture1.Visible = True
     '生成获取收件箱信息的SQL查询语句
     If trvDept.SelectedItem.Index >= 4 And trvDept.SelectedItem.Index <= 8 Then
        Dept = "DeptSend"
        If UserDept = "系统管理员" Then
           strSQL = "SELECT * FROM tblInfo "
           strSQL = strSQL & "WHERE DeptSend='" & trvDept.SelectedItem.Text & "'"
        Else
           strSQL = "SELECT * FROM tblInfo "
           strSQL = strSQL & "WHERE DeptSend='" & trvDept.SelectedItem.Text
           strSQL = strSQL & "' and DeptRecieve='" & UserDept & "'"
        End If
     End If
     '生成获取发件箱信息的SQL查询语句
     If trvDept.SelectedItem.Index >= 9 And trvDept.SelectedItem.Index <= 13 Then
        Dept = "DeptRecieve"
        strSQL = "SELECT * FROM tblInfo WHERE DeptSend='" & UserDept & "' and DeptRecieve='" & trvDept.SelectedItem.Text & "'"
     End If
     '初始化信息列表
     lsvInfoInit Dept, "VIEW"
     '在数据库查询信息
     Set RsAdo = New ADODB.Recordset
     RsAdo.CursorType = adOpenStatic
     RsAdo.Open strSQL, AdoCon, adOpenStatic, adLockReadOnly
     If Not RsAdo.EOF Then
        If Dept = "DeptSend" Then lbl(5) = "发件部门" & "："
        If Dept = "DeptRecieve" Then lbl(5) = "收件部门" & "："
        RsAdo.MoveFirst
        Do While Not RsAdo.EOF
           '在信息列表中表示
           If RsAdo("Processed") = False Then icon = 3
           If RsAdo("Processed") = True Then icon = 4
           Set Item = lsvInfo.ListItems.Add(, , RsAdo("InfoID"), , icon)
           Item.SubItems(1) = RsAdo(Dept)
           Item.SubItems(2) = RsAdo("Addresser")
           Item.SubItems(3) = RsAdo("AddresserTel")
           Item.SubItems(4) = RsAdo("ProcTimeLimit")
           Item.SubItems(5) = RsAdo("SendTime")
           RsAdo.MoveNext
        Loop
        If Node.Image = 3 Then PlaySound App.Path & "\msg.wav"
     End If
     CloseRsAdo
     '提示
     If lsvInfo.ListItems.Count > 0 Then
        lbl(0) = "一共获取到 " & lsvInfo.ListItems.Count & " 条" & trvDept.SelectedItem.Text & "的信息。"
     Else: lbl(0) = "没有关于该部门的信息！"
     End If
     If lsvInfo.ListItems.Count >= 1 Then
        CurrentItemNumber = 1
        lsvInfo_ItemClick lsvInfo.ListItems(1)
        lsvInfo.SetFocus
     End If
     If lsvInfo.ListItems.Count <= 1 Then cmdNext.Enabled = False Else cmdNext.Enabled = True
     TimeDelay 2000
     Picture1.Visible = False
  End If
  Exit Sub
ErrorHandler:
  MsgBox Err.Description, vbCritical, "出现错误"
  Exit Sub
End Sub

'在文本框显示详细信息
Private Sub lsvInfo_ItemClick(ByVal Item As MSComctlLib.ListItem)
  On Error GoTo ErrorHandler
  Dim strSQL As String
  lbl(5) = "发件部门："
  lbl(6) = "发件人："
  lbl(7) = "发件人电话："
  lbl(8) = "发件时间："
  lbl(9) = "处理时限："
  SBar.Panels(1).Text = "阅读" & Item.ListSubItems(1).Text & "发送的信息"
  '获取信息
  Set RsAdo = New ADODB.Recordset
  RsAdo.CursorType = adOpenStatic
  strSQL = "SELECT * FROM tblInfo "
  strSQL = strSQL & "WHERE InfoID='" & Item.Text & "'"
  RsAdo.Open strSQL, AdoCon, adOpenStatic, adLockReadOnly
  If Not RsAdo.EOF Then
     RsAdo.MoveFirst
     '在文本框中显示详细信息
     txt(0) = RsAdo("DeptSend")
     txt(1) = RsAdo("Addresser")
     txt(2) = RsAdo("AddresserTel")
     txt(3) = RsAdo("SendTime")
     txt(4) = RsAdo("ProcTimeLimit")
     txt(5) = RsAdo("InfoContent")
  End If
  CloseRsAdo
  '处理按钮和菜单的Enable属性
  If lsvInfo.ListItems.Count > 0 Then
     If CanBeDel Then
        cmdDelInfo.Enabled = True
        mnuDelInfo.Enabled = True
        TBar.Buttons(10).Enabled = True
     Else
        cmdDelInfo.Enabled = False
        mnuDelInfo.Enabled = False
        TBar.Buttons(10).Enabled = False
     End If
  End If
  cmdPrevious.Enabled = True
  cmdNext.Enabled = True
  If lsvInfo.SelectedItem.SmallIcon = 4 Then cmdReadReply.Enabled = True Else cmdReadReply.Enabled = False
  If Item.Index = 1 Then cmdPrevious.Enabled = False
  If Item.Index = lsvInfo.ListItems.Count Then cmdNext.Enabled = False
  '获取当前单击行的索引
  CurrentItemNumber = Item.Index
  Exit Sub
ErrorHandler:
  MsgBox Err.Description, vbCritical, "出现错误"
  Resume Next
End Sub

'按照组合条件查询信息
Private Sub cmdQuery_Click()
  On Error Resume Next
  Dim Condition As String         '查询条件
  Dim Item As ListItem            'lsv的行
  Dim icon As Integer             'lsvInfo的行的图标
  Dim strSQL As String
  '提示
  If chkQuery(0).Value <> 1 And chkQuery(1).Value <> 1 _
  And chkQuery(2).Value <> 1 And chkQuery(3).Value <> 1 Then
     MsgBox "请至少选择一项查询条件。", vbInformation, "查询信息"
     Exit Sub
  End If
  lbl(3).Visible = False
  lbl(4).Visible = False
  lsvInfoInit "DeptSend", "QUERY"
  Condition = QuerySQL
  '在数据库查询信息
  Set RsAdo = New Recordset
  strSQL = "SELECT * FROM tblInfo WHERE " & Condition
  RsAdo.Open strSQL, AdoCon, adOpenStatic, adLockReadOnly
  If Not RsAdo.EOF Then
     RsAdo.MoveFirst
     Do While Not RsAdo.EOF
        '在信息列表显示信息
        If RsAdo("Processed") = False Then icon = 3
        If RsAdo("Processed") = True Then icon = 4
        Set Item = lsvInfo.ListItems.Add(, , RsAdo("InfoID"), , icon)
        Item.SubItems(1) = RsAdo("DeptSend")               '发件部门
        Item.SubItems(2) = RsAdo("Addresser")              '发件人
        Item.SubItems(3) = RsAdo("AddresserTel")           '发件人电话
        Item.SubItems(4) = RsAdo("ProcTimelimit")          '处理时限
        Item.SubItems(5) = RsAdo("SendTime")               '发件时间
        Item.SubItems(6) = RsAdo("DeptRecieve")            '收件部门
        Item.SubItems(7) = RsAdo("Replyer")                '回复人
        Item.SubItems(8) = RsAdo("ReplyerTel")             '回复人电话
        Item.SubItems(9) = RsAdo("ReplyTime")              '回复时间
        RsAdo.MoveNext
     Loop
  End If
  '处理按钮的Enabled属性并单击第一条信息
  If lsvInfo.ListItems.Count <= 1 Then
     cmdNext.Enabled = False
  Else
     lsvInfo.ListItems(1).Selected = True
     cmdNext.Enabled = True
     CurrentItemNumber = 1
     lsvInfo_ItemClick lsvInfo.ListItems(1)
  End If
  MsgBox "查询完毕。", vbInformation, "查询信息"
  lbl(4) = "本次查询为您找到 " & lsvInfo.ListItems.Count & " 条记录。"
  lbl(3).Visible = True
  lbl(4).Visible = True
End Sub

'查看信息的回复信息
Private Sub cmdReadReply_Click()
  On Error GoTo ErrorHandler
  Dim strSQL As String
  lbl(5) = "发件部门："
  lbl(6) = "回复部门："
  lbl(7) = "回复人："
  lbl(8) = "回复人电话："
  lbl(9) = "回复时间："
  SBar.Panels(1).Text = "阅读回复给" & lsvInfo.SelectedItem.ListSubItems(1).Text & "的信息"
  '在数据库查询信息的回复
  Set RsAdo = New ADODB.Recordset
  RsAdo.CursorType = adOpenStatic
  strSQL = "SELECT * FROM tblInfo "
  strSQL = strSQL & "WHERE InfoID='" & lsvInfo.SelectedItem.Text & "'"
  RsAdo.Open strSQL, AdoCon, adOpenStatic, adLockReadOnly
  If Not RsAdo.EOF Then
     RsAdo.MoveFirst
     '在文本框显示信息的回复
     txt(0) = RsAdo("DeptSend")
     txt(1) = RsAdo("DeptRecieve")
     txt(2) = RsAdo("Replyer")
     txt(3) = RsAdo("ReplyerTel")
     txt(4) = RsAdo("ReplyTime")
     txt(5) = RsAdo("ReplyContent")
  End If
  CloseRsAdo
  lsvInfo.SetFocus
  Exit Sub
ErrorHandler:
  MsgBox Err.Description, vbCritical, "出现错误"
  Exit Sub
End Sub