如何获取图表的哪一部分被选中？

Question

我有一些 vsto add-in 到 PowerPoint。

我需要知道用户选择了图表的哪一部分（系列、标题、图表区域、绘图区域、图例等）。有没有可能得到这样的信息？

我当然知道如何获取所选图表。

Answer 1

PowerPoint 对象模型不提供任何属性或方法。

Answer 2

我的加载项是用 VBA 编写的，但我认为以下内容会对您有所帮助。 PPT 对象模型不支持这一点，所以我的 hacky 解决方案是将删除线字体应用为 ExecuteMSO 命令（即删除线应用于所选的任何内容），然后我遍历图表的每个元素并寻找删除线。当我们找到它时，我们可以知道用户选择了什么，应用我们想要的任何规则，并删除删除线。

就我而言，我想重写 Bold 命令，以便我们可以对用户的选择应用不同的字体粗细，而不是使用本机的仿粗体。这是我的解决方案的一部分：

首先，这是当所选内容包含形状时调用的子程序。请注意我们如何处理图表场景：

Private Sub commandBoldSelectedShapes(mySelection As Selection)

Debug.Print "IN_commandBoldSelectedShapes"

Dim oShp As Shape
Dim oSmrtArt As SmartArt
Dim oTable As Table
Dim oChart As Chart
Dim oCell As Cell
Dim i As Long
Dim j As Long
Dim ctr As Long

Dim oFont As Font


For ctr = 1 To mySelection.ShapeRange.Count
    Set oShp = mySelection.ShapeRange(ctr)

    If oShp.Type = msoGroup Then
        RefontTypoGroup oShp, mySelection
    ElseIf oShp.HasSmartArt Then
        Set oSmrtArt = oShp.SmartArt
        DoEvents
        Application.CommandBars.ExecuteMso ("Strikethrough")
        DoEvents
        RefontTypoSmartArt oSmrtArt
    ElseIf oShp.HasTable Then
        Debug.Print "Seeing a table!"
        Set oTable = oShp.Table
    
        If ctr = 1 And mySelection.ShapeRange.Count = 1 Then
    
            With oTable
                For i = 1 To oTable.Rows.Count
                    For j = 1 To oTable.Columns.Count
                        Set oCell = oTable.Rows(i).Cells(j)
                        If oCell.Selected Then
                            Set oFont = oCell.Shape.TextFrame.TextRange.Font
                            checkBoldsNoStrikethrough oFont
                        End If
                    Next
                Next
            End With
    
        Else
            For i = 1 To oTable.Rows.Count
                For j = 1 To oTable.Columns.Count
                    Set oCell = oTable.Rows(i).Cells(j)
                    Set oFont = oCell.Shape.TextFrame.TextRange.Font
                    checkBoldsNoStrikethrough oFont
                Next
            Next
        End If
        
        ' Charts are highly problematic because the VBA Selection object
        ' doesn't allow you to figure out which element(s) in a chart the user
        ' may have selected. You can only see that the full shape containing a chart
        ' has been selected. So my solution was to run an
        ' ExecuteMso - Strikethrough command. Then, separate macros
        ' go through the whole chart looking for strikethoughs and replace them
        ' with bolded/unbolded text and the correct font weight.
    
    ElseIf oShp.HasChart Then
        Debug.Print "Seeing a chart!"
        Set oChart = oShp.Chart
        If ctr = 1 And mySelection.ShapeRange.Count = 1 Then
            DoEvents
            Application.CommandBars.ExecuteMso ("Strikethrough")
            DoEvents
            RefontTypoChart oChart
            Exit Sub
            
            ' If there is more than one shape selected, including a chart,
            ' and that chart is not the first shape selected, we know that
            ' the whole chart has been selected. As a result, we can simply
            ' apply bolding to the whole chart.
        Else
            With oChart.ChartArea.Format.TextFrame2.TextRange.Font
                If GlobalSettings.IsBoldPressed = False Then
                    .Bold = False
                    .Name = FontsSettings.ActiveFonts.bodyFont
                Else
                    .Bold = True
                    .Name = FontsSettings.ActiveFonts.headingFont
                End If
            End With
        End If
    ElseIf oShp.HasTextFrame Then
        If oShp.TextFrame.HasText Then
            Set oFont = oShp.TextFrame.TextRange.Font
            checkBoldsNoStrikethrough oFont
        End If
    End If

