frmmain.frm

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

'控制删除信息的界面
Private Sub lsvInfo_ItemCheck(ByVal Item As MSComctlLib.ListItem)
  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 Sub

'查看下一条信息
Private Sub cmdNext_Click()
  CurrentItemNumber = CurrentItemNumber + 1
  lsvInfo.ListItems(CurrentItemNumber).Selected = True
  lsvInfo_ItemClick lsvInfo.ListItems(CurrentItemNumber)
  lsvInfo.SetFocus
End Sub

'查看上一条信息
Private Sub cmdPrevious_Click()
  CurrentItemNumber = CurrentItemNumber - 1
  lsvInfo.ListItems(CurrentItemNumber).Selected = True
  lsvInfo_ItemClick lsvInfo.ListItems(CurrentItemNumber)
  lsvInfo.SetFocus
End Sub

'隐藏查询界面，显示部门树
Private Sub cmdReturn_Click()
  lbl(3).Visible = False
  lbl(4).Visible = False
  picQuery.Visible = False
  trvDept.Visible = True
End Sub

Private Sub cmdDelInfo_Click()
  mnuDelInfo_Click
End Sub

Private Sub Form_Unload(Cancel As Integer)
  If LoginStat = 2 Then
     If MsgBox("您确定要退出本系统吗？", vbInformation + vbYesNo, "退出系统") = vbYes Then
        '关闭数据库连接
        If Not (AdoCon Is Nothing) Then
           AdoCon.Close
           Set AdoCon = Nothing
        End If
        '结束程序运行
        End
     Else: Cancel = 1   '取消卸载窗体
     End If
  End If
End Sub

'主界面加载时初始化界面
Private Sub Form_Load()
  Dim i As Long
  On Error Resume Next
  '设置部门树和信息列表
  trvDeptInit
  lsvInfoInit "DeptSend", "VIEW"
  '添加组合框的项目
  AddComboItems cboDept(0)
  AddComboItems cboDept(1)
  cboDept(0).AddItem UserDept
  cboDept(1).AddItem UserDept
  For i = 0 To cboDept(0).ListCount - 1
      If cboDept(0).List(i) = UserDept Then cboDept(0).ListIndex = i: Exit For
  Next i
  '设置状态栏
  SBar.Panels(1).Text = "就绪"
  SBar.Panels(2).Text = "     特瑞飞软件 打造软件精品"
  SBar.Panels(3).Text = Format(Now, "yyyy年m月d日 hh:mm:ss")
  lbl(1) = "当前登录部门：" & UserDept
  lbl(2) = lbl(1)
  mnuDelInfo.Enabled = False
  Show
  If MsgBox("您要现在提取信息吗？", vbQuestion + vbYesNo, "提取信息") = vbYes Then mnuGetInfo_Click
End Sub

'根据用户的选择来得到查询条件
Private Function QuerySQL() As String
  If chkQuery(0).Value = 1 Then
     QuerySQL = QuerySQL & " and DeptSend = '" & RealString(cboDept(0).Text) & "'"
  End If
  If chkQuery(1).Value = 1 Then
     QuerySQL = QuerySQL & " and DeptRecieve = '" & RealString(cboDept(1).Text) & "'"
  End If
  If chkQuery(2).Value = 1 Then
     QuerySQL = QuerySQL & " and Addresser = '" & RealString(txt(6).Text) & "'"
  End If
  If chkQuery(3).Value = 1 Then
     QuerySQL = QuerySQL & " and Replyer = '" & RealString(txt(7).Text) & "'"
  End If
  If Left(QuerySQL, 5) = " and " Then
     QuerySQL = Mid(QuerySQL, 6, Len(QuerySQL) - 5)
  End If
End Function

'为部门树添加节点
Private Sub trvDeptInit()
  Dim i As Long
  Dim Sys As Node, Inbox As Node, Outbox As Node, Dept As Node
  trvDept.Nodes.Clear
  '添加根节点
  Set Sys = trvDept.Nodes.Add(, , , "企业内部业务联系系统", 2)
  '添加根接点的一级子节点
  Set Inbox = trvDept.Nodes.Add(Sys, tvwChild, , "收件箱", 4)
  Set Outbox = trvDept.Nodes.Add(Sys, tvwChild, , "发件箱", 4)
  '展开根节点
  Sys.Expanded = True
  '展开Inbox节点
  Inbox.Expanded = True
  '添加Inbox的子节点
  Set Dept = trvDept.Nodes.Add(Inbox, tvwChild, , "系统管理员", 4)
  Set Dept = trvDept.Nodes.Add(Inbox, tvwChild, , "帐务中心", 4)
  Set Dept = trvDept.Nodes.Add(Inbox, tvwChild, , "市场拓展部", 4)
  Set Dept = trvDept.Nodes.Add(Inbox, tvwChild, , "公众客户部", 4)
  Set Dept = trvDept.Nodes.Add(Inbox, tvwChild, , "大客户部", 4)
  Set Dept = trvDept.Nodes.Add(Inbox, tvwChild, , "网络管理调度部", 4)
  '添加Outbox的子节点
  Set Dept = trvDept.Nodes.Add(Outbox, tvwChild, , "系统管理员", 4)
  Set Dept = trvDept.Nodes.Add(Outbox, tvwChild, , "帐务中心", 4)
  Set Dept = trvDept.Nodes.Add(Outbox, tvwChild, , "市场拓展部", 4)
  Set Dept = trvDept.Nodes.Add(Outbox, tvwChild, , "公众客户部", 4)
  Set Dept = trvDept.Nodes.Add(Outbox, tvwChild, , "大客户部", 4)
  Set Dept = trvDept.Nodes.Add(Outbox, tvwChild, , "网络管理调度部", 4)
  '移除当前登录部门
  For i = trvDept.Nodes.Count To 1 Step -1
    If trvDept.Nodes(i).Text = UserDept Then
       trvDept.Nodes.Remove i
    End If
  Next i
End Sub

'设置信息列表的列首
Private Sub lsvInfoInit(Dept As String, Stat As String)
  With lsvInfo
      '清空ListView项和标题头
      .ListItems.Clear
      .ColumnHeaders.Clear
      '添加标题头
      .ColumnHeaders.Add , , "信息号"
      If Dept = "DeptSend" Then .ColumnHeaders.Add , , "发件部门"
      If Dept = "DeptRecieve" Then .ColumnHeaders.Add , , "收件部门"
      .ColumnHeaders.Add , , "发件人"
      .ColumnHeaders.Add , , "发件人电话"
      .ColumnHeaders.Add , , "处理时限"
      .ColumnHeaders.Add , , "发件时间"
      If Stat = "QUERY" Then
      .ColumnHeaders.Add , , "回复部门"
      .ColumnHeaders.Add , , "回复人"
      .ColumnHeaders.Add , , "回复人电话"
      .ColumnHeaders.Add , , "回复时间"
      End If
      '设置列的宽度
      If Stat = "VIEW" Then
      .ColumnHeaders(1).Width = lsvInfo.Width / 8
      .ColumnHeaders(2).Width = lsvInfo.Width / 5.5
      .ColumnHeaders(3).Width = lsvInfo.Width / 8.5
      .ColumnHeaders(4).Width = lsvInfo.Width / 6
      .ColumnHeaders(5).Width = lsvInfo.Width / 8
      .ColumnHeaders(6).Width = lsvInfo.Width / 4
      End If
  End With
End Sub

'部分控件的启用和禁用
Private Sub ctlEnabled(Identify As Boolean)
  mnuDelInfo.Enabled = Identify
  TBar.Buttons(10).Enabled = Identify
  cmdDelInfo.Enabled = Identify
  cmdReadReply.Enabled = Identify
  cmdNext.Enabled = Identify
  cmdPrevious.Enabled = Identify
End Sub

'判断是否在信息列表选择信息进行删除
Private Function CanBeDel() As Boolean
  Dim i As Long
  For i = 1 To lsvInfo.ListItems.Count
      If lsvInfo.ListItems(i).Checked = True Then
         CanBeDel = True
         Exit For
      End If
  Next i
End Function

Private Sub Tmr_Timer()
  SBar.Panels(3).Text = Format(Now, "yyyy年m月d日 hh:mm:ss")
End Sub

