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
Access快速开发平台QQ群 (群号:321554481) Access源码网店
常见问答:
技术分类:
源码示例
- 【源码QQ群号19834647...(12.17)
- Access两种方式实现即时更...(03.01)
- Access隐藏与显示lacc...(01.12)
- 【Access高效办公】将每个...(12.23)
- Access21点游戏源代码(12.13)
- 【Access窗体导出Exce...(11.15)
- 【Access开发】Acces...(11.14)
- 通过Access宏录入数据到选...(11.10)
- 用DLOOKUP函数将需求表中...(10.31)
- Access日期区间段查询数据...(10.25)
学习心得
最新文章
- Access快速开发平台--在WI...(03.08)
- 使用SQL语句删除xscj表中学号...(03.08)
- Access快速开发平台进销存教程...(03.07)
- Access快速开发平台--frm...(03.06)
- 【Access删除查询】删除数字最...(03.06)
- Access快速开发平台进销存教程...(03.05)
- Access快速开发平台进销存教程...(03.04)
- Access快速开发平台--IsL...(03.02)
- Access两种方式实现即时更新月...(03.01)
- Access开发的资金管理系统;基...(02.29)