Макрос VBA для печати таблиц в PDF-формате создает отрезанные диаграммы в странном масштабировании

Question

Здравствуйте, красивые люди из Интернета.

У меня проблема с макросом VBA, который я собрал вместе.Макрос предназначен для форматирования всех листов диаграмм в рабочей книге, созданной коммерческим программным обеспечением, а затем распечатки всех листов диаграмм в файлы PDF.Все выполняется правильно, но полученные PDF-файлы показывают графики со странным масштабированием и обрезаются справа.Если я просто беру файлы, отформатированные макросом, а затем вручную печатаю их в PDF через интерфейс File> Print, все в порядке.

Я считаю, что происходящее связано с ориентацией диаграммы.Программное обеспечение генерирует листы диаграммы в альбомной ориентации.Мой макрос меняет их на портрет через 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 здесь , но я не достаточно разбираюсь в VB, чтобы быть уверенным.

Answer 1

Ну ... после того, как я возился с этим весь день, мне удалось найти раздражающее решение.

Чтобы решить эту проблему, я вынул кусок ExportAsFixedFormat из основного цикла форматирования, поместив его во второй цикли заставил 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