Question

你好，互联网上的美女。

我拼凑在一起的VBA宏出现问题。该宏用于在由商业软件生成的工作簿中格式化所有图表，然后将所有图表打印为PDF文件。一切正常执行，但是生成的PDF文件以奇怪的比例显示了图表，并在右侧被切除。如果仅使用宏格式化的文件，然后通过File> Print界面手动将其打印为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块从主格式化循环中取出，放入第二个循环，并强制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

VBA宏可将Chartsheets打印为PDF以奇怪的比例生成截止图

1 个答案: