如何使用VBA代码将PowerPoint条形图从左到右翻转为从右到左

我用pptxgenjs生成了一批默认从左到右展示的PowerPoint条形图，希望将其布局翻转为从右到左的样式，但运行以下VBA代码后未达到预期效果，求可行解决方案：

Sub AdjustYAxisForArabic()
Dim pptPresentation As Presentation
Dim pptSlide As Slide
Dim pptShape As Shape
Dim pptChart As Chart
Dim pptChartAxis As Axis
Dim pptPath As String
Dim FSO As Object
Dim folder As Object
Dim file As Object
Dim logFile As String
Dim fileNum As Integer

    On Error GoTo ErrorHandler
    
    ' Select the folder path where your PowerPoint files are located
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select Folder"
        If .Show = -1 Then
            pptPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    
    logFile = pptPath & "\Log.txt"
    fileNum = FreeFile()
    
    Open logFile For Append As #fileNum
    Print #fileNum, "Processing started at " & Now()
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set folder = FSO.GetFolder(pptPath)
    
    Dim processedFiles As Integer
    processedFiles = 0
    
    For Each file In folder.Files
        If LCase(FSO.GetExtensionName(file.Name)) = "pptx" Then
    
            Set pptPresentation = Application.Presentations.Open(file.Path)
            For Each pptSlide In pptPresentation.Slides
                For Each pptShape In pptSlide.Shapes
                    If pptShape.HasChart Then
                        Set pptChart = pptShape.Chart
    
                        ' Move Y-axis to the right side
                        If pptChart.HasAxis(xlValue) Then
                            Set pptChartAxis = pptChart.Axes(xlValue)
                            If Not pptChartAxis Is Nothing Then
                                ' Center align the Y-axis title
                                If pptChartAxis.HasTitle Then
                                    pptChartAxis.AxisTitle.VerticalAlignment = xlCenter
                                End If
                                
                                ' Move axis to the right
                                pptChartAxis.TickLabelPosition = ppAxisTickLabelPositionNextToAxis
                                pptChartAxis.ReversePlotOrder = False
                                pptChartAxis.TickLabels.Alignment = ppAlignLeft
                                pptChartAxis.Format.Line.Visible = msoTrue
                                pptChartAxis.Format.Line.ForeColor.RGB = RGB(0, 0, 0)  ' Black color
                            End If
                        End If
    
                        ' Adjust X-axis for right-to-left reading
                        If pptChart.HasAxis(xlCategory) Then
                            Set pptChartAxis = pptChart.Axes(xlCategory)
                            If Not pptChartAxis Is Nothing Then
                                pptChartAxis.ReversePlotOrder = True
                                pptChartAxis.TickLabels.Orientation = ppHorizontal
                            End If
                        End If
    
                        ' Adjust plot area
                        pptChart.PlotArea.InsideLeft = pptChart.PlotArea.InsideWidth * 0.1
                        pptChart.PlotArea.InsideWidth = pptChart.PlotArea.InsideWidth * 0.8
                    End If
                Next pptShape
            Next pptSlide
    
            pptPresentation.Save
            pptPresentation.Close
    
            Print #fileNum, "Processed: " & file.Name
    
            processedFiles = processedFiles + 1
        End If
    Next file
    
    Print #fileNum, "Processing completed at " & Now()
    Print #fileNum, processedFiles & " files were processed successfully."
    Close #fileNum
    
    MsgBox "Mission Accomplished! " & processedFiles & " files were processed.", vbInformation
    Exit Sub

ErrorHandler:
If Err.Number <> 0 Then
Print #fileNum, "Error processing file: " & file.Name
Print #fileNum, "Error description: " & Err.Description
MsgBox "An error occurred: " & Err.Description & vbNewLine & _
"File: " & file.Name, vbCritical
End If

    If Not pptPresentation Is Nothing Then
        pptPresentation.Close
        Set pptPresentation = Nothing
    End If
    
    Resume Next

End Sub

原代码未针对条形图的轴特性做精准设置，以下是修正后的关键调整点：

