大家看看这个函数为什么执行错误

mclly2000

AccToExcel函数
'**-------------------------------------------------------------------
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 DeleteFiles 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
'**-------------------------------------------------------------------

mclly2000

附件已上传，数据后台是SQL SERVER 大家凑合看吧，需要远程操作测试代码 请QQ联系我 412180883

tmtony

将 AccToExcel 随便改个名称 即可
AccToExcel1  或 MyTest
另你代码里还缺少其它函数, 可能你摘抄别人的代码没有抄全

mclly2000

cuxun 发表于 2012-12-26 14:10
怎么一句调试都不会的.最起码要知道错误在哪吧.

非常感谢站长和大肚老师的悉心教诲，祝你们元旦快乐

mclly2000

tmtony 发表于 2012-12-26 13:49
将 AccToExcel 随便改个名称 即可
AccToExcel1  或 MyTest
另你代码里还缺少其它函数, 可能你摘抄别人的代 ...

非常感谢站长和大肚老师的悉心教诲，祝您们元旦快乐