vb数据库编程_ADO数据导出到Excel表格实例

bsmtlxw

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form CopyToExcel
BorderStyle = 1 'Fixed Single
Caption = "ADO数据导出到Excel表格实例"
ClientHeight = 4320
ClientLeft = 45
ClientTop = 330
ClientWidth = 5400
BeginProperty Font
Name = "Arial"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "CopyToExcel.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 4320
ScaleWidth = 5400
StartUpPosition = 2 '屏幕中心
Begin VB.Frame Frame1
Caption = "单击需要导出到Excel表格的数据表 "
BeginProperty Font
Name = "Arial"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = -1 'True
Strikethrough = 0 'False
EndProperty
ForeColor = &H00C00000&
Height = 4095
Left = 120
TabIndex = 0
Top = 120
Visible = 0 'False
Width = 5175
Begin VB.CommandButton cmdCopyToExcel
Caption = "将数据导出为Excel表格"
Height = 495
Left = 2520
TabIndex = 5
Top = 3480
Width = 1215
End
Begin VB.CommandButton cmdCopyToHtml
Caption = "将数据导出为Html文件"
Height = 495
Left = 3840
TabIndex = 4
Top = 3480
Width = 1215
End
Begin VB.CommandButton Command1
Caption = "重新选择数据库"
Height = 495
Left = 840
TabIndex = 3
Top = 3480
Width = 1575
End
Begin VB.PictureBox Picture1
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 120
ScaleHeight = 195
ScaleWidth = 4875
TabIndex = 2
Top = 3120
Width = 4935
End
Begin VB.ListBox List1
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 2790
Left = 120
TabIndex = 1
Top = 240
Width = 4935
End
End
Begin MSComDlg.CommonDialog CommonDialog1
Left = 120
Top = 120
_ExtentX = 847
_ExtentY = 847
_Version = 393216
CancelError = -1 'True
DialogTitle = "Select Database File"
FileName = "*.mdb"
Filter = "Access Files (*.mdb)"
FilterIndex = 1
FontName = "Arial"
InitDir = "."
End
End
Attribute VB_Name = "CopyToExcel"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim adoConn As adodb.Connection
Dim RS As adodb.Recordset
Dim strCaption As String
Dim SN As String
Dim i As Single
Dim Recs As Integer
Dim Counter As Integer
Dim BarString As String
Dim MdbFile As String
Dim Junk As String
Dim strAdoConn As String

Private Type ExlCell
Row As Long
Col As Long
End Type

bsmtlxw

\'\"将数据导出为Excel表格\"按钮单击事件响应代码
Private Sub cmdCopyToExcel_Click()
On Error GoTo Err_List1_Click

Screen.MousePointer = vbHourglass
Junk = List1.Text
Set RS = New adodb.Recordset
RS.Open Junk, adoConn, adOpenStatic, adLockReadOnly, adCmdTable
ToExcel RS, App.Path & \"\\wk.xls\"

Exit_List1_Click:
Screen.MousePointer = vbDefault
On Error GoTo 0
Exit Sub

Err_List1_Click:
Select Case Err
Case 0
Resume Next
Case Else
MsgBox \"错误: \" & Err.Number & vbNewLine & Err.Description, vbInformation, \"错误\"
Resume Exit_List1_Click
End Select
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

Junk = List1.Text
Set RS = New adodb.Recordset
RS.Open Junk, adoConn, adOpenStatic, adLockReadOnly, adCmdTable

ToHTML RS, \"将ADO数据导出到Html文件实例\", CommonDialog1.FileName
End Sub

Private Sub Form_Load()
LoadForm
Exit_Form_Load:
On Error GoTo 0
Exit Sub
Err_Form_Load:
Select Case Err
Case 0
Resume Next
Case Else
MsgBox \"错误: \" & Err.Number & vbNewLine & Err.Description, vbInformation, \"错误\"
Resume Exit_Form_Load
End Select

End Sub
Private Sub Form_Unload(Cancel As Integer)

On Error GoTo Err_Form_Unload
If Not (adoConn Is Nothing) Then
adoConn.Close
Set adoConn = Nothing
End If

Exit_Form_Unload:
On Error GoTo 0
Exit Sub

Err_Form_Unload:
Select Case Err
Case 0, 91, 3704
Resume Next
Case Else
MsgBox \"错误: \" & Err.Number & vbNewLine & Err.Description, vbInformation, \"错误\"
Resume Exit_Form_Unload
End Select

End Sub

\'\"重新选择数据库\"按钮单击事件响应代码
Private Sub Command1_Click()

On Error GoTo Err_Command1_Click
UpdateProgress Picture1, 0
\'隐藏Frame1
Frame1.Visible = False
\'清空List1
List1.Clear
\'从新运行填充List1的程序
LoadForm

Exit_Command1_Click:
On Error GoTo 0
Exit Sub

Err_Command1_Click:
Select Case Err
Case 0
Resume Next
Case Else
Frame1.Visible = True
MsgBox \"错误: \" & Err.Number & vbNewLine & Err.Description, vbInformation, \"错误\"
Resume Exit_Command1_Click
End Select

End Sub

\'更新进度条的子程序
Sub UpdateProgress(PB As Control, ByVal Percent)
\'本实例使用一个PictureBox控件模拟滚动条效果
\'百分比
Dim Num As String

