VBA 用于使用横向格式将 Excel 转换为 PDF
VBA for to convert Excel to PDF using landscape format
我正在尝试将文件夹中的多个 excel 文件转换为 PDF。我创建了一个将 excel 文件转换为 PDF 并格式化第一页的宏。
我正在尝试让它为每个页面设置格式,但我运气不好。
我已经尝试了很多 for each 循环,但它似乎不起作用。
单元格 E4 和 E3 是位于主宏工作簿第一个 sheet 中的文件的位置。
有什么建议吗?
Sub Convert_ExceltoPDF()
Application.DisplayStatusBar = True
Application.ScreenUpdating = False
Dim sh As Worksheet
Dim fso As New FileSystemObject
Dim fo As Folder
Dim f As File
Dim n As Integer
Dim x As Integer
Dim wb As Workbook
Dim I As Long
Set sh = ThisWorkbook.Sheets("Sheet1")
Set fo = fso.GetFolder(sh.Range("E3").Value)
For Each f In fo.Files
n = n
Application.StatusBar = "Processing..." & n & "/" & fo.Files.Count
Set wb = Workbooks.Open(f.Path)
Call Print_Settings(f, xlPaperLetter)
wb.ExportAsFixedFormat xlTypePDF, sh.Range("E4").Value & Application.PathSeparator & VBA.Replace(f.Name, ".xlsx", ".pdf"), quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=True
Call Print_Settings(f, xlPaperLetter)
wb.Close
Next
Application.StatusBar = ""
MsgBox "Process Complete"
End Sub
Sub Print_Settings(f As File, ePaperSize As XlPaperSize)
On Error Resume Next
Application.PrintCommunication = False
With PageSetup
LeftMargin = Application.InchesToPoints(0)
RightMargin = Application.InchesToPoints(0)
TopMargin = Application.InchesToPoints(0)
BottomMargin = Application.InchesToPoints(0)
HeaderMargin = Application.InchesToPoints(0)
FooterMargin = Application.InchesToPoints(0)
Orientation = xlLandscape
PaperSize = ePaperSize
Zoom = False
FitToPagesWide = 1
FitToPagesTall = 1
End With
Application.PrintCommunication = True
End Sub
首先,您需要更改 Print_Settings()
的签名,以便它接受工作簿对象,而不是文件对象...
Sub Print_Settings(wb As Workbook, ePaperSize As XlPaperSize)
然后您可以使用 For Each/Next
循环遍历每个工作表...
For Each ws In wb.Worksheets
'etc
'
'
Next ws
所以Print_Settings()
将如下...
Sub Print_Settings(wb As Workbook, ePaperSize As XlPaperSize)
Dim ws As Worksheet
'On Error Resume Next
Application.PrintCommunication = False
For Each ws In wb.Worksheets
With ws.PageSetup
.LeftMargin = Application.InchesToPoints(0)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0)
.BottomMargin = Application.InchesToPoints(0)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
.Orientation = xlLandscape
.PaperSize = ePaperSize
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
Next ws
Application.PrintCommunication = True
End Sub
然后你可以调用如下程序...
Call Print_Settings(wb, xlPaperLetter)
其他注意事项
您可以删除对 Print_Settings()
的第二次调用,因为它看起来多余。
您应该为 Workbook 对象的 Close 方法提供适当的参数。否则,系统会提示您是否要保存工作簿。
您的计数器变量 n
应在 For Each/Next
循环之前初始化,然后在循环内递增。
试试下面的方法...
n = 0 'initialize counter
For Each f In fo.Files
n = n + 1 'increment counter
Application.StatusBar = "Processing..." & n & "/" & fo.Files.Count
Set wb = Workbooks.Open(f.Path)
Call Print_Settings(wb, xlPaperLetter)
wb.ExportAsFixedFormat xlTypePDF, sh.Range("E4").Value & Application.PathSeparator & VBA.Replace(f.Name, ".xlsx", ".pdf"), quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=True
wb.Close SaveChanges:=False 'change as desired
Next
我正在尝试将文件夹中的多个 excel 文件转换为 PDF。我创建了一个将 excel 文件转换为 PDF 并格式化第一页的宏。
我正在尝试让它为每个页面设置格式,但我运气不好。
我已经尝试了很多 for each 循环,但它似乎不起作用。
单元格 E4 和 E3 是位于主宏工作簿第一个 sheet 中的文件的位置。
有什么建议吗?
Sub Convert_ExceltoPDF()
Application.DisplayStatusBar = True
Application.ScreenUpdating = False
Dim sh As Worksheet
Dim fso As New FileSystemObject
Dim fo As Folder
Dim f As File
Dim n As Integer
Dim x As Integer
Dim wb As Workbook
Dim I As Long
Set sh = ThisWorkbook.Sheets("Sheet1")
Set fo = fso.GetFolder(sh.Range("E3").Value)
For Each f In fo.Files
n = n
Application.StatusBar = "Processing..." & n & "/" & fo.Files.Count
Set wb = Workbooks.Open(f.Path)
Call Print_Settings(f, xlPaperLetter)
wb.ExportAsFixedFormat xlTypePDF, sh.Range("E4").Value & Application.PathSeparator & VBA.Replace(f.Name, ".xlsx", ".pdf"), quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=True
Call Print_Settings(f, xlPaperLetter)
wb.Close
Next
Application.StatusBar = ""
MsgBox "Process Complete"
End Sub
Sub Print_Settings(f As File, ePaperSize As XlPaperSize)
On Error Resume Next
Application.PrintCommunication = False
With PageSetup
LeftMargin = Application.InchesToPoints(0)
RightMargin = Application.InchesToPoints(0)
TopMargin = Application.InchesToPoints(0)
BottomMargin = Application.InchesToPoints(0)
HeaderMargin = Application.InchesToPoints(0)
FooterMargin = Application.InchesToPoints(0)
Orientation = xlLandscape
PaperSize = ePaperSize
Zoom = False
FitToPagesWide = 1
FitToPagesTall = 1
End With
Application.PrintCommunication = True
End Sub
首先,您需要更改 Print_Settings()
的签名,以便它接受工作簿对象,而不是文件对象...
Sub Print_Settings(wb As Workbook, ePaperSize As XlPaperSize)
然后您可以使用 For Each/Next
循环遍历每个工作表...
For Each ws In wb.Worksheets
'etc
'
'
Next ws
所以Print_Settings()
将如下...
Sub Print_Settings(wb As Workbook, ePaperSize As XlPaperSize)
Dim ws As Worksheet
'On Error Resume Next
Application.PrintCommunication = False
For Each ws In wb.Worksheets
With ws.PageSetup
.LeftMargin = Application.InchesToPoints(0)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0)
.BottomMargin = Application.InchesToPoints(0)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
.Orientation = xlLandscape
.PaperSize = ePaperSize
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
Next ws
Application.PrintCommunication = True
End Sub
然后你可以调用如下程序...
Call Print_Settings(wb, xlPaperLetter)
其他注意事项
您可以删除对
Print_Settings()
的第二次调用,因为它看起来多余。您应该为 Workbook 对象的 Close 方法提供适当的参数。否则,系统会提示您是否要保存工作簿。
您的计数器变量
n
应在For Each/Next
循环之前初始化,然后在循环内递增。
试试下面的方法...
n = 0 'initialize counter
For Each f In fo.Files
n = n + 1 'increment counter
Application.StatusBar = "Processing..." & n & "/" & fo.Files.Count
Set wb = Workbooks.Open(f.Path)
Call Print_Settings(wb, xlPaperLetter)
wb.ExportAsFixedFormat xlTypePDF, sh.Range("E4").Value & Application.PathSeparator & VBA.Replace(f.Name, ".xlsx", ".pdf"), quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=True
wb.Close SaveChanges:=False 'change as desired
Next