Excel VBA宏将图表表打印为PDF，以奇怪的比例生成截止图

你好，美丽的互联网人

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

我相信正在发生的事情与图表方向有关。该软件在横向中生成图表。“我的宏”通过Chart.PageSetup.Orientation=xltartic将它们更改为纵向。制作的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

子组_GraphTool（）
作为整数的Dim i
Dim JobNo作为变体
作为字符串的Dim StrWk
将作业名称设置为字符串
Dim SubT1作为字符串
Dim SubT2作为字符串
作为字符串的Dim命名器
作为字符串的Dim prnt
暗海隧As图
将srs作为对象
作为整数的Dim-scont
作为整数的Dim t1s
作为整数的Dim t1e
作为整数的Dim t2s
作为整数的Dim t2e
作为整数的Dim t3s
作为整数的Dim t3e
将LED调暗为布尔值
作为整数的Dim YAX
作为布尔值的Dim prnts
Dim fldr As FILE对话框
Dim GetFolder作为变量
以字符串形式显示
将名称设置为字符串
将徽标变暗为字符串
将徽标变暗为布尔值
变暗prntr As对话框
Application.ScreenUpdating=False
Application.EnableEvents=False
"提问,
作业编号=输入框（“输入作业编号”）
作业名称=输入框（“输入作业名称”）
SubT1=输入框（“输入子标题1（可选）”）
SubT2=输入框（“输入副标题2（可选）”）
YAX=输入框（“输入Y轴的最大深度”）
NAMEser=InputBox（“是否手动命名每个系列？（是/否）”）
如果NAMEser=“是”或NAMEser=“是”或NAMEser=“是”，则
Scont=InputBox（“每个图表中有多少个系列？”）
'获取所有系列名称
设置srs=CreateObject（“Scripting.Dictionary”）
对于i=1，搜索
srs（i）=输入框（“系列名称”&i）
下一个
LED=真
其他的
发光二极管=假
如果结束
LOGOs=InputBox（“是否要添加徽标？（是/否）”）
如果LOGOs=“Yes”或LOGOs=“Yes”或LOGOs=“Yes”，则
logo=True
其他的
logo=False
如果结束
prnt=InputBox（“是否要打印结果图表？（是/否）”）
如果prnt=“是”或prnt=“是”或prnt=“是”，则
设置fldr=Application.FileDialog（msoFileDialogFolderPicker）
与fldr
.Title=“选择一个文件夹”
.AllowMultiSelect=False
如果.Show-1，则转到下一个代码
sItem=.SelectedItems（1）
以
下一个代码：
GetFolder=sItem
设置fldr=无
prnts=真
其他的
prnts=错误
如果结束
“计算标题长度
t1s=1
t1e=Len（作业编号和作业名称）
t2s=t1e+1
t2e=t1e+Len（子1）
t3s=t2e+1
t3e=t2e+Len（子2）
'循环浏览工作簿中的所有图表
对于ActiveWorkbook.Charts中的每个cht
激活
'设置图表打印区域
使用ActiveChart.PageSetup
.方向=xl纵向
.center=True
.PaperSize=xlPaperLetter
.TopMargin=应用程序.InchesToPoints（0.75）
.HeaderMargin=应用程序.InchesToPoints（0.3）
.LeftMargin=应用程序.InchesToPoints（0.7）
.RightMargin=应用程序.InchesToPoints（0.7）
.BottomMargin=应用程序的.InchesToPoints（0.75）
.FooterMargin=应用程序.InchesToPoints（0.3）
以
"加标题",
设置cht=ActiveChart
cht.hasttle=真
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
'命名系列（如果选中）
如果LED=真，则
对于i=1，搜索
cht.SeriesCollection（i）.Name=srs（i）
下一个
如果结束
'将轴设置为常规（摆脱sci.not.）
cht.Axes（xlCategory，xlPrimary）.TickLabels.NumberFormat=“general”
'如果系列未命名，则删除图例；如果系列未命名，则移动图例
如果LED=假，则
cht.haslegdeng=False
其他的
cht.haslegdeng=True
cht.Legend.Position=xlLegendPositionBottom
如果结束
'设置Y轴
垂直轴（xlValue）。最大刻度=YAX
“添加徽标
如果logo=True，则
注意！将附带的徽标文件保存到您的计算机
然后在下面看到散列的地方设置路径
使用cht.Pictures.Insert（“#############Logo.jpg”）
.Left=cht.ChartArea.Left+1000
.Top=cht.ChartArea.Top+1000
.Placement=1
以
如果结束
'打印，如果选择
如果prnts=真，则
chtName=cht.Axes（xlCategory）.axistTitle.Caption
ActiveChart.ExportAsFixedFormat类型：=xlTypePDF，文件名：=_
GetFolder&“/”&chtName，质量：=_
xlQualityStandard，IncludeDocProperties:=真，IgnorePrintAreas:=假_
OpenAfterPublish:=False
如果结束
下一个红隧
Application.EnableEvents=True
端接头

非常感谢您的帮助。我到处寻找，都没有成功。我发现另一个线程似乎讨论了这个问题，它是Excel 2007中首次出现的一个bug，但我对VB还不够精通，不能肯定。

好吧。。。饭后

'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