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

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 = NothingExit FunctionerrHandlerr:
MsgBox err.Description + "：" + CStr(err.number), vbCritical, MsgBoxTitleEnd Function

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 FunctionerrHandlerr:
MsgBox err.Description + "：" + CStr(err.number), vbCritical, MsgBoxTitle
End Function

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 FunctionerrHandlerr:
MsgBox err.Description + "：" + CStr(err.number), vbCritical, MsgBoxTitle
End Function

哪裡用那麼多代碼啊？
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
用代碼太多很亂啊!

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

调试易

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

解决方案 »