'强制收发件人必有一个为当前用户
Private Sub txt_Change(Index As Integer)
  If UserDept <> "系统管理员" Then
     Select Case Index
       Case 6: If txt(Index) <> UserName Then txt(7) = UserName
       Case 7: If txt(Index) <> UserName Then txt(6) = UserName
     End Select
  End If
End Sub

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

Private Sub TBar_ButtonClick(ByVal Button As MSComctlLib.Button)
  Select Case Button.Index
    Case 2: mnuRelogin_Click
    Case 3: mnuUserMgmt_Click
    Case 5: mnuNewInfo_Click
    Case 6: mnuReplyInfo_Click
    Case 7: mnuGetInfo_Click
    Case 8: mnuInfoQuery_Click
    Case 9: mnuInfoBroardcast_Click
    Case 10: mnuDelInfo_Click
    Case 12: mnuAbout_Click
    Case 13: mnuExit_Click
  End Select
End Sub

'回复信息
Private Sub mnuReplyInfo_Click()
  If lsvInfo.ColumnHeaders(2) = "收件部门" Then
     MsgBox "不能回复自己所在部门发送的信息。", vbInformation, "回复信息"
     Exit Sub
  End If
  If lsvInfo.ListItems.Count > 0 Then
     If lsvInfo.SelectedItem.SmallIcon = 3 Then
        frmSendInfo.Caption = "回复信息"
        SetfrmSendInfo
     Else:
        MsgBox "请选择一条未被回复的信息进行回复。", vbInformation, "回复信息"
        Exit Sub
     End If
  Else:
     MsgBox "请选择一条信息进行回复。", vbInformation, "回复信息"
     Exit Sub
  End If
End Sub

'（按信息列表的选择）删除信息
Private Sub mnuDelInfo_Click()
  On Error GoTo ErrorHandler
  Dim i As Long
  Dim strSQL As String
  '删除数据库里的记录
  Set RsAdo = New ADODB.Recordset
  RsAdo.CursorType = adOpenStatic
  For i = lsvInfo.ListItems.Count To 1 Step -1
      If lsvInfo.ListItems(i).Checked = True Then
         strSQL = "delete FROM tblInfo WHERE InfoID = '" & lsvInfo.ListItems(i).Text & "'"
         RsAdo.Open strSQL, AdoCon, adOpenStatic, adLockReadOnly
         '更新信息列表里的信息
         lsvInfo.ListItems.Remove i
      End If
  Next i
  CloseRsAdo
  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
        MsgBox "信息已经成功删除。", vbInformation, "删除信息"
     End If
  End If
  '禁用功能对象
  cmdDelInfo.Enabled = False
  mnuDelInfo.Enabled = False
  TBar.Buttons(10).Enabled = False
  Exit Sub
ErrorHandler:
  MsgBox Err.Description, vbCritical, "出现错误"
  Exit Sub
End Sub

'显示查询信息界面
Private Sub mnuInfoQuery_Click()
  picQuery.Visible = True
  trvDept.Visible = False
  ctlEnabled False
End Sub

'显示关于软件界面
Private Sub mnuAbout_Click()
  frmAbout.Show vbModal, Me
End Sub

'显示用户管理界面
Private Sub mnuUserMgmt_Click()
  frmUsrMgmt.Show
End Sub

'显示发送广播界面
Private Sub mnuInfoBroardcast_Click()
  frmSendInfo.Caption = "发送广播"
  SetfrmSendInfo
End Sub

'退出系统
Private Sub mnuExit_Click()
  Unload Me
End Sub

'显示帮助文档
Private Sub mnuHelpCHM_Click()
  ShellExecute Me.hwnd, "open", App.Path & "\readme.txt", "", "", SW_SHOW
End Sub

'显示重新登录界面
Private Sub mnuRelogin_Click()
  LoginStat = 1
  frmLogin.Show vbModal, Me
End Sub

'显示发送新信息界面
Private Sub mnuNewInfo_Click()
  frmSendInfo.Caption = "新信息"
  SetfrmSendInfo
End Sub

'显示提取信息界面
Private Sub mnuGetInfo_Click()
  frmGetInfo.Show vbModeless, Me
End Sub