快速开发平台--解决导出EXCEL错误/错误#1004-类Worksheet的Paste方法无效
时 间:2014-11-29 08:35:22
作 者:风行 ID:16058 城市:江阴
摘 要:先要引用Microsoft Excel 14.0 Object Library,
然后将下面的代码粘贴到 Main 文件 的 basRDPRef(其它模块也行),以替换平台的相同函数,解决在部分电脑上导出时会出现“Paste方法作用于Workbook对象时失败的错误”
正 文:
Public Function ExportToExcel(WorkbookName As String, _
Optional WorksheetName As String, _
Optional StartRange As String = "A1" _
) As String
On Error GoTo ErrorHandler
DoCmd.Hourglass True
Dim strExtensions As String: strExtensions = IIf(Val(Application.Version) <= 11, ".xls", ".xlsx")
Dim strFileName As String: strFileName = WorkbookName
If InStrRev(strFileName, ".") > 0 Then
Dim strExtName As String: strExtName = Mid$(strFileName, InStrRev(strFileName, "."))
strFileName = Left$(WorkbookName, Len(WorkbookName) - Len(strExtName))
If strExtName = ".xls" or strExtName = ".xlsx" Then strExtensions = strExtName
End If
With Application.FileDialog(msoFileDialogSaveAs)
.InitialFileName = strFileName & strExtensions
If Not .Show Then GoTo ExitHere
strFileName = .SelectedItems(1)
If InStrRev(strFileName, ".") > 0 Then
strExtName = Mid$(strFileName, InStrRev(strFileName, "."))
strFileName = Left$(strFileName, Len(strFileName) - Len(strExtName))
If strExtName = ".xls" or strExtName = ".xlsx" Then strExtensions = strExtName
End If
strFileName = strFileName & strExtensions
End With
If Len(Dir(strFileName)) > 0 Then Kill strFileName
Dim objApp As Object: Set objApp = CreateObject("Excel.Application")
objApp.CutCopyMode = xlCopy
RunCommand acCmdSelectAllRecords
RunCommand acCmdCopy
SendKeys "{TAB}", True
' objApp.Visible = True
Dim objBook As Object: Set objBook = objApp.Workbooks.Add()
Do Until objBook.Sheets.Count = 1
objBook.Sheets(1).Delete '
Loop
Dim objSheet As Object: Set objSheet = objBook.Sheets(1)
objSheet.Range(StartRange).Select
objSheet.Paste
EmptyAccessClipboard
objApp.ActiveWindow.SplitRow = objSheet.Range(StartRange).Row
objApp.ActiveWindow.FreezePanes = True
objApp.ActiveWindow.DisplayGridlines = False
If strFileName Like "*.xlsx" And Val(objApp.Version) < 12 Then
strFileName = Left$(strFileName, Len(strFileName) - 1)
End If
If Len(WorksheetName) > 0 Then
objSheet.Name = WorksheetName
Else
strExtName = Mid$(strFileName, InStrRev(strFileName, "\") + 1)
If InStrRev(strExtName, ".") > 0 Then
strExtName = Left$(strExtName, InStrRev(strExtName, ".") - 1)
End If
objSheet.Name = strExtName
End If
objApp.ScreenUpdating = False
Dim lngRow As Long: lngRow = objSheet.Range(StartRange).Row + objSheet.UsedRange.Rows.Count - 1
Dim lngColumn As Long: lngColumn = objSheet.Range(StartRange).Column + objSheet.UsedRange.Columns.Count - 1
On Error Resume Next
With objSheet.Range(StartRange, objSheet.Cells(lngRow, lngColumn))
.Select
.RowHeight = 13.5
.ColumnWidth = 100
.EntireColumn.AutoFit
' .HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeLeft).Weight = xlThin
.Borders(xlEdgeLeft).ColorIndex = xlAutomatic
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeTop).Weight = xlThin
.Borders(xlEdgeTop).ColorIndex = xlAutomatic
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).Weight = xlThin
.Borders(xlEdgeBottom).ColorIndex = xlAutomatic
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeRight).Weight = xlThin
.Borders(xlEdgeRight).ColorIndex = xlAutomatic
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideVertical).ColorIndex = xlAutomatic
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).Weight = xlThin
.Borders(xlInsideHorizontal).ColorIndex = xlAutomatic
' .Interior.ColorIndex = xlNone
End With
On Error GoTo ErrorHandler
' objSheet.Rows(1).RowHeight = 27
' objSheet.Range("A1", objSheet.Cells(1, lngColumn)).Interior.Color = 15986395
objApp.Range(StartRange).Select
If strFileName Like "*.xls" Then
If Val(objApp.Version) > 11 Then
objBook.SaveAs strFileName, xlExcel8
Else
objBook.SaveAs strFileName
End If
Else
objBook.SaveAs strFileName, xlOpenXMLWorkbook
End If
objApp.Visible = True
ExportToExcel = strFileName
ExitHere:
On Error Resume Next
DoCmd.Hourglass False
objApp.ScreenUpdating = True
Set objApp = Nothing
Set objBook = Nothing
Set objSheet = Nothing
Exit Function
ErrorHandler:
RDPErrorHandler " Function ExportToExcel()"
Resume ExitHere
End Function
其它相关资料
快速开发平台--导出Excel文件出现#1004 ExportToExcel()类 Worksheet的Paste方法无效的解决方法[Access软件网]http://www.accessoft.com/article-show.asp?id=9585
2.0.2版本快速开发平台“导出”出错,错误号#1004解决办法[Access软件网]
http://www.accessoft.com/article-show.asp?id=9739
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)