Next


End Sub

还有一个子程序开始遍历图表元素。大多数检查都将删除线搜索外包给另一个子：

Sub RefontTypoChart(chrt As Chart)
On Error GoTo Errhandler

'   Dim s As Series
Dim A As axis
'   Dim scnt As Integer
Dim i As Integer

Dim oShp As Shape

Dim oTxtRange2 As TextRange2
Dim oTickLabels As TickLabels
Dim oLegendEntries As LegendEntries
      
Set oTxtRange2 = chrt.Format.TextFrame2.TextRange

If oTxtRange2.Font.Strikethrough = msoTrue Then
    RefontTypoChartShapeRange oTxtRange2
    Exit Sub
End If


If chrt.HasLegend Then
    
    Set oLegendEntries = chrt.Legend.LegendEntries
    
    For i = 1 To oLegendEntries.Count
        With oLegendEntries(i).Font
            If GlobalSettings.IsBoldPressed = False Then
                If .Strikethrough = True Then
                    .Bold = False
                    .Name = FontsSettings.ActiveFonts.bodyFont
                    .Strikethrough = False
                End If
            Else
                If .Strikethrough = True Then
                    .Bold = True
                    .Name = FontsSettings.ActiveFonts.headingFont
                    .Strikethrough = False
                End If
            End If
        End With

    Next
    
    With chrt.Legend.Format.TextFrame2.TextRange.Font
        If GlobalSettings.IsBoldPressed = False Then
            If .Strikethrough = True Then
                .Bold = False
                .Name = FontsSettings.ActiveFonts.bodyFont
                .Strikethrough = False
            End If
        Else
            If .Strikethrough = True Then
                .Bold = True
                .Name = FontsSettings.ActiveFonts.headingFont
                .Strikethrough = False
            End If
        End If
    End With
    
End If
         
If chrt.HasTitle Then
    Set oTxtRange2 = chrt.ChartTitle.Format.TextFrame2.TextRange
    RefontTypoShapeRange oTxtRange2
End If

   
If chrt.HasAxis(xlCategory, xlPrimary) Then
    Set A = chrt.Axes(xlCategory, xlPrimary)
    If A.HasTitle = True Then
        Set oTxtRange2 = A.AxisTitle.Format.TextFrame2.TextRange
        RefontTypoShapeRange oTxtRange2
    End If

    Set oTickLabels = A.TickLabels
    RefontTypoTickLabels oTickLabels
End If

If chrt.HasAxis(xlCategory, xlSecondary) Then
    Set A = chrt.Axes(xlCategory, xlSecondary)
    If A.HasTitle = True Then
        Set oTxtRange2 = A.AxisTitle.Format.TextFrame2.TextRange
        RefontTypoShapeRange oTxtRange2
    End If

    Set oTickLabels = A.TickLabels
    RefontTypoTickLabels oTickLabels
End If

If chrt.HasAxis(xlValue, xlPrimary) Then
    Set A = chrt.Axes(xlValue, xlPrimary)
    If A.HasTitle = True Then
        Set oTxtRange2 = A.AxisTitle.Format.TextFrame2.TextRange
        RefontTypoShapeRange oTxtRange2
    End If
    Set oTickLabels = A.TickLabels
    RefontTypoTickLabels oTickLabels
End If
   

If chrt.HasAxis(xlValue, xlSecondary) Then
    Set A = chrt.Axes(xlValue, xlSecondary)
    If A.HasTitle = True Then
        Set oTxtRange2 = A.AxisTitle.Format.TextFrame2.TextRange
        RefontTypoShapeRange oTxtRange2
    End If
    Set oTickLabels = A.TickLabels
    RefontTypoTickLabels oTickLabels
