请问VB里怎么将数据库表生成EXCEL文件?

[jhliuguiping]

请问VB里怎么将数据库表生成EXCEL文件? 在recordset记录集中生成吗?

[libingao]

Public Function vExporToExcel_ADO(strOpen As String, CnnStr As String, Optional Caption As String = "导出的 Excel 文件", Optional Companyname As String = "")
'***************************************************************************
'* 名称：vExporToExcel_ADO
'* 功能：通过 ADO 快速导出数据到EXCEL
'* 用法：vExporToExcel_ADO(sql查询字符串,ADO 连接字符串,导出文件名称,总公司名称)
'***************************************************************************
On Error GoTo errHandlerr

Dim Rs_Data As New ADODB.Recordset
Dim Irowcount As Integer
Dim Icolcount As Integer

Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlQuery As Excel.QueryTable

With Rs_Data
If .State = adStateOpen Then .Close
.ActiveConnection = CnnStr
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockReadOnly
.Source = strOpen
.Open

If .RecordCount < 1 Then
MsgBox "没有记录可供导出!", vbInformation, MsgBoxTitle
Exit Function
End If

Irowcount = .RecordCount '记录总数
Icolcount = .Fields.count '字段总数

End With

Set xlApp = CreateObject("Excel.Application")
Set xlBook = Nothing
Set xlSheet = Nothing
Set xlBook = xlApp.Workbooks().add
Set xlSheet = xlBook.Worksheets("sheet1")
xlApp.Visible = True

'添加查询语句，导入EXCEL数据
Set xlQuery = xlSheet.QueryTables.add(Rs_Data, xlSheet.Range("a1"))

With xlQuery
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True

.FieldNames = True '显示字段名
.Refresh

End With


With xlSheet
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.name = "黑体" '设标题为黑体字
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = False 'True '标题字体不加粗
.Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous '设表格边框样式

With .PageSetup '打印时的页眉页脚设置
.LeftHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10公司名称：" + Companyname '打印 左页眉
.CenterHeader = "&""楷体_GB2312,常规""" + Caption + "&""宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10打印日期：" + Format(Date, "YYYY-MM-DD") '打印 中页眉
.RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10打印时间：" + Format(Time, "HH:MM:SS ") '打印 右页眉
.LeftFooter = "&""楷体_GB2312,常规""&10制表人：" '打印 左页脚
.CenterFooter = "&""楷体_GB2312,常规""&10制表日期：" + Format(Date, "YYYY-MM-DD") '打印 中页脚
.RightFooter = "&""楷体_GB2312,常规""&10第 &P 页 共 &N 页 " '打印 右页脚
End With

End With

xlApp.Application.Visible = True
Set xlApp = Nothing '交还控制给Excel
Set xlBook = Nothing
Set xlSheet = Nothing

Exit Function

errHandlerr:
MsgBox err.Description + "：" + CStr(err.number), vbCritical, MsgBoxTitle

End Function

[libingao]

Public Function vExporToExcel_DAO(strOpen As String, TabAddress As String, Optional Caption As String = "导出的 Excel 文件", Optional Companyname As String = "", Optional DataPassWord As String = "")
'***************************************************************************
'* 名称：vExporToExcel_DAO
'* 功能：通过 DAO 快速导出数据到EXCEL
'* 用法：vExporToExcel_DAO(sql查询字符串,DAO 连接数据库路径和名称,导出文件名称,总公司名称,数据库密码)
'***************************************************************************
On Error GoTo errHandlerr

Dim OpenWs As Workspace
Dim OpenDB As Database
Dim RsData As Recordset

Dim Irowcount As Integer
Dim Icolcount As Integer

Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlQuery As Excel.QueryTable

Set OpenWs = DBEngine.Workspaces(0)
Set OpenDB = OpenWs.OpenDatabase(TabAddress, False, False, "MS Access;PWD=" + DataPassWord)
Set RsData = OpenDB.OpenRecordset(strOpen, dbOpenSnapshot)

With RsData

If .RecordCount < 1 Then
MsgBox "没有记录可供导出!", vbInformation, MsgBoxTitle
Exit Function
End If
.MoveLast
.MoveFirst
Irowcount = .RecordCount '记录总数
Icolcount = .Fields.count '字段总数

End With

Set xlApp = CreateObject("Excel.Application")
Set xlBook = Nothing
Set xlSheet = Nothing
Set xlBook = xlApp.Workbooks().add
Set xlSheet = xlBook.Worksheets("sheet1")
xlApp.Visible = True

'添加查询语句，导入EXCEL数据
Set xlQuery = xlSheet.QueryTables.add(RsData, xlSheet.Range("a1"))

With xlQuery
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True

.FieldNames = True '显示字段名
.Refresh

End With


With xlSheet
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.name = "黑体" '设标题为黑体字
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = False 'True '标题字体不加粗
.Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous '设表格边框样式

