在PowerPoint幻灯片上选择“所有”形状，然后将所有数据返回到Excel VBA，以最终更改这些形状的文本

Question

下面的代码允许您选择形状，然后通过提供形状名称，内容，幻灯片编号和注释（用于个人注释）在Excel中填充单元格。 但是，我不想一次选择一个形状，而是一次选择全部或一个以上的形状，以填充回Excel工作表。

有人可以帮忙吗？

这是代码：

Dim ppapp As PowerPoint.Application
Dim pppres As PowerPoint.Presentation

Sub getshapedata()
On Error GoTo line1
Set ppapp = GetObject(, "Powerpoint.application")
Set pppres = ppapp.ActivePresentation

Dim shapeslide
Dim shapename
Dim shapetext
Dim nextrow

shapeslide = ppapp.ActiveWindow.View.Slide.SlideIndex
shapename = ppapp.ActiveWindow.Selection.ShapeRange(1).Name
shapetext = pppres.Slides(shapeslide).Shapes(shapename).TextEffect.Text
friendlyname = InputBox("Insert Friendly Name for " & shapetext, "Friendly Name", "")

nextrow = Sheet1.Range("a" & Rows.Count).End(xlUp).Row + 1

Sheet1.Range("a" & nextrow) = shapeslide
Sheet1.Range("b" & nextrow) = shapename
Sheet1.Range("c" & nextrow) = shapetext
Sheet1.Range("d" & nextrow) = friendlyname

Exit Sub



line1:
MsgBox "No item selected"

End Sub

Sub writedata()
Dim c As Object
Dim shapeslide
Dim shapename
Dim shapetext

Set ppapp = GetObject(, "Powerpoint.application")
Set pppres = ppapp.ActivePresentation

For Each c In Sheet1.Range("a2:a" & Sheet1.Range("a" & Rows.Count).End(xlUp).Row)

shapeslide = Sheet1.Range("a" & c.Row)
shapename = Sheet1.Range("b" & c.Row)
shapetext = Sheet1.Range("c" & c.Row).Text
friendlyname = Sheet1.Range("d" & c.Row)
pppres.Slides(shapeslide).Shapes(shapename).TextEffect.Text = shapetext

Next c

End Sub

Answer 1

声明一个Slide变量和一个Shape变量以用作迭代器：

Dim ppSlide as Object 'PowerPoint.Slide
Dim ppShape as Object 'PowerPoint.Shape

然后将其设置到幻灯片上：

Set ppSlide = ppapp.ActiveWindow.View.Slide

然后，遍历该幻灯片上的形状集合：

For each pptShape in ppSlide.Shapes
    If ppShape.HasTextFrame Then
        '### DO STUFF
    End If
Next

在您的代码中，根据注释，如下所示，并使用自定义函数GetPPTSelection进行了修改：

我不希望所有形状都写回excel，只有我选择的形状。 我该怎么做？

函数GetPPTSelection返回形状的集合（如果选择了任何形状），我认为它应该处理“分组”形状以及多个选择，并且还忽略不具有TextFrame形状（嵌入式图像等）。

Sub getshapedata()

    Dim ppSlide As Object 'PowerPoint.Slide
    Dim ppShape As Object 'PowerPoint.Shape
    Dim nextrow As Long

    Set ppapp = GetObject(, "Powerpoint.application")
    Set pppres = ppapp.ActivePresentation
    Set ppSlide = ppapp.ActiveWindow.View.Slide

    For each ppShape in GetPPTSelection(ppPres.Windows(1))
        friendlyname = InputBox("Insert Friendly Name for " & shapetext, "Friendly Name", "")
        With Sheet1
            nextrow = .Range("a" & .Rows.Count).End(xlUp).Row + 1
            .Range("a" & nextrow) = ppSlide.SlideIndex
            .Range("b" & nextrow) = ppShape.Name
            .Range("c" & nextrow) = ppShape.TextEffect.Text
            .Range("d" & nextrow) = friendlyname
        End With
    Next
Exit Sub


Function GetPPTSelection(window As Object)

' Returns a Collection of selected shapes, if shapes are selected
' Returns a Nothing, if anything else (slides, text, etc.) selected
Dim coll As New Collection
Dim c As Integer
Dim s As Integer
Dim g As Integer

Dim sel As Object '# PowerPoint.Selection

Const ppSelectionShapes As Long = 2  ' in case of late binding

Set sel = window.Selection

If sel.Type = ppSelectionShapes Then
    For s = 1 To sel.ShapeRange.Count
        If IsGrouped(sel.ShapeRange(s)) Then
            '# handle grouped shapes
            For g = 1 To sel.ShapeRange(s).GroupItems.Count
                coll.Add sel.ShapeRange(s).GroupItems(g)
            Next
        Else:
            '# ordinary, ungrouped shapes:
            coll.Add sel.ShapeRange(s)
        End If
    Next
End If

'# Get rid of any shapes which don't have a textframe:
For c = coll.Count To 1 Step -1
    If Not coll(c).HasTextFrame Then coll.Remove (c)
Next

'# Return the collection to the calling procedure:
Set GetPPTSelection = coll

End Function

Function IsGrouped(shp As Object)
'Returns boolean if shape is groupshapes
Dim ret As Boolean

On Error Resume Next
ret = shp.GroupItems.Count > 1
IsGrouped = ret

End Function

我摆脱了On Error GoTo Line1因为此代码中没有标签Line1 ，而且，我认为通常更好地预见和捕获错误，而不是使用像这样的综合处理程序，因为这样会使调试实际问题变得更加困难。 如果此代码仍然引发一些错误，请告诉我哪一行，我可以尝试帮助调试它。

或者，只使用后果自负的On Error Resume Next :)