📄 frmoutput.frm
字号:
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{BDC217C8-ED16-11CD-956C-0000C04E4C0A}#1.1#0"; "TABCTL32.OCX"
Begin VB.Form frmOutput
BorderStyle = 3 'Fixed Dialog
Caption = "输出"
ClientHeight = 3945
ClientLeft = 45
ClientTop = 330
ClientWidth = 6270
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "frmOutput.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 3945
ScaleWidth = 6270
ShowInTaskbar = 0 'False
StartUpPosition = 2 'CenterScreen
Begin TabDlg.SSTab stbOut
Height = 3375
Left = 60
TabIndex = 2
Top = 60
Width = 6135
_ExtentX = 10821
_ExtentY = 5953
_Version = 393216
Style = 1
Tabs = 1
TabsPerRow = 1
TabHeight = 520
TabCaption(0) = "Excel 输出"
TabPicture(0) = "frmOutput.frx":000C
Tab(0).ControlEnabled= -1 'True
Tab(0).Control(0)= "lblCount"
Tab(0).Control(0).Enabled= 0 'False
Tab(0).Control(1)= "lblInfo"
Tab(0).Control(1).Enabled= 0 'False
Tab(0).Control(2)= "Line(1)"
Tab(0).Control(2).Enabled= 0 'False
Tab(0).Control(3)= "Line(0)"
Tab(0).Control(3).Enabled= 0 'False
Tab(0).Control(4)= "proBar"
Tab(0).Control(4).Enabled= 0 'False
Tab(0).Control(5)= "cmdselect(1)"
Tab(0).Control(5).Enabled= 0 'False
Tab(0).Control(6)= "cmdselect(0)"
Tab(0).Control(6).Enabled= 0 'False
Tab(0).Control(7)= "litName"
Tab(0).Control(7).Enabled= 0 'False
Tab(0).ControlCount= 8
Begin VB.ListBox litName
Height = 2790
Left = 120
Style = 1 'Checkbox
TabIndex = 5
Top = 420
Width = 2175
End
Begin VB.CommandButton cmdselect
BackColor = &H00C0FFC0&
Caption = "全部选中"
Height = 350
Index = 0
Left = 3600
TabIndex = 4
Top = 1980
Width = 1095
End
Begin VB.CommandButton cmdselect
BackColor = &H00C0FFC0&
Caption = "都不选"
Height = 350
Index = 1
Left = 4800
TabIndex = 3
Top = 1980
Width = 1095
End
Begin MSComctlLib.ProgressBar proBar
Height = 255
Left = 2520
TabIndex = 8
Top = 2880
Visible = 0 'False
Width = 3375
_ExtentX = 5953
_ExtentY = 450
_Version = 393216
Appearance = 1
End
Begin VB.Line Line
BorderColor = &H00808080&
Index = 0
X1 = 2520
X2 = 5880
Y1 = 2400
Y2 = 2400
End
Begin VB.Line Line
BorderColor = &H00FFFFFF&
Index = 1
X1 = 2520
X2 = 5880
Y1 = 2415
Y2 = 2415
End
Begin VB.Label lblInfo
BackStyle = 0 'Transparent
Caption = " 将员工资料输出到Excel文件中,默认输出为[员工编号,姓名,隶属部门],可选择输出其它的内容,如果系统未安装Excel,此功能将不可用! "
Height = 735
Left = 2520
TabIndex = 7
Top = 720
Width = 3330
End
Begin VB.Label lblCount
AutoSize = -1 'True
BackStyle = 0 'Transparent
Height = 180
Left = 2520
TabIndex = 6
Top = 2580
Width = 90
End
End
Begin VB.CommandButton cmdCancel
BackColor = &H00C0C0FF&
Cancel = -1 'True
Caption = "取消(&C)"
Height = 350
Left = 5100
TabIndex = 1
Top = 3540
Width = 1095
End
Begin VB.CommandButton cmdOut
BackColor = &H00C0E0FF&
Caption = "输出(&O)"
Default = -1 'True
Height = 350
Left = 3900
TabIndex = 0
Top = 3540
Width = 1095
End
End
Attribute VB_Name = "frmOutput"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim blnTF As Boolean
Private Sub cmdCancel_Click()
If blnTF = True Then
blnTF = False
Else
Unload Me
End If
End Sub
Private Sub cmdOut_Click() 'Excel输出
Dim intSave As Integer
Dim strSelect As String
On Error GoTo errNext
With adoMainLink
If .State = adStateOpen Then .Close
cmdOut.Enabled = False
With frmInfo.cdgMain
.DialogTitle = "另存为Excel文档"
.Filter = "Excel文件(*.xls)|*.xls|"
.ShowSave
If Len(Trim(.FileName)) = 0 Then GoTo ExitClear
End With
strSelect = "员工编号,隶属部门,姓名"
For intCount = 1 To litName.ListCount
If litName.Selected(intCount - 1) = True Then
strSelect = IIf(litName.List(intCount - 1) Like "*(*)*", strSelect & ",[" & litName.List(intCount - 1) & "]", strSelect & "," & litName.List(intCount - 1))
End If
Next
Dim objExcel As Object
lblCount.Caption = " 创建Excel对象..."
blnTF = True
Set objExcel = CreateObject("Excel.Sheet.8")
.Open "select " & strSelect & " from v员工详细资料 order by 隶属部门,员工编号", adoConn, adOpenDynamic, adLockPessimistic, adCmdText
If .EOF = False Then
proBar.Value = 0
proBar.Visible = True
lblCount.Caption = " 将字段名添加到Excel表格中..."
For intCount = 0 To .Fields.Count - 1
objExcel.Worksheets(1).cells(1, intCount + 1).Value = adoMainLink(intCount).Name
Next
.MoveLast
proBar.Max = .RecordCount
.MoveFirst
intCount = 2
Do Until .EOF ' 在记录中循环
lblCount.Caption = "写入记录中: " & proBar.Value & "/" & proBar.Max
For intSave = 0 To .Fields.Count - 1 ' 加每个字段的值加到工作表中
objExcel.Worksheets(1).cells(intCount, intSave + 1).Value = .Fields(intSave)
Next
DoEvents
If blnTF = False Then
If MsgBox("确认要中止Excel输出吗?", vbOKCancel) = vbOK Then
objExcel.Application.Quit
GoTo ExitClear
End If
blnTF = True
End If
.MoveNext
intCount = intCount + 1
proBar.Value = proBar.Value + 1
Loop
lblCount.Caption = " 保存文件..." ' 保存工作表
objExcel.SaveAs frmInfo.cdgMain.FileName
objExcel.Application.Quit
Else
MsgBox "未找到记录,保存失败!", vbCritical, App.Title
objExcel.Application.Quit
GoTo ExitClear
End If
End With
GoTo ExitClear
MsgBox "文件输出成功!", vbInformation, App.Title
frmInfo.cdgMain.FileName = ""
errNext:
MsgBox Err.Description, vbOKOnly, App.Title
ExitClear:
blnTF = False
cmdOut.Enabled = True
lblCount.Caption = ""
proBar.Visible = False
End Sub
Private Sub cmdselect_Click(Index As Integer)
Dim blnYN As Boolean
litName.Visible = False
blnYN = Index
For intCount = 1 To litName.ListCount
If litName.Selected(intCount - 1) = blnYN Then litName.Selected(intCount - 1) = Not blnYN
Next
litName.ListIndex = 0
litName.Visible = True
End Sub
Private Sub Form_Load()
blnTF = False
frmInfo.Enabled = False
On Error Resume Next
With adoMainLink
If .State = adStateOpen Then .Close
.Open "select * from v员工详细资料", adoConn, adOpenDynamic, adLockPessimistic, adCmdText
For intCount = 3 To .Fields.Count
litName.AddItem .Fields(intCount).Name, intCount - 3
Next
End With
End Sub
Private Sub Form_Unload(Cancel As Integer)
frmInfo.Enabled = True
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -