使用vba .ExportAsFixedFormat方法从excel打印没有边距的图表表？

Question

我使用以下例程将图表导出（保存）为 pdf。该函数获取集合中用户选择的图表的名称。然后将其一一导出为pdf，用户可以在其中选择导出的pdf的保存文件夹。这是我的代码。

Private Function ExportCurvesPDF(Curves As Collection)
Dim source As Workbook
Dim i As Integer
Dim FileName As String
Dim ExportPath As String

Set source = Thisworkbook

ExportPath = "V:\"
For i = 1 To Curves.count
    FileName = Application.GetSaveAsFilename(ExportPath & Curves(i) & ".pdf")

    If FileName <> "False" Then
       source.Sheets(Curves(i)).ExportAsFixedFormat Type:=xlTypePDF, FileName:=FileName, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
    End If

    ExportPath = common_DB.FolderFromPath(FileName)
Next i

End Function

代码按预期工作，并打印出 pdf，如下面的示例：

虽然 pdf 有相当大的余量，但我想减少或删除它。我曾尝试更改 IgnorePrintArea 属性和 IncludeDocProperties 属性，但似乎对边距没有任何影响。

有没有办法用.ExportAsFixedFileFormat 减少边距？

编辑：我被要求提供图表在 excel 中的屏幕截图：

Answer 1

您可以尝试指定更多要导出的区域。如果减少了 .pdf 内容，这将起作用。例如，假设您的图表与单元格 A1 到 H30 对齐。您可以导出：

source.Sheets(Curves(i)).Range("A1:H30").ExportAsFixedFormat Type:=xlTypePDF...

请记住，您可以列出范围以适应您自己的代码。

这样做可以避免文档顶部出现多余的红线。

Answer 2

可能是我没有清楚地理解这个问题。如果您只想减少保证金，那么对于一个赏金问题来说似乎太简单了（只需将保证金减少到 0 或PageSetup 中的要求）。结果可能是这样的

 With source.Sheets(Curves(i)).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)
 End With

source.Sheets(Curves(i)).ExportAsFixedFormat Type:=xlTypePDF, FileName:=FileName, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

Answer 3

这是我使用的代码。

File= Sheets("Geophysics").Range("F2").Value

With Sheets("Export").PageSetup
    .PrintArea = "A1:I52"     '/!\ The range has to fit what you want to print (first picture)
    .LeftMargin = Application.InchesToPoints(0)
    .RightMargin = Application.InchesToPoints(0)
    .TopMargin = Application.InchesToPoints(0)
    .BottomMargin = Application.InchesToPoints(0)
    .HeaderMargin = Application.InchesToPoints(0)
    .FooterMargin = Application.InchesToPoints(0)
    .CenterHorizontally = True
    .CenterVertically = True
    .Zoom = 106  '/!\ Search for the value that fit the most A4 dimension (second picture). 
    'Depends on rows height and columns width of your print area cells.
    
End With

Sheets("Export").ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\" & File & ".pdf" _
, Quality:=xlQualityStandard, IgnorePrintAreas:=False , OpenAfterPublish:=True

Answer 4

下面的代码对我有用。 我留下了一些可能对您有用的注释行。 我不确定是否需要 ch.Activate。我希望它不是，但我没有彻底测试它。

我得到的图像也在下面。 我不知道这对你来说是不是太大了，但它的白边似乎比你的情况要少。

' Sub only for testing
Private Sub ExportCurvesPDF_caller()
    Dim chsheets As Sheets
    Set chsheets = Charts
    Call ExportCurvesPDF(chsheets)
End Sub

' The Subs you need
Private Sub ExportCurvesPDF(Curves As Sheets)        
    Dim ExportPath As String
    ExportPath = "C:\Users\user1\Documents\"

    Dim ch As Chart
    For Each ch In Curves
        Dim FileName As String
        FileName = ExportPath & ch.Name
        ch.Activate
        Call set_margins(ch)
        ch.ExportAsFixedFormat Type:=xlTypePDF, FileName:=FileName, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
    Next ch        
End Sub

Private Sub set_margins(ch As Chart)
    Application.PrintCommunication = False
    With ch.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0)
        .RightMargin = Application.InchesToPoints(0)
        .TopMargin = Application.InchesToPoints(0)
        .BottomMargin = Application.InchesToPoints(0)
        .HeaderMargin = Application.InchesToPoints(0)
        .FooterMargin = Application.InchesToPoints(0)
        '.ChartSize = xlScreenSize
        '.PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        '.Orientation = xlLandscape
        .Draft = False
        .OddAndEvenPagesHeaderFooter = False
        '.DifferentFirstPageHeaderFooter = False
        '.EvenPage.LeftHeader.Text = ""
        '.EvenPage.CenterHeader.Text = ""
        '.EvenPage.RightHeader.Text = ""
        '.EvenPage.LeftFooter.Text = ""
        '.EvenPage.CenterFooter.Text = ""
        '.EvenPage.RightFooter.Text = ""
        '.FirstPage.LeftHeader.Text = ""
        '.FirstPage.CenterHeader.Text = ""
        '.FirstPage.RightHeader.Text = ""
        '.FirstPage.LeftFooter.Text = ""
        '.FirstPage.CenterFooter.Text = ""
        '.FirstPage.RightFooter.Text = ""
        .PaperSize = xlPaperA4
        '.FirstPageNumber = xlAutomatic
        '.BlackAndWhite = False
        '.Zoom = 100
    End With
    Application.PrintCommunication = True