End If

RefontTypoChartLabels chrt

If chrt.Shapes.Count > 0 Then
    For Each oShp In chrt.Shapes
        If oShp.HasTextFrame Then
            If oShp.TextFrame.HasText Then
                Set oTxtRange2 = oShp.TextFrame2.TextRange
                RefontTypoShapeRange oTxtRange2
            End If
        End If
    Next
End If

Exit Sub

Errhandler:
Debug.Print "Error: " & Err.Description

End Sub

这是查找大部分删除线的子项：

Public Sub RefontTypoShapeRange(oTxtRange2 As TextRange2)

Dim i As Long

With oTxtRange2
    For i = .Runs.Count To 1 Step -1
        With .Runs(i).Font
            If GlobalSettings.IsBoldPressed = False Then
                If .Strikethrough = True Then
                    .Bold = False
                    .Name = FontsSettings.ActiveFonts.bodyFont
                End If
            Else
                If .Strikethrough = True Then
                    .Bold = True
                    .Name = FontsSettings.ActiveFonts.headingFont
                End If
            End If
            
        End With
    Next
    
    .Font.Strikethrough = False
End With

End Sub

您可能会注意到，在发布的第二个子项中，引用了一些专门用于某些图表元素的不同子项。这是因为 TickLabels 没有 TextRange2 对象，因此需要它们自己的检查子（一个传递 TickLabels 对象的）。此外，可以具有多种格式运行的图表元素与不能具有多种格式的图表元素之间存在区别——在不支持的图表元素的 TextRange2 对象中查找运行s超过 1 运行会导致崩溃。

Public Sub RefontTypoChartShapeRange(oTxtRange2 As TextRange2)

Debug.Print "IN_RefontTypoChartShapeRange"
       

With oTxtRange2.Font
    If GlobalSettings.IsBoldPressed = False Then
        If .Strikethrough <> msoFalse Then
            .Bold = False
            .Name = FontsSettings.ActiveFonts.bodyFont
        End If
    Else
        If .Strikethrough <> msoFalse Then
            .Bold = True
            .Name = FontsSettings.ActiveFonts.headingFont
        End If
    End If
    
    .Strikethrough = False
End With

End Sub

图表数据标签也是一个小噩梦，因为如果我们不修改 .Autotext 属性，它们将与数据断开连接，如下所示。

Sub RefontTypoChartLabels(oChrt As Chart)

Dim i As Integer
Dim j As Integer


Dim seriesVar As Series
Dim dataLabelsVar As DataLabels
Dim dataLabelVar As DataLabel

Dim pointVar As Point
Dim oTxtRange2 As TextRange2

Dim isAutoText As Boolean



For i = 1 To oChrt.SeriesCollection.Count
    Set seriesVar = oChrt.SeriesCollection(i)
    
    If seriesVar.HasDataLabels = True Then
        Set dataLabelsVar = seriesVar.DataLabels

        If dataLabelsVar.Format.TextFrame2.TextRange.Font.Strikethrough <> msoFalse Then
            Set oTxtRange2 = dataLabelsVar.Format.TextFrame2.TextRange
            RefontTypoChartShapeRange oTxtRange2
        Else
            For j = 1 To seriesVar.Points.Count
                Set pointVar = seriesVar.Points(j)
                If pointVar.HasDataLabel = True Then
                    Set dataLabelVar = seriesVar.DataLabels(j)
                    isAutoText = dataLabelVar.AutoText
                    Set oTxtRange2 = dataLabelVar.Format.TextFrame2.TextRange
                    RefontTypoChartShapeRange oTxtRange2
                    dataLabelVar.AutoText = isAutoText
                End If
            Next
        End If
    End If
Next

End Sub

希望您能够根据自己的需要调整其中的一些内容，避免拔头发。如果您认为某个地方的某个人可能需要在图表中使用删除线字体，您也可以使用阴影而不是删除线。

如何获取图表的哪一部分被选中？

How to obtain which part of chart is selected?

powerpoint

vsto

office-interop