vb数据库编程_DAO数据导出到Excel表格和Html文件实例

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form CopyToExcel
BorderStyle = 1 'Fixed Single
Caption = "DAO数据导出到Excel表格和Html文件实例"
ClientHeight = 4995
ClientLeft = 45
ClientTop = 435
ClientWidth = 5190
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 4995
ScaleWidth = 5190
StartUpPosition = 3 '窗口缺省
Begin VB.PictureBox Picture1
Height = 255
Left = 1440
ScaleHeight = 195
ScaleWidth = 3315
TabIndex = 9
Top = 4080
Width = 3375
End
Begin VB.Data Data1
Caption = "Data1"
Connect = "Access 2000;"
DatabaseName = ""
DefaultCursorType= 0 '缺省游标
DefaultType = 2 '使用 ODBC
Exclusive = 0 'False
Height = 375
Left = 4080
Options = 0
ReadOnly = 0 'False
RecordsetType = 1 'Dynaset
RecordSource = ""
Top = 240
Visible = 0 'False
Width = 1140
End
Begin VB.CommandButton cmdCopyToHtml
Caption = "将数据导出为Html文件"
Height = 495
Left = 3600
TabIndex = 8
Top = 4440
Width = 1215
End
Begin VB.CommandButton cmdCopyToExcel
Caption = "将数据导出为Excel表格"
Height = 495
Left = 2280
TabIndex = 7
Top = 4440
Width = 1215
End
Begin MSComDlg.CommonDialog CommonDialog1
Left = 360
Top = 2040
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.ListBox List1
Height = 2760
Left = 1440
TabIndex = 6
Top = 1200
Width = 3375
End
Begin VB.CommandButton cmdOpen
Caption = "打开"
Height = 300
Left = 4080
TabIndex = 4
Top = 720
Width = 735
End
Begin VB.TextBox txtDBName
Height = 300
Left = 1440
Locked = -1 'True
TabIndex = 3
Top = 720
Width = 2535
End
Begin VB.ComboBox cmbDatabaseType
Height = 300
Left = 1440
Style = 2 'Dropdown List
TabIndex = 2
Top = 240
Width = 2535
End
Begin VB.Label Label3
Caption = "表："
Height = 255
Left = 240
TabIndex = 5
Top = 1200
Width = 1095
End
Begin VB.Label Label2
Caption = "数据库类型："
Height = 255
Left = 240
TabIndex = 1
Top = 240
Width = 1095
End
Begin VB.Label Label1
Caption = "数据库："
Height = 255
Left = 240
TabIndex = 0
Top = 720
Width = 1095
End
End
Attribute VB_Name = "CopyToExcel"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Type ExlCell
Row As Long
Col As Long
End Type

'"将数据导出为Excel表格"按钮单击事件响应代码
Private Sub cmdCopyToExcel_Click()
'指定打开数据库类型
If cmbDatabaseType.Text = "Access;" Then
Data1.Connect = ";"
Else
Data1.Connect = cmbDatabaseType.Text
End If
'使用Data控件打开数据库
Data1.DatabaseName = txtDBName.Text
Data1.RecordSource = List1.List(List1.ListIndex)
Data1.Refresh

Call ToExcel(Data1.Recordset, "")

End Sub

'"将数据导出为Html文件"按钮单击事件响应代码
Private Sub cmdCopyToHtml_Click()
'用户指定Html文件名
CommonDialog1.InitDir = App.Path
CommonDialog1.Filter = "Html文件(*.htm)|*.htm"
CommonDialog1.ShowSave
If CommonDialog1.FileName = "" Then Exit Sub
'指定打开数据库类型
If cmbDatabaseType.Text = "Access;" Then
Data1.Connect = ";"
Else
Data1.Connect = cmbDatabaseType.Text
End If
'使用Data控件打开数据库
Data1.DatabaseName = txtDBName.Text
Data1.RecordSource = List1.List(List1.ListIndex)
Data1.Refresh

ToHTML Data1.Recordset, "将DAO数据导出到Html文件实例", CommonDialog1.FileName
End Sub

'"打开"按钮单击事件响应代码
Private Sub cmdOpen_Click()
'从数据库类型判断数据库文件扩展名
Select Case cmbDatabaseType.Text
Case "Access 2000;", "Access;"
CommonDialog1.Filter = "Access数据库(*.mdb)|*.mdb"
Case "dBASE III;", "dBASE IV;", "dBASE 5.0;", "FoxPro 2.0;", "FoxPro 2.5;", "FoxPro 2.6;", "FoxPro 3.0;"
CommonDialog1.Filter = "dbf数据库(*.dbf)|*.dbf"
Case "Paradox 3.x;", "Paradox 4.x;", "Paradox 5.x;"
CommonDialog1.Filter = "Paradox数据库|*.*"
Case "Excel 3.0;", "Excel 4.0;", "Excel 5.0;", "Excel 8.0;"
CommonDialog1.Filter = "Excel表格(*.xls)|*.xls"
Case "Lotus WK1;"
CommonDialog1.Filter = "Lotus 1-2-3 WK1表格(*.wk1)|*.wk1"
Case "Lotus WK3;"
CommonDialog1.Filter = "Lotus 1-2-3 WK3表格(*.wk3)|*.wk3"
Case "Lotus WK4;"
CommonDialog1.Filter = "Lotus 1-2-3 WK4表格(*.mdb)|*.mdb"
Case "Text;"
CommonDialog1.Filter = "文本文件(*.txt)|*.txt"
End Select
CommonDialog1.InitDir = App.Path
CommonDialog1.ShowOpen
Dim strDBName As String, lSeek As Long
strDBName = CommonDialog1.FileName
'用户指定了数据库
If strDBName <> "" Then
'根据数据库类型不同指定变化其数据库名
Select Case cmbDatabaseType.Text
Case "dBASE III;", "dBASE IV;", "dBASE 5.0;", "FoxPro 2.0;", "FoxPro 2.5;", "FoxPro 2.6;", "FoxPro 3.0;"
lSeek = InStr(1, strDBName, "\")
txtDBName.Text = Mid(strDBName, 1, lSeek)
Case "Paradox 3.x;", "Paradox 4.x;", "Paradox 5.x;"
lSeek = InStr(1, strDBName, "\")
txtDBName.Text = Mid(strDBName, 1, lSeek)
Case Else
txtDBName.Text = strDBName
End Select
'获取当前数据库中所有数据表
Call GetAllTables
End If

End Sub

'获取当前数据库中所有数据表
Private Sub GetAllTables()

Dim wrkJet As Workspace
Dim DatabaseX As Database
'打开Workspace
Set wrkJet = CreateWorkspace("NewJetWorkspace", "admin", "", dbUseJet)
'根据数据库类型不同，以不同形式打开数据库
If cmbDatabaseType.Text = "Access;" Then
Set DatabaseX = wrkJet.OpenDatabase(txtDBName, , , ";")
Else
Set DatabaseX = wrkJet.OpenDatabase(txtDBName, , , cmbDatabaseType)
End If
List1.Clear
'将数据表名添加到List1中
For i = 0 To DatabaseX.TableDefs.Count - 1
'排除数据表中的系统表
If Len(DatabaseX.TableDefs(i).Name) <= 4 Then
List1.AddItem DatabaseX.TableDefs(i).Name
Else
If UCase(Left(DatabaseX.TableDefs(i).Name, 4)) <> "MSYS" Then
List1.AddItem DatabaseX.TableDefs(i).Name
End If
End If
Next i

'释放资源
DatabaseX.Close
Set DatabaseX = Nothing
wrkJet.Close
Set wrkJet = Nothing

End Sub

Private Sub Form_Load()
'数据库类型
With cmbDatabaseType
.AddItem "Access 2000;"
.AddItem "Access;"
.AddItem "dBASE III;"
.AddItem "dBASE IV;"
.AddItem "dBASE 5.0;"
.AddItem "Paradox 3.x;"
.AddItem "Paradox 4.x;"
.AddItem "Paradox 5.x;"
.AddItem "FoxPro 2.0;"
.AddItem "FoxPro 2.5;"
.AddItem "FoxPro 2.6;"
.AddItem "FoxPro 3.0;"
.AddItem "Excel 3.0;"
.AddItem "Excel 4.0;"
.AddItem "Excel 5.0;"
.AddItem "Excel 8.0;"
.AddItem "Lotus WK1;"
.AddItem "Lotus WK3;"
.AddItem "Lotus WK4;"
.AddItem "Text;"
End With
End Sub

Exit_UpdateProgress:

On Error GoTo 0
Exit Sub

Err_UpdateProgress:

Select Case Err
Case 0
Resume Next
Case Else
MsgBox \"Error: \" & Err.Number & vbNewLine & Err.Description, vbInformation, \"错误\"
Resume Exit_UpdateProgress
End Select

End Sub

\'将Recordset中的数据以Html格式写入文件
Private Sub ToHTML(SN As Recordset, strCaption As String, FileName As String)

Open FileName For Output As #1
\'Html的文件头和页面信息
Print #1, \"<HTML>\"
Print #1, \"<HEAD>\"
Print #1, \"<meta http-equiv=\"\"Content-Type\"\" content=\"\"text/html; charset=gb2312\"\">\"
Print #1, \"<meta http-equiv=\"\"Content-Language\"\" content=\"\" zh - cn \"\" > \"
Print #1, \"<meta name=\"\"GENERATOR\"\" content = \"\" Visual Basic Access to Html \"\" > \"
\'Html标题
Print #1, \"<TITLE>\" & strCaption & \"</TITLE>\"
Print #1, \"<STYLE>\"
Print #1, \"<!--\"
Print #1, \"BODY,td {\"
Print #1, \"font-family:\"\"宋体,Arial Black\"\";\"
Print #1, \"font-size:9pt;\"
Print #1, \"line-height:16px;\"
Print #1, \"}\"
Print #1, \"-->\"
Print #1, \"</STYLE>\"
Print #1, \"</Head>\"
\'数据开始
Print #1, \"<Body>\"
Print #1, \"<Table border=\"\" 1\"\">\"

\'自动根据字段数量确定列宽
If SN.Fields.Count > 1 Then
lwidth = 100 / SN.Fields.Count - 1
Else
lwidth = 100 / SN.Fields.Count
End If

\'保证列宽大小
If lwidth < 10 Then
lwidth = 10
End If

\'若要设置固定列宽，将下面一行的注释符号去除即可
lwidth = 1000

\'先输出表头
Print #1, \"<TR>\"
For i = 0 To SN.Fields.Count - 1
Print #1, \"<td width=\"\"\" & Str(lwidth) & \"\"\" bgcolor = \"\"#B1CACF\"\" > \"
Print #1, SN.Fields(i).Name
Print #1, \"</td>\"
Next i
Print #1, \"</TR>\"
\'开始输出数据
Do Until SN.EOF
\'实现黑白交替效果
If j Mod 2 = 1 Then
Print #1, \"<TR bgcolor = \"\"#EFEFEF\"\">\"
Else
Print #1, \"<TR bgcolor = \"\"#FFFFFF\"\">\"
End If
\'输出每个字段数据
For i = 0 To SN.Fields.Count - 1
Print #1, \"<td width=\"\"\" & Str(lwidth) & \"\"\"> \"
Print #1, SN.Fields(i).Value
Print #1, \"</td>\"
Next i
Print #1, \"</TR>\"
SN.MoveNext
UpdateProgress Picture1, j / SN.RecordCount * 100
j = j + 1

Loop
\'Html文件结束
Print #1, \"</Table>\"
Print #1, \"</Body>\"
Print #1, \"</HTML>\"
Close #1

End Sub

\'复制Recordset中数据到Excel表格Worksheet
Private Sub CopyRecords(RST As Recordset, WS As Worksheet, StartingCell As ExlCell)

Dim SomeArray() As Variant
Dim Row As Long
Dim Col As Long
Dim Fd As Field

On Error GoTo Err_CopyRecords

\'检测Recordset中是否没有数据
If RST.EOF And RST.BOF Then Exit Sub
RST.MoveLast
ReDim SomeArray(RST.RecordCount + 1, RST.Fields.Count)

\'拷贝表头到数组
Col = 0
For Each Fd In RST.Fields
SomeArray(0, Col) = Fd.Name
Col = Col + 1
Next

\'拷贝Recordset到数组
RST.MoveFirst
Recs = RST.RecordCount
Counter = 0
For Row = 1 To RST.RecordCount - 1
Counter = Counter + 1
If Counter <= Recs Then i = (Counter / Recs) * 100
UpdateProgress Picture1, i
For Col = 0 To RST.Fields.Count - 1
SomeArray(Row, Col) = RST.Fields(Col).Value
If IsNull(SomeArray(Row, Col)) Then _
SomeArray(Row, Col) = \"\"
Next
RST.MoveNext
Next

\'将数组填充到Excel WorkSheet
\'Range应该和数组拥有同样的行数和列数
WS.Range(WS.Cells(StartingCell.Row, StartingCell.Col), _
WS.Cells(StartingCell.Row + RST.RecordCount + 1, _
StartingCell.Col + RST.Fields.Count)).Value = SomeArray

Exit_CopyRecords:
On Error GoTo 0
Exit Sub

Err_CopyRecords:
Select Case Err
Case 0
Resume Next
Case Else
MsgBox \"错误: \" & Err.Number & vbNewLine & Err.Description, vbInformation, \"错误\"
Resume Exit_CopyRecords
End Select

End Sub

\'将Recordset数据转换到Excel中
Private Sub ToExcel(SN As Recordset, strCaption As String)

Dim oExcel As Object
\'OLE自动化对象
Dim objExlSht As Object
Dim stCell As ExlCell

On Error GoTo Err_ToExcel

DoEvents
On Error Resume Next
Set oExcel = GetObject(, \"Excel.Application\")
\'若Excel没有启动
If Err = 429 Then
Err = 0
Set oExcel = CreateObject(\"Excel.Application\")
\'无法创建Excel对象
If Err = 429 Then
MsgBox Err & \": \" & Error, vbExclamation + vbOKOnly
Exit Sub
End If
End If
oExcel.Workbooks.Add
oExcel.Worksheets(\"sheet1\").Name = strCaption
Set objExlSht = oExcel.ActiveWorkbook.Sheets(1)
stCell.Row = 1
stCell.Col = 1

\'填充Excel表格
CopyRecords SN, objExlSht, stCell
\'将控制权交给用户
oExcel.Visible = True
oExcel.Interactive = True

\'测试对象是否活动并释放对象
If Not (objExlSht Is Nothing) Then
Set objExlSht = Nothing
End If
If Not (oExcel Is Nothing) Then
Set oExcel = Nothing
End If
If Not (SN Is Nothing) Then
Set SN = Nothing
End If
UpdateProgress Picture1, 100

Exit_ToExcel:
On Error GoTo 0
Exit Sub

Err_ToExcel:
Select Case Err
Case 0
Resume Next
Case Else
MsgBox \"错误: \" & Err.Number & vbNewLine & Err.Description, vbInformation, \"错误\"
Resume Exit_ToExcel
End Select

End Sub