On Error GoTo Err_UpdateProgress

If Not PB.AutoRedraw Then
PB.AutoRedraw = -1
End If
\'清空PictureBox
PB.Cls
PB.ScaleWidth = 100
\'xor画刷模式
PB.DrawMode = 10
Num = BarString & Format$(Percent, \"###\") + \"%\"
PB.CurrentX = 50 - PB.TextWidth(Num) / 2
PB.CurrentY = (PB.ScaleHeight - PB.TextHeight(Num)) / 2
\'显示百分比
PB.Print Num
PB.Line (0, 0)-(Percent, PB.ScaleHeight), , BF
\'刷新
PB.Refresh

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中数据到Excel表格Worksheet
Private Sub CopyRecords(RST As adodb.Recordset, WS As Worksheet, StartingCell As ExlCell)

Dim SomeArray() As Variant
Dim Row As Long
Dim Col As Long
Dim Fd As adodb.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 adodb.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

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

SN.MoveLast
SN.MoveFirst
Dim lwidth As Long, i, j
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

Private Sub LoadForm()

On Error GoTo Err_LoadForm

Picture1.Visible = True
Frame1.Caption = \"单击需要导出到Excel表格的数据表\"

GoTo TECHNIQUE_2
\'这里有两种方法
\'对于Access 2000使用Technique 1
\'对于ODBC数据源使用Technique 2
\'使用哪一种方法根据具体需要

TECHNIQUE_1:
Picture1.ForeColor = RGB(0, 0, 255)
\'打开Open对话框
CommonDialog1.Filter = \"Access Files (*.mdb)\"
CommonDialog1.FilterIndex = 0
CommonDialog1.FileName = \"*.mdb\"
CommonDialog1.ShowOpen
MdbFile = (CommonDialog1.FileName)
\'设置Access数据库连接
Set adoConn = New adodb.Connection
adoConn.ConnectionString = \"DRIVER={Microsoft Access Driver (*.mdb)};DBQ=\" & MdbFile \'App.Path & \"\\Examples.mdb\"
GoTo OPENTHEDATABASE

TECHNIQUE_2:
strAdoConn = BuildAdoConnection(\"\")
\'设置数据库连接属性
Set adoConn = New adodb.Connection
adoConn.ConnectionString = strAdoConn

OPENTHEDATABASE:
adoConn.Open
\'获取数据库中所有表格的名字
Set RS = adoConn.OpenSchema(adSchemaTables)
Do Until RS.EOF
\' 确定获取的表不是系统表或者视图
If RS.Fields(\"TABLE_TYPE\") = \"TABLE\" Then
If LCase$(Left$(RS.Fields(\"TABLE_NAME\"), 4)) = \"usys\" Then
\'系统表,排除
DoEvents
Else
List1.AddItem RS.Fields(\"TABLE_NAME\")
End If
End If
RS.MoveNext
Loop
\'关闭对象
If Not (RS Is Nothing) Then
RS.Close
Set RS = Nothing
End If
Frame1.Visible = True

Exit_LoadForm:
On Error GoTo 0
Exit Sub

Err_LoadForm:

Select Case Err
Case 0, 91
Resume Next
Case 32755, -2147467259, 3704
Frame1.Visible = True
Picture1.Visible = False
Frame1.Caption = \"没有选择数据库\"
Resume Exit_LoadForm
Case Else
MsgBox \"错误: \" & Err.Number & vbNewLine & Err.Description, vbInformation, \"错误\"
Resume Exit_LoadForm
End Select

End Sub
Private Function BuildAdoConnection(ByVal ConnectionString As String) As String

\'显示数据链接属性对话框(ADO DB Designer)
Dim dlViewConnection As MSDASC.DataLinks

On Error GoTo Err_BuildAdoConnection

Set adoConn = New adodb.Connection
If Not (Trim$(ConnectionString) = \"\") Then
Set adoConn = New adodb.Connection
adoConn.ConnectionString = ConnectionString
Set dlViewConnection = New MSDASC.DataLinks
dlViewConnection.hWnd = Me.hWnd
If dlViewConnection.PromptEdit(adoConn) Then
BuildAdoConnection = adoConn.ConnectionString
Else
BuildAdoConnection = ConnectionString
End If
Set dlViewConnection = Nothing
Set adoConn = Nothing
Else
Set dlViewConnection = New MSDASC.DataLinks
dlViewConnection.hWnd = Me.hWnd
Set adoConn = dlViewConnection.PromptNew
BuildAdoConnection = adoConn.ConnectionString
Set dlViewConnection = Nothing
Set adoConn = Nothing
End If

Exit_BuildAdoConnection:

On Error Resume Next
If Not (adoConn Is Nothing) Then
Set adoConn = Nothing
End If
If Not (dlViewConnection Is Nothing) Then
Set dlViewConnection = Nothing
End If
On Error GoTo 0
Exit Function

Err_BuildAdoConnection:

Select Case Err
Case 0
Resume Next
Case -2147217805
adoConn.ConnectionString = \"\"
Resume
Case 91
Resume Exit_BuildAdoConnection
Case Else
MsgBox \"错误: \" & Err.Number & vbNewLine & Err.Description, vbInformation, \"错误\"
Resume Exit_BuildAdoConnection
End Select

End Function

[upload=rar]viewFile.asp?ID=28[/upload]

xuliang987

学习中