End Sub

Answer 5

使用 Word 作为辅助应用程序的解决方案

据我所知，仅使用.ExportAsFixedFileFormat 是无法实现的，但您可以使用 Word 作为帮助应用程序来实现您的愿望，我将在下面的代码中进行演示。

为了导出一堆不经常打开和关闭 Word 的图表，我实现了一个 ShapeExporter 类，它包含一个 Word 实例并使用它来导出图表或形状：

在普通模块中使用，如果费用是嵌入式图表（工作表中的图表）

Sub ExportChartToPDF()
    ' Setting up the variables for passing to ShapeExporter
    Dim MyChart As Object

    ' If your chart is an embedded chart in a worksheet
    Set MyChart = ThisWorkbook.Worksheets("YourWorksheet").ChartObjects("ChartName")

    ' If your chart is it's own "chart sheet" like in os's question:
    Set MyChart = ThisWorkbook.Charts("ChartSheetName").ChartArea

    Dim fileName  As String
    fileName = "TestExport"
    
    Dim filePath As String
    filePath = ThisWorkbook.Path
    
    ' Creating an instance of our ShapeExporter:
    ' During the creation of the object, Word is opened in the background
    ' if it wasn't already open.
    Dim oShapeExporter As cShapeExporter
    Set oShapeExporter = New cShapeExporter
    
    ' Export as many shapes as you want here, before destroying oShapeExporter
    ' The ExportShapeAsPDF method pastes the chart in a word document, resizes the
    ' Document to be exactly the size of the chart and then saves it as PDF
    oShapeExporter.ExportShapeAsPDF MyChart, fileName, filePath

    ' As the object goes out of scope, the background instance of Word 
    ' gets closed, if it wasn't open at the time of the creation of the object
    Set oShapeExporter = Nothing
End Sub

要使用导出器对象，您必须将以下代码粘贴到类模块并将类模块命名为cShapeExporter：

Option Explicit

' Storing the instance of Word in the object
Dim wdApp As Object
Dim wdDoc As Object
Dim wdWasOpen As Boolean

Private Sub Class_Initialize()
    ' Opening Word
    If WordIsRunning Then
        Set wdApp = GetObject(, "Word.Application")
        wdWasOpen = True
    Else
        Set wdApp = CreateObject("Word.Application")
        wdApp.Visible = False
        wdWasOpen = False
    End If
    
    ' And creating a Document that will be used for the pasting and exporting
    Set wdDoc = wdApp.Documents.Add
    
    ' Setting margins to 0 so we have no white borders!
    ' If you want, you can set custom white borders for the exported PDF here
    With wdDoc.PageSetup
        .LeftMargin = 0
        .RightMargin = 0
        .TopMargin = 0
        .BottomMargin = 0
    End With
End Sub

Private Sub Class_Terminate()
    ' Important: Close Word as the object is destroyed, but only if it wasn't
    ' previously opened!
    If Not wdWasOpen Then
        wdApp.Quit 0 '(wdDoNotSaveChanges)
    Else
        wdDoc.Close 0
    End If
    Set wdApp = Nothing
    Set wdDoc = Nothing
End Sub

Public Sub ExportShapeAsPDF(xlShp As Object, fileName As String, filePath As String)
    ' Defining which objects can be exported, maybe others are also supported,
    ' they just need to support all the methods and have all the properties used
    ' in this sub
    If TypeName(xlShp) = "ChartObject" Or TypeName(xlShp) = "Shape" Or TypeName(xlShp) = "ChartArea" Then
        'fine
    Else
        MsgBox "Exporting Objects of type " & TypeName(xlShp) & " not supported, sorry."
        Exit Sub
    End If
    
    ' Copying the Excel object into the Word Document
    xlShp.Copy
    wdDoc.Range.Paste
    
    Dim wdShp As Object
    Set wdShp = wdDoc.Shapes(1)
    
    ' Resizing the Word Document
    With wdDoc.PageSetup
        .PageWidth = wdShp.Width
        .PageHeight = wdShp.Height
    End With
    
    ' Aligning the pasted object
    wdShp.Top = 0
    wdShp.Left = 0
    
    ' Export as .pdf
    wdDoc.saveas2 fileName:=filePath & "\" & fileName, FileFormat:=17  '(wdExportFormatPDF)
    
    ' Delete shape in wdDoc
    wdShp.Delete
End Sub

' Utility Function
Private Function WordIsRunning() As Boolean
    Dim wdApp As Object
    On Error Resume Next
    Err.Clear
    Set wdApp = GetObject(, "Word.Application")
    If Err.Number <> 0 Then
        WordIsRunning = False
    Else
        WordIsRunning = True
    End If
End Function