• 仅针对条形图类型（如xlBarClustered、xlBarStacked）处理，避免影响其他图表
• 条形图分类轴（Y轴）：翻转分类顺序，将刻度标签移到轴右侧
• 条形图数值轴（X轴）：翻转数值递增方向，将轴位置调整到图表右侧
• 优化绘图区域位置，防止轴标签被遮挡

修正后的完整VBA代码：

Sub AdjustBarChartToRTL()
Dim pptPresentation As Presentation
Dim pptSlide As Slide
Dim pptShape As Shape
Dim pptChart As Chart
Dim pptChartAxis As Axis
Dim pptPath As String
Dim FSO As Object
Dim folder As Object
Dim file As Object
Dim logFile As String
Dim fileNum As Integer

    On Error GoTo ErrorHandler
    
    ' 选择PPT文件所在文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择文件夹"
        If .Show = -1 Then
            pptPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    
    logFile = pptPath & "\处理日志.txt"
    fileNum = FreeFile()
    
    Open logFile For Append As #fileNum
    Print #fileNum, "处理开始时间: " & Now()
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set folder = FSO.GetFolder(pptPath)
    
    Dim processedFiles As Integer
    processedFiles = 0
    
    For Each file In folder.Files
        If LCase(FSO.GetExtensionName(file.Name)) = "pptx" Then
    
            Set pptPresentation = Application.Presentations.Open(file.Path)
            For Each pptSlide In pptPresentation.Slides
                For Each pptShape In pptSlide.Shapes
                    If pptShape.HasChart Then
                        Set pptChart = pptShape.Chart
                        
                        ' 仅处理条形图类型
                        Select Case pptChart.ChartType
                            Case xlBarClustered, xlBarStacked, xlBarStacked100, xl3DBarClustered, xl3DBarStacked, xl3DBarStacked100
                                ' 处理分类轴（Y轴）：翻转顺序+刻度标签移到右侧
                                If pptChart.HasAxis(xlCategory) Then
                                    Set pptChartAxis = pptChart.Axes(xlCategory)
                                    With pptChartAxis
                                        .ReversePlotOrder = True
                                        .TickLabelPosition = xlTickLabelPositionHigh ' 刻度标签在轴右侧
                                        If .HasTitle Then
                                            .AxisTitle.HorizontalAlignment = xlRight ' 轴标题右对齐
                                        End If
                                    End With
                                End If
                                
                                ' 处理数值轴（X轴）：翻转数值方向+轴移到右侧
                                If pptChart.HasAxis(xlValue) Then
                                    Set pptChartAxis = pptChart.Axes(xlValue)
                                    With pptChartAxis
                                        .ReversePlotOrder = True
                                        .Crosses = xlCrossesMaximum ' 轴在最大值处（右侧）
                                        .TickLabelPosition = xlTickLabelPositionNextToAxis
                                        If .HasTitle Then
                                            .AxisTitle.HorizontalAlignment = xlLeft
                                        End If
                                    End With
                                End If
                                
                                ' 调整绘图区域，避免标签被遮挡
                                With pptChart.PlotArea
                                    .InsideLeft = .Parent.Width * 0.2 ' 左移留出标签空间
                                    .InsideWidth = .Parent.Width * 0.7 ' 缩小宽度
                                End With
                        End Select
                    End If
                Next pptShape
            Next pptSlide
    
            pptPresentation.Save
            pptPresentation.Close
    
            Print #fileNum, "已处理: " & file.Name
            processedFiles = processedFiles + 1
        End If
    Next file
    
    Print #fileNum, "处理结束时间: " & Now()
    Print #fileNum, "成功处理 " & processedFiles & " 个文件。"
    Close #fileNum
    
    MsgBox "处理完成！共处理 " & processedFiles & " 个文件。", vbInformation
    Exit Sub

ErrorHandler:
If Err.Number <> 0 Then
    Print #fileNum, "处理文件出错: " & file.Name
    Print #fileNum, "错误描述: " & Err.Description
    MsgBox "发生错误: " & Err.Description & vbNewLine & _
    "文件: " & file.Name, vbCritical
End If

    If Not pptPresentation Is Nothing Then
        pptPresentation.Close
        Set pptPresentation = Nothing
    End If
    
    Resume Next

End Sub

内容的提问来源于stack exchange，提问作者Hedi Developer