|
|
Function ExportToExcelCopyFromRecordset(ByVal WorkbookName As String, ByVal strSQL As String)
On Error GoTo Err_ExportToExcel
Dim objExcel As Object
Dim objBook As Object
Dim objSheet As Object
Dim objRange As Object
Dim rst As Object
Dim cnn As Object
Dim strFileName As String
Dim lngRow As Long
Dim lngColumn As Long
Dim FirstRange As String
Const xlLastCell = 11
Const xlCenter = -4108
Const xlEdgeLeft = 7
Const xlEdgeTop = 8
Const xlEdgeBottom = 9
Const xlEdgeRight = 10
Const xlInsideVertical = 11
Const xlInsideHorizontal = 12
Const xlContinuous = 1
Const xlDiagonalDown = 5
Const xlDiagonalUp = 6
Const xlNone = -4142
'根据当前版本取得对应的文件扩展名
strExtName = ".xls"
If Val(Application.Version) > 11 Then strExtName = ".xlsx"
'取得另存为文件名
With Application.FileDialog(2) 'msoFileDialogSaveAs
.InitialFileName = WorkbookName & strExtName
If Not .Show Then Exit Function
strFileName = .SelectedItems(1)
If Not strFileName Like "*" & strExtName Then
strFileName = strFileName & strExtName
End If
If Len(Dir(strFileName)) > 0 Then Kill strFileName
End With
DoCmd.Hourglass True
Set cnn = CurrentProject.Connection
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False
Set objBook = objExcel.Workbooks.Add
'objBook.Worksheets.Add().Select
Set objSheet = objBook.Worksheets.Add
'Set objSheet = objBook.Worksheets("sheet1")
objSheet.Name = WorkbookName '工作表名称
'由于CopyFromRecordset 方法不返回字段标题，需要自己处理增加字段标题
Set rst = CurrentProject.Connection.Execute(strSQL)
For intI = 0 To rst.Fields.Count - 1
' strName = ""
' strName = rst.Fields(intI).Properties("Caption")
' If strName = "" Then strName = rst.Fields(intI).Name
objExcel.ActiveSheet.Cells(3, intI + 1) = rst.Fields(intI).Name
Next
objExcel.ActiveSheet.Range("A4").CopyFromRecordset cnn.Execute(strSQL)
With objExcel.ActiveSheet.PageSetup
' .Orientation = xlLandscape
'.LeftMargin = Application.CentimetersToPoints(2) '页边距：左(L)_1.9厘米
' .RightMargin = Application.InchesToPoints(0.75) '页边距：右(R)_1.9厘米
' .TopMargin = InchesToPoints(1) '页边距：上(T)_2.5厘米
' .BottomMargin = Application.InchesToPoints(1) '页边距：下(B)_2.5厘米
.PrintTitleRows = "$1:$2"
.RightFooter = "第 &P 页,共 &N 页" '页脚右设置为：页码
'.PrintTitleColumns = "A:G"
End With
cnn.Close
objExcel.ActiveCell.SpecialCells(xlLastCell).SELECT
lngRow = objExcel.ActiveCell.row
lngColumn = objExcel.ActiveCell.Column
objExcel.Cells(lngRow + 1, 6).formula = "=sum(F4:F" & lngRow & ")"
objExcel.Cells(lngRow + 1, 1) = "合计:"
'格式化Excel
Set objRange = objSheet.Range("A2", objExcel.ActiveCell).Offset(1, 0)
objRange.SELECT
With objRange
.RowHeight = 16
'.ColumnWidth = 50
'.EntireColumn.AutoFit
.VerticalAlignment = xlCenter '垂直对齐 不引用excel控件的话只能使用xlCenter
.HorizontalAlignment = xlCenter '水平对齐 不引用excel控件的话只能使用xlCenter
.WrapText = True '文字自动换行
'.Font.Name = "Calibri"
.Font.Size = 12
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
End With
D = Now
objSheet.Rows(1).RowHeight = 29
objExcel.Range("A1") = "乡镇卫生院发票汇总表"
' objExcel.Range("B2") = "录入日期：" & D
objSheet.Columns("G:G").ColumnWidth = 20
objExcel.ActiveWindow.SplitRow = 3 '拆分第一行
objExcel.ActiveWindow.FreezePanes = True '固定拆分
objExcel.Range("A1:G1").Merge
objExcel.Range("A2:G2").Merge
objExcel.Range("A1").Font.Size = 20
objSheet.Range("A1:G1").Borders.LineStyle = 0
objExcel.Visible = True
objBook.SaveAs strFileName
Set objRange = objSheet.Range("A1:G1")
objRange.SELECT
With objRange
.VerticalAlignment = xlCenter '垂直对齐 不引用excel控件的话只能使用xlCenter
.HorizontalAlignment = xlCenter '水平对齐 不引用excel控件的话只能使用xlCenter
.Columns("B").ColumnWidth = 26
.Columns("C").ColumnWidth = 18.5
.Columns("D").ColumnWidth = 15
.Columns("E").ColumnWidth = 22
.Columns("F").ColumnWidth = 17
.Columns("G").ColumnWidth = 20
End With
objSheet.Range("B4:B300").HorizontalAlignment = -4131
objSheet.Range("A2:G2").Font.Size = 14
objExcel.Cells(lngRow + 3, 1) = "开票人:": objExcel.Cells(lngRow + 3, 3) = "复核人:": objExcel.Cells(lngRow + 3, 5) = "发票接收人:"
objSheet.Range("A" & lngRow + 3).Font.Size = 12: objSheet.Range("C" & lngRow + 3).Font.Size = 12: objSheet.Range("E" & lngRow + 3).Font.Size = 12
Exit_ExportToExcel:
Set rst = Nothing
Set cnn = Nothing
Set objSheet = Nothing
Set objBook = Nothing
Set objExcel = Nothing
DoCmd.Hourglass False
Exit Function
Err_ExportToExcel:
Resume Exit_ExportToExcel
End Function
第1个问题：无法运行下面代码 第2个问题：如何修改成自动默认保存自定义路径，例：导出到E盘要目录，谢谢！
'.LeftMargin = Application.CentimetersToPoints(2) '页边距：左(L)_1.9厘米
' .RightMargin = Application.InchesToPoints(0.75) '页边距：右(R)_1.9厘米
' .TopMargin = InchesToPoints(1) '页边距：上(T)_2.5厘米
' .BottomMargin = Application.InchesToPoints(1) '页边距：下(B)_2.5厘米
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-7-5 08:15
楼主
