📄 frmgetinfo.frm
字号:
VERSION 5.00
Begin VB.Form frmGetInfo
BorderStyle = 1 'Fixed Single
Caption = "提取信息"
ClientHeight = 5205
ClientLeft = 45
ClientTop = 330
ClientWidth = 4065
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
ScaleHeight = 5205
ScaleWidth = 4065
StartUpPosition = 2 '屏幕中心
Begin VB.PictureBox pic
Appearance = 0 'Flat
BackColor = &H00808080&
BorderStyle = 0 'None
ForeColor = &H80000008&
Height = 330
Left = 0
ScaleHeight = 330
ScaleWidth = 4065
TabIndex = 8
Top = 0
Width = 4065
Begin VB.Label lbl
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "提取信息 [ 0 个部门]"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FFFFFF&
Height = 210
Index = 0
Left = 120
TabIndex = 10
Top = 60
Width = 2295
End
Begin VB.Label lbl
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "提取信息 [ 0 个部门]"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 210
Index = 1
Left = 150
TabIndex = 9
Top = 90
Width = 2295
End
End
Begin VB.Frame fr
Height = 4965
Index = 0
Left = 0
TabIndex = 0
Top = 240
Width = 4065
Begin VB.Frame fr
BeginProperty Font
Name = "宋体"
Size = 5.25
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 4635
Index = 1
Left = 90
TabIndex = 6
Top = 180
Width = 2430
Begin VB.ListBox lstDept
Height = 3840
Left = 150
Style = 1 'Checkbox
TabIndex = 1
Top = 570
Width = 2115
End
Begin VB.Label lbl
AutoSize = -1 'True
Caption = "请选择提取何部门的信息"
Height = 180
Index = 2
Left = 210
TabIndex = 7
Top = 210
Width = 1980
End
End
Begin VB.CommandButton cmdNoneSelected
Caption = "全否(&N)"
Height = 345
Left = 2670
TabIndex = 5
Top = 4350
Width = 1185
End
Begin VB.CommandButton cmdAllSelected
Caption = "全选(&A)"
Height = 345
Left = 2670
TabIndex = 4
Top = 3870
Width = 1185
End
Begin VB.CommandButton cmdGetInfo
Caption = "提取(&G)"
Default = -1 'True
Height = 375
Left = 2670
TabIndex = 2
Top = 360
Width = 1185
End
Begin VB.CommandButton cmdCancel
Caption = "取消(&C)"
Height = 375
Left = 2670
TabIndex = 3
Top = 840
Width = 1185
End
End
End
Attribute VB_Name = "frmGetInfo"
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 Form_Load()
'初始化部门列表框，添加部门名称
AddListItems lstDept
lstDept.AddItem UserDept
End Sub
'选择列表框的所有项目
Private Sub cmdAllSelected_Click()
Dim i As Long
For i = 0 To lstDept.ListCount - 1
lstDept.Selected(i) = True
Next i
'设置列表框的列表索引
lstDept.ListIndex = -1
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
End Sub
'提取信息，并在主界面上用红蓝图标的方式表示
Private Sub cmdGetInfo_Click()
On Error GoTo ErrorHandler
Dim strSQL As String
Dim i As Long
For i = 0 To lstDept.ListCount - 1
If lstDept.Selected(i) = True Then Exit For
If i = lstDept.ListCount - 1 Then
MsgBox "请先选择部门！", vbInformation, "提取信息"
Exit Sub
End If
Next i
frmPrompt.lbl = "请稍候，正在从服务器提取信息......"
frmPrompt.Show vbModeless, Me
DoEvents
cmdEnabled False
'提取信息
GetInfo
cmdEnabled True
TimeDelay 1000
Unload frmPrompt
GotInfo = True
If MsgBox("操作已结束！", vbInformation, "提取信息") = vbOK Then Unload Me
frmMain.SetFocus
Exit Sub
ErrorHandler:
MsgBox Err.Description, vbCritical, "提取信息"
cmdEnabled True
Exit Sub
End Sub
'按照选择的部门提取信息
Private Sub GetInfo()
On Error GoTo ErrorHandler
Dim strSQL As String
Dim i As Long, j As Long
frmMain.trvDept.Nodes(1).Image = 2
For i = 2 To 3
frmMain.trvDept.Nodes(i).Image = 4
Next i
For i = 4 To 13
frmMain.trvDept.Nodes(i).Image = 4
Next i
strSQL = "SELECT DeptSend,DeptRecieve FROM tblInfo WHERE Processed = 0"
'按照选择的部门提取信息
For i = 0 To lstDept.ListCount - 1
If lstDept.Selected(i) = True Then
Set RsAdo = New ADODB.Recordset
RsAdo.CursorType = adOpenStatic
RsAdo.Open strSQL, AdoCon, adOpenStatic, adLockReadOnly
If Not RsAdo.EOF Then
RsAdo.MoveFirst
Do While Not RsAdo.EOF
'主界面上显示收件箱的信息
For j = 4 To 8
'主界面上显示普通用户的新信息
If UserDept <> "系统管理员" Then
If RsAdo("DeptSend") = frmMain.trvDept.Nodes(j).Text _
And RsAdo("DeptRecieve") = UserDept _
Then frmMain.trvDept.Nodes(j).Image = 3
'主界面上显示系统管理员的新信息
Else
If RsAdo("DeptSend") = frmMain.trvDept.Nodes(j).Text _
Then frmMain.trvDept.Nodes(j).Image = 3
End If
Next j
'主界面上显示发件箱的信息
For j = 9 To 13
If RsAdo("DeptSend") = UserDept _
And RsAdo("DeptRecieve") = frmMain.trvDept.Nodes(j).Text _
Then frmMain.trvDept.Nodes(j).Image = 3
Next j
RsAdo.MoveNext
Loop
'处理根节点及其一级子节点
trvRootChlIcon
PlaySound App.Path & "\msg.wav"
End If
End If
Next i
CloseRsAdo
Exit Sub
ErrorHandler:
MsgBox Err.Description, vbCritical, "提取信息"
Exit Sub
End Sub
'处理根节点及其一级子节点的图标
Private Sub trvRootChlIcon()
Dim i As Long
'“收件箱”节点
For i = 4 To 8
If frmMain.trvDept.Nodes(i).Image = 3 Then frmMain.trvDept.Nodes(2).Image = 3
Next i
'“发件箱”节点
For i = 9 To 13
If frmMain.trvDept.Nodes(i).Image = 3 Then frmMain.trvDept.Nodes(3).Image = 3
Next i
'根节点
If frmMain.trvDept.Nodes(2).Image = 3 _
Or frmMain.trvDept.Nodes(3).Image = 3 Then frmMain.trvDept.Nodes(1).Image = 1
End Sub
'禁用和启用frmPrompt的按钮
Private Sub cmdEnabled(Identifier As Boolean)
cmdGetInfo.Enabled = Identifier
cmdCancel.Enabled = Identifier
cmdAllSelected.Enabled = Identifier
cmdNoneSelected.Enabled = Identifier
End Sub
Private Sub cmdCancel_Click()
Unload Me
End Sub
'设定提示标签
Private Sub lstDept_ItemCheck(Item As Integer)
Dim i As Long
Dim DeptNum As Integer
For i = 0 To lstDept.ListCount - 1
If lstDept.Selected(i) = True Then DeptNum = DeptNum + 1
Next i
lbl(0) = "提取信息 [ " & DeptNum & " 个部门]"
lbl(1) = lbl(0)
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -