excel - 用于将 Chartsheets 打印到 PDF 的 VBA 宏以奇怪的比例生成截止图表

Question

你好美丽的互联网人。

我拼凑在一起的 VBA 宏有问题。该宏旨在格式化由一个商业软件生成的工作簿中的所有图表表，然后将所有图表表打印为 PDF 文件。一切都正常执行，但生成的 PDF 文件显示的图表具有奇怪的缩放比例并在右侧被截断。如果我只是简单地把宏格式化的文件，然后通过文件>打印界面手动打印成PDF，一切都很好。

我相信正在发生的事情与图表方向有关。该软件生成横向图表。我的宏通过 Chart.PageSetup.Orientation = xlPortrait 将它们更改为纵向。生成的 PDF 是纵向的，但图表似乎仍然是横向的，大部分右侧被截断。

以下是完整的代码块。

Sub GROUP_GraphTool()

Dim i As Integer
Dim JobNo As Variant
Dim StrWk As String
Dim JobName As String
Dim SubT1 As String
Dim SubT2 As String
Dim NAMEser As String
Dim prnt As String
Dim cht As Chart
Dim srs As Object
Dim SCount As Integer
Dim t1s As Integer
Dim t1e As Integer
Dim t2s As Integer
Dim t2e As Integer
Dim t3s As Integer
Dim t3e As Integer
Dim LED As Boolean
Dim YAX As Integer
Dim prnts As Boolean
Dim fldr As FileDialog
Dim GetFolder As Variant
Dim sItem As String
Dim chtName As String
Dim LOGOs As String
Dim logo As Boolean
Dim prntr As Dialog


Application.ScreenUpdating = False
Application.EnableEvents = False

'Asking Questions
    JobNo = InputBox("Enter Job Number")
    JobName = InputBox("Enter Job Name")
    SubT1 = InputBox("Enter Subtitle 1 (optional)")
    SubT2 = InputBox("Enter Subtitle 2 (optional)")
    YAX = InputBox("Enter maximum depth for Y-Axis")
    NAMEser = InputBox("Would you like to manually name each series? (Yes/No)")
        If NAMEser = "Yes" Or NAMEser = "yes" Or NAMEser = "YES" Then
            SCount = InputBox("How many series in each chart?")
             'Getting all the series names
                Set srs = CreateObject("Scripting.Dictionary")
                For i = 1 To SCount
                    srs(i) = InputBox("Name of series" & i)
                Next
            LED = True
        Else
            LED = False
        End If
    LOGOs = InputBox("Would you like to add a logo? (Yes/No)")
        If LOGOs = "Yes" Or LOGOs = "yes" Or LOGOs = "YES" Then
            logo = True
        Else
            logo = False
        End If
    prnt = InputBox("Would you like to print resulting charts? (Yes/No)")
        If prnt = "Yes" Or prnt = "yes" Or prnt = "YES" Then

        Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
        With fldr
            .Title = "Select a Folder"
            .AllowMultiSelect = False
            If .Show <> -1 Then GoTo NextCode
            sItem = .SelectedItems(1)
        End With
NextCode:
            GetFolder = sItem
            Set fldr = Nothing
            prnts = True
        Else
            prnts = False
        End If

'Counting Title Lengths
    t1s = 1
    t1e = Len(JobNo & " - " & JobName)
    t2s = t1e + 1
    t2e = t1e + Len(SubT1)
    t3s = t2e + 1
    t3e = t2e + Len(SubT2)

'Loop Through all charts in Workbook
  For Each cht In ActiveWorkbook.Charts
  cht.Activate

    'Setting chart print area
        With ActiveChart.PageSetup
            .Orientation = xlPortrait
            .CenterHorizontally = True
            .PaperSize = xlPaperLetter
            .TopMargin = Application.InchesToPoints(0.75)
            .HeaderMargin = Application.InchesToPoints(0.3)
            .LeftMargin = Application.InchesToPoints(0.7)
            .RightMargin = Application.InchesToPoints(0.7)
            .BottomMargin = Application.InchesToPoints(0.75)
            .FooterMargin = Application.InchesToPoints(0.3)
        End With



    'Adding Titles

        Set cht = ActiveChart
        cht.HasTitle = True
        cht.ChartTitle.Text = JobNo & " - " & JobName & Chr(10) & SubT1 & Chr(10) & SubT2
        cht.ChartTitle.Font.Bold = True
        cht.ChartTitle.Font.Name = "Calibri"
        cht.ChartTitle.Characters(t1s, t1e).Font.Size = 16
        cht.ChartTitle.Characters(t2s, t3e).Font.Size = 14

    'Naming series if selected
    If LED = True Then
        For i = 1 To SCount
            cht.SeriesCollection(i).Name = srs(i)
        Next
    End If

    'Setting Axes to General (getting rid of sci. not.)

        cht.Axes(xlCategory, xlPrimary).TickLabels.NumberFormat = "general"

    'Deleteing Legend if series not named, Moving Legend if they are
        If LED = False Then
            cht.HasLegend = False
        Else
            cht.HasLegend = True
            cht.Legend.Position = xlLegendPositionBottom
        End If

    'Setting Y-Axis
        cht.Axes(xlValue).MaximumScale = YAX

    'Adding Logo
    If logo = True Then
'''''''''NOTE! Save included logo file to your computer''''''''
'''''''''and set the path to it below where you see hashes'''''
        With cht.Pictures.Insert("##########\Logo.jpg")
            .Left = cht.ChartArea.Left + 1000
            .Top = cht.ChartArea.Top + 1000
            .Placement = 1
        End With
    End If

    'Printing, if selected
        If prnts = True Then
            chtName = cht.Axes(xlCategory).AxisTitle.Caption
            ActiveChart.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
            GetFolder & "/" & chtName, Quality:= _
            xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
            OpenAfterPublish:=False
        End If

Next cht

Application.EnableEvents = True

End Sub

任何帮助深表感谢。我找了高低，都没有成功。我发现另一个线程似乎将此问题作为在 Excel 2007 here 中首次出现的错误进行了讨论。 ，但我对 VB 的了解还不够，无法确定。

Answer 1

好吧......在搞砸了一整天之后，我设法找到了一个烦人的解决方案。

为了解决这个问题，我将 ExportAsFixedFormat block 从主格式化循环中取出，将其放入第二个循环中，并强制 excel 在运行 ExportAsFixedFormat 之前在屏幕上显示每个图表一秒钟。

因此，发生的事情归结为图表没有重新定向以响应 PageSetup.Orientation 中的更改，直到每个图表都显示一秒钟。

代码:

'updating chartsheets

    Application.ScreenUpdating = True

    For Each cht In ActiveWorkbook.Charts
        cht.Select
        cht.Activate
        cht.Refresh
        cht.Visible = True
        With ActiveChart.PageSetup
            .FitToPagesWide = 1
            .FitToPagesTall = 1
        End With
        Application.Wait Now + TimeSerial(0, 0, 1)
    Next cht

    Application.ScreenUpdating = False

    'Printing, if selected
        If prnts = True Then
            chtName = cht.Axes(xlCategory).AxisTitle.Caption
            ActiveChart.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
            GetFolder & "/" & chtName, Quality:= _
            xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
            OpenAfterPublish:=False
        End If
Next cht