Excel导入导出系列-借用Excel的QueryTables.Add方法导出数据

时　间:2014-02-18 08:54:57
作　者:金宇   ID：43  城市：江阴
摘　要:Excel的QueryTables.Add方法导出数据
正　文:

点击下载此附件

'===============================================================================
'函数名称： ExportToExcelQueryTables
'功能描述： 将SQL语句创建的记录集对象中的内容复制到Excel工作表
'输入参数： WorkbookName 必需的，工作簿名称
'           strSQL       必需的，不能包含具有 OLE 对象的字段，否则该方法无效。
'返回参数： 无
'使用说明： ExportToExcelQueryTables("公司资料","select * from 表名称或者查询名称")
'作    者： 金宇
'创建日期： 2013-11-1
'===============================================================================
Function ExportToExcelQueryTables(ByVal WorkbookName As String, ByVal strSQL As String)
On Error GoTo Err_ExportToExcel
    Dim objExcel As Object
    Dim objBook  As Object
    Dim objSheet As Object
    Dim objRange As Object
    Dim objExcelQuery As Object
    Dim rst      As Object
    Dim cnn      As Object
    Dim strFileName As String
    Dim strExtName As String
    
    Dim lngRow As Long
    Dim lngColumn As Long
    Dim FirstRange As String

  

    If Dir(WorkbookName) <> "" Then Kill WorkbookName
    '根据当前版本取得对应的文件扩展名
    strExtName = ".xls"
    If Val(Application.Version) > 11 Then strExtName = ".xlsx"
    '取得另存为文件名
    With Application.FileDialog(2) 'msoFileDialogSaveAs
        .InitialFileName = WorkbookName & strExtName
        If Not .Show Then Exit Function
        strFileName = .SelectedItems(1)
        If Not strFileName Like "*" & strExtName Then
            strFileName = strFileName & strExtName
        End If
        If Len(Dir(strFileName)) > 0 Then Kill strFileName
    End With

    DoCmd.Hourglass True

    'ADO方式
    Set rst = CreateObject("adodb.recordset")
    Set cnn = CurrentProject.Connection
    'CursorLocation = 3 这段代码必须加否则会出错，
    '如果不加会在objSheet.QueryTables.Add那里会出现 "无效的过程调用或参数"
    rst.CursorLocation = 3
    rst.Open strSQL, cnn, 1, 1

    Set objExcel = CreateObject("Excel.Application")
    objExcel.Visible = False
    Set objBook = objExcel.Workbooks.Add
    Set objSheet = objBook.Worksheets.Add
    'Set objSheet = objBook.Worksheets("Sheet1")
    objSheet.Name = WorkbookName '工作表名称
    objSheet.Select
    Set objExcelQuery = objSheet.QueryTables.Add(rst, objSheet.Range("A1"))
    With objExcelQuery
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .Refresh BackgroundQuery:=False
    End With


    objExcel.Visible = True
    objBook.SaveAs strFileName

    
Exit_ExportToExcel:
    Set rst = Nothing
    Set objSheet = Nothing
    Set objBook = Nothing
    Set objExcel = Nothing
    
    DoCmd.Hourglass False
    Exit Function
    
Err_ExportToExcel:
    MsgBox Err.Description, vbCritical, "错误提示"
    Resume Exit_ExportToExcel
End Function

只需要将上面的函数保存到Access的模块中，然后在窗体中调用此函数，可以参考下面的源码示例。