With .PageSetup '打印时的页眉页脚设置
.LeftHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10公司名称：" + Companyname '打印 左页眉
.CenterHeader = "&""楷体_GB2312,常规""" + Caption + "&""宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10打印日期：" + Format(Date, "YYYY-MM-DD") '打印 中页眉
.RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10打印时间：" + Format(Time, "HH:MM:SS ") '打印 右页眉
.LeftFooter = "&""楷体_GB2312,常规""&10制表人：" '打印 左页脚
.CenterFooter = "&""楷体_GB2312,常规""&10制表日期：" + Format(Date, "YYYY-MM-DD") '打印 中页脚
.RightFooter = "&""楷体_GB2312,常规""&10第 &P 页 共 &N 页 " '打印 右页脚
End With

End With

xlApp.Application.Visible = True
Set xlApp = Nothing '交还控制给Excel
Set xlBook = Nothing
Set xlSheet = Nothing
Exit Function

errHandlerr:
MsgBox err.Description + "：" + CStr(err.number), vbCritical, MsgBoxTitle
End Function

[libingao]

Public Function vExporToExcel_Recordset(Rst As Object, CnnStr As String, Optional Caption As String = "导出的 Excel 文件", Optional Companyname As String = "")
'****************************************************************************************
'* 名称：vExporToExcel_Recordset
'* 功能：通过 Recordset记录集（包含 ADO 和 DAO 记录集） 快速导出数据到 EXCEL
'* 用法：vExporToExcel_Recordset(Recordset记录集,空串,导出文件名称,总公司名称)
'****************************************************************************************
On Error GoTo errHandlerr

Dim Irowcount As Integer
Dim Icolcount As Integer

Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlQuery As Excel.QueryTable

With Rst

If .RecordCount < 1 Then
MsgBox "没有记录可供导出!", vbInformation, MsgBoxTitle
Exit Function
End If

Irowcount = .RecordCount '记录总数
Icolcount = .Fields.count '字段总数

End With

Set xlApp = CreateObject("Excel.Application")
Set xlBook = Nothing
Set xlSheet = Nothing
Set xlBook = xlApp.Workbooks().add
Set xlSheet = xlBook.Worksheets("sheet1")
xlApp.Visible = True

'添加查询语句，导入EXCEL数据
Set xlQuery = xlSheet.QueryTables.add(Rst, xlSheet.Range("a1"))

With xlQuery
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True

.FieldNames = True '显示字段名
.Refresh

End With


With xlSheet
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.name = "黑体" '设标题为黑体字
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = False 'True '标题字体不加粗
.Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous '设表格边框样式

With .PageSetup '打印时的页眉页脚设置
.LeftHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10公司名称：" + Companyname '打印 左页眉
.CenterHeader = "&""楷体_GB2312,常规""" + Caption + "&""宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10打印日期：" + Format(Date, "YYYY-MM-DD") '打印 中页眉
.RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10打印时间：" + Format(Time, "HH:MM:SS ") '打印 右页眉
.LeftFooter = "&""楷体_GB2312,常规""&10制表人：" '打印 左页脚
.CenterFooter = "&""楷体_GB2312,常规""&10制表日期：" + Format(Date, "YYYY-MM-DD") '打印 中页脚
.RightFooter = "&""楷体_GB2312,常规""&10第 &P 页 共 &N 页 " '打印 右页脚
End With

End With

xlApp.Application.Visible = True
Set xlApp = Nothing '交还控制给Excel
Set xlBook = Nothing
Set xlSheet = Nothing

Exit Function

errHandlerr:
MsgBox err.Description + "：" + CStr(err.number), vbCritical, MsgBoxTitle
End Function

[gamemx]

up

[Andy__Huang]

哪裡用那麼多代碼啊？
Private Sub Command3_Click()
Dim strFileName As String
Dim objFileSystem As Object
Dim objExcelText As Object
Dim strExcel As String
strConn = "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=develop; password=12345;Data Source=ServerName"
pubConn.Open strConn

rsTable.CursorLocation = adUseClient
strSQL = "select * from Table1 left join Table2 on..."
rsTable.Open strSQL, pubConn, adOpenDynamic, adLockOptimistic
Set DataGrid1.DataSource = rsTable
strExcel = rsTable.GetString

cmDialog.CancelError = False
cmDialog.FileName = "FileExcel"
cmDialog.DialogTitle = "Save Export File"
cmDialog.Filter = "Excel (*.xls)|*.xls|文本文件(*.DBF)|*.DBF|檔案文件(*.doc)|*.doc|所有文件(*.*)|*.*"
cmDialog.DefaultExt = "*.xls"
cmDialog.ShowSave

strFileName = cmDialog.FileName

Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Set objExcelText = objFileSystem.createtextfile(strFileName, True)
objExcelText.writeline (strExcel)

objExcelText.Close
Set objFileSystem = Nothing

End Sub


用代碼太多很亂啊!

[flyingZFX]

如果导出到一新excel文件或新工作表：
cn.Execute "select * into [Excel 8.0;DATABASE=excel文件名].表名 from 源表名"
'导出到已存在文件表：
cn.Execute "Insert into [Excel 8.0;DATABASE=excel文件名].表名 select * from 源表名"