Access快速开发平台--Error#1004 Function ExportToExcel2()不能设置类Window的FreezePanes属性的解决方法

时　间:2017-11-25 00:03:23
作　者:麥田   ID：11  城市：上海  QQ：3002789054
摘　要:Access快速开发平台--Error#1004 Function ExportToExcel2()不能设置类Window的FreezePanes属性的解决方法
正　文:

在操作Access快速开发平台导出到Excel数据表会出现错误:
Error#1004 Function ExportToExcel2()不能设置类Window的FreezePanes属性，如下图:

解决方法:
在Main数据库里面新建一个模块，将下列代码贴在模块里面保存即可，再操作导出Excel即可解决。

Function ExportToExcel2(Optional WorkbookName As String, _
                        Optional WorksheetName As String, _
                        Optional StartRange As String = "A1", _
                        Optional DataForm As Form, _
                        Optional DisplayAfterExporting As Boolean = True _
                        ) As String
    On Error GoTo ErrorHandler

    Const xlWorkbookNormal = -4143
   
    With Application.FileDialog(msoFileDialogSaveAs)
        Dim strFileName As String: strFileName = WorkbookName
        If strFileName = "" Then strFileName = DataForm.Caption
        If strFileName = "" Then strFileName = "Book1"
        If Not strFileName Like "*" & IIf(Val(Application.Version) > 11, ".xlsx", ".xls") Then
            strFileName = strFileName & IIf(Val(Application.Version) > 11, ".xlsx", ".xls")
        End If
        .InitialFileName = strFileName
        strFileName = ""
        If Not .Show Then Exit Function
        strFileName = .SelectedItems(1)
    End With

    If Dir(strFileName) <> "" Then Kill strFileName

    DoCmd.Hourglass True
   
    If DataForm Is Nothing Then
        Set DataForm = Screen.ActiveControl.Form
    End If
    DataForm.repaint
    DataForm.Painting = False

    Dim clsPB As PopupProgressBar: Set clsPB = CreateInstance("PopupProgressBar")
    clsPB.StatusText = LoadString("Exporting...")
    If DataForm.Recordset.RecordCount > 0 Then
        DataForm.Recordset.MoveLast
        DataForm.Recordset.MoveFirst
    End If
    clsPB.Max = DataForm.Recordset.RecordCount
   
    Dim objApp   As Object: Set objApp = CreateObject("Excel.Application")
    Dim objBook  As Object: Set objBook = objApp.Workbooks.Add()
    Dim objSheet As Object: Set objSheet = objBook.Worksheets(1)
'    objApp.Visible = True
   
    Do Until objBook.Worksheets.Count = 1
        objBook.Worksheets(2).Delete
    Loop
    Set objSheet = objBook.Worksheets(1)
    objSheet.select
    Dim strSheetName As String: strSheetName = WorksheetName
    If strSheetName <> "" Then
        strSheetName = Replace(strSheetName, "/", "")
        strSheetName = Replace(strSheetName, "\", "")
        strSheetName = Replace(strSheetName, "?", "")
        strSheetName = Replace(strSheetName, "*", "")
        strSheetName = Replace(strSheetName, "[", "")
        strSheetName = Replace(strSheetName, "]", "")
        objSheet.Name = Left(strSheetName, 30)
    End If
   
    Dim varFieldList As Variant: varFieldList = GetFormFieldList(DataForm)
    Dim lngCol As Long: lngCol = 1

    On Error Resume Next
    Dim varItem As Variant
    For Each varItem In varFieldList
        objSheet.Cells(1, lngCol).Value = DataForm("" & varItem).Controls(0).Caption
        Dim strFormat As String: strFormat = DataForm("" & varItem).Format
        Select Case True
        Case strFormat Like "*:nn:*": strFormat = Replace(strFormat, ":nn:", ":mm:")
        Case strFormat Like "*:n:*":  strFormat = Replace(strFormat, ":n:", ":m:")
        End Select
        objSheet.Columns(lngCol).NumberFormatLocal = strFormat
       
        If (TypeOf DataForm("" & varItem) Is TextBox) _
        or (TypeOf DataForm("" & varItem) Is ComboBox) _
        or (TypeOf DataForm("" & varItem) Is ListBox) Then
            Select Case DataForm("" & varItem).TextAlign
            Case 1: objSheet.Columns(lngCol).HorizontalAlignment = xlLeft
            Case 2: objSheet.Columns(lngCol).HorizontalAlignment = xlCenter
            Case 3: objSheet.Columns(lngCol).HorizontalAlignment = xlRight
            End Select
            objSheet.Columns(lngCol).VerticalAlignment = xlCenter
        End If
        lngCol = lngCol + 1
    Next
    On Error GoTo ErrorHandler

    Dim lngRow As Long: lngRow = 2
    Dim rst As Object: Set rst = DataForm.Recordset
    Do Until rst.EOF
        lngCol = 1
        For Each varItem In varFieldList
            objSheet.Cells(lngRow, lngCol).Value = DataForm("" & varItem)
            lngCol = lngCol + 1
        Next
        lngRow = lngRow + 1
        clsPB.Value = lngRow
        rst.MoveNext
    Loop
    FormatExcelSheet objSheet

    objApp.DisplayAlerts = False
    If Val(Application.Version) > 11 Then
        objBook.SaveAs strFileName, xlOpenXMLWorkbook
    Else
        objBook.SaveAs strFileName, xlWorkbookNormal
    End If
    objApp.DisplayAlerts = True
    strFileName = objBook.Name
    clsPB.CloseProgressBar
'    objApp.Workbooks.Open FileName:=strFileName
    If DisplayAfterExporting Then
        objApp.Visible = True
    Else
        objBook.Close
        objApp.Quit
    End If
    ExportToExcel2 = strFileName

ExitHere:
    DoCmd.Hourglass False
    DataForm.Painting = True
    Set clsPB = Nothing
    Set objSheet = Nothing
    Set objBook = Nothing
    Set objApp = Nothing
    Set rst = Nothing
    Exit Function

ErrorHandler:
    MsgBox "Function ExportToExcel2()" & vbCrLf & Err.Description, vbCritical, "Error #" & Err.Number
    Resume ExitHere
End Function