如何修改这个函数将数据导成2007格式的Excel(xlsx)

mclly2000

Option Compare Database
Option Explicit
Private Const xlFormatFromLeftOrAbove = 0
Private Const xlAutomatic = -4105
Private Const xlToRight = -4161
Private Const xlFillSeries = 2
Private Const xlNone = -4142
Private Const xlDiagonalDown = 5
Private Const xlDiagonalUp = 6
Private Const xlEdgeLeft = 7
Private Const xlContinuous = 1
Private Const xlThin = 2
Private Const xlEdgeTop = 8
Private Const xlEdgeBottom = 9
Private Const xlEdgeRight = 10
Private Const xlInsideVertical = 11
Private Const xlInsideHorizontal = 12
Private Const xlCenter As Long = -4108
Private Const xlBottom As Long = -4107
Public Function AccToExcel(ByVal AdoRs As ADODB.Recordset, _
                           ByVal strSheetName As String, _
                           Optional strExpPath As String, _
                           Optional msg As Boolean = True, _
                           Optional ExcelQuit As Boolean = True, _
                           Optional ExlToLine As Boolean = True, _
                           Optional ExlToAutoNum As Boolean = False, _
                           Optional strFrmNames As String) As Boolean
''根据SQL导入数据到Excel
'AccToExcel(rs,"card")
''AdoRs:       sql语句
''strSheetName:工作簿名
''strExpPath:  导出路径
''msg:         是否显示消息
''ExcelQuit:   导出后关闭excel
''ExlToLine:   为excel数据画线
''ExlToAutoNum:为excel加编码
''strFrmNames: 窗体名称
    Dim Rs As New ADODB.Recordset
    Dim tExpPath As String
    Dim intCount As Integer
    Dim ApXL As Object                                                         'Excel.Application
    Dim xlWBk As Object                                                        'Excel.Workbook
    Dim xlWSh As Object                                                        'Excel.Worksheet
    Dim lngRows As Long
    Dim LngColumns As Long
    Dim StrSql As String
    On Error Resume Next                                                       'GoTo Err_handler
    If msg Then If MsgBox("确认要导出到excel吗?", vbQuestion + vbYesNo + vbDefaultButton1) = vbNo Then Exit Function
    If msg Then MsgBox "后台正在导出数据,请稍候。"
    If Exist(strExpPath) = 0 Then strExpPath = CurrentProject.Path & "\"
    tExpPath = strExpPath & strSheetName & ".xls"
    If Exist(tExpPath) = 1 Then Kill tExpPath
    Set ApXL = CreateObject("Excel.Application")
    Set xlWBk = ApXL.Workbooks.Add
    ApXL.Visible = False
    Set xlWSh = xlWBk.Worksheets("Sheet1")
    If Len(strSheetName) > 0 Then xlWSh.Name = Left(strSheetName, 34)
    ''导出为2003格式的excel
    If CDbl(Application.Version) < 12 Then
        xlWSh.SaveAs tExpPath
    Else
        xlWSh.SaveAs FileName:=tExpPath, FileFormat:=56, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
    End If
    xlWSh.Range("A1").Select
    Set Rs = AdoRs
    If Not Rs.EOF Then
        Do Until intCount = Rs.Fields.Count
            ApXL.ActiveCell = Rs.Fields(intCount).Name
            ApXL.ActiveCell.offset(0, 1).Select
            intCount = intCount + 1
        Loop
        Rs.MoveFirst
        xlWSh.Range("A2").CopyFromRecordset Rs
        xlWSh.Range("1:1").Select
        With ApXL.Selection.Font
            .Name = "Arial"
            .Size = 12
            .Strikethrough = False
            .Superscript = False
            .Subscript = False
            .OutlineFont = False
            .Shadow = False
        End With
        ApXL.Selection.Font.Bold = True
        With ApXL.Selection
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlBottom
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .MergeCells = False
        End With
        If ExlToAutoNum Then
            '自动编号代码开始
            xlWSh.Columns("A:A").Select
            ApXL.Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
            xlWSh.Range("A1").Select
            ApXL.ActiveCell.FormulaR1C1 = "编号"
            xlWSh.Range("A2").Select
            ApXL.ActiveCell.FormulaR1C1 = "1"
            ApXL.Selection.AutoFill Destination:=xlWSh.Range("A2:A" & ApXL.ActiveSheet.UsedRange.Cells.Rows.Count), Type:=xlFillSeries
            xlWSh.Range("A2:A" & ApXL.ActiveSheet.UsedRange.Cells.Rows.Count).Select
            '自动编号代码结束
        End If
        ApXL.ActiveSheet.Cells.Select
        ApXL.ActiveSheet.Cells.EntireColumn.AutoFit
        If ExlToLine Then
            '画线代码开始
            lngRows = ApXL.ActiveSheet.UsedRange.Cells.Rows.Count
            LngColumns = ApXL.ActiveSheet.UsedRange.Cells.Columns.Count
            xlWSh.Range("A1").Select
            xlWSh.Range(xlWSh.Cells(1, 1), xlWSh.Cells(lngRows, LngColumns)).Select
            xlWSh.Range("A1").Activate
            ApXL.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
            ApXL.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
            With ApXL.Selection.Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
            With ApXL.Selection.Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
            With ApXL.Selection.Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
            With ApXL.Selection.Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
            With ApXL.Selection.Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
            With ApXL.Selection.Borders(xlInsideHorizontal)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
            '画线代码结束
        End If
        xlWSh.Range("A1").Select
    End If
    If Not ExcelQuit Then ApXL.Visible = True
    ''禁止出现Resume.xlw 禁止显示警报。
    ApXL.DisplayAlerts = 0
    ApXL.Save False
    ApXL.DisplayAlerts = -1
    ''关闭工作表
    If ExcelQuit Then ApXL.Quit
    If msg Then MsgBox "数据导出完成。"
    Rs.Close
    Set ApXL = Nothing
    Set xlWBk = Nothing
    Set xlWSh = Nothing
End Function
Public Function Exist(ByVal strDirPath As String, Optional BlnMsg As Boolean = False) As Integer
''测试路径是否有效
'返回0代表文件或路径不存在
'返回1代表该文件存在
'返回2代表该文件夹存在
    Dim intAttr As Integer
    On Error GoTo err:
    If Len(strDirPath) > 0 Then
        intAttr = GetAttr(strDirPath)
        If (intAttr And vbDirectory) Then
            Exist = 2
            'If BlnMsg Then MsgBox "该文件夹存在。"
        ElseIf intAttr > 0 Then
            Exist = 1                                 '
            'If BlnMsg Then Waiting "该文件存在。"
        End If
    End If
    Exit Function
err:
    'If BlnMsg Then Waiting "该文件或文件夹不存在。"
    'Debug.Print Err.Description, "Exist"
    Exit Function
End Function

roych

将这一行：tExpPath = strExpPath & strSheetName & ".xls"
改成：
tExpPath = strExpPath & strSheetName & ".xlsx"
试试看。
不过我个人觉得始终这个函数过于复杂，倒不如在Excel表中设置好模版格式，直接导出好些。