Select PowerPoint 幻灯片上的所有形状，并将所有数据返回 Excel VBA 以最终更改这些形状的文本

Question

下面的代码允许您 select 形状，然后通过提供形状名称、内容、幻灯片编号和评论（用于您的个人笔记）填充 Excel 中的单元格。但是我不想一次select一个形状，我想一次select所有或多个形状来填充回Excel sheet。

有人能帮忙吗？

代码如下：

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 进行了修改，如下所示

I don't want ALL the shapes to write back to excel, only the ones I select. How do I go about doing that?

函数 GetPPTSelection returns 形状集合（如果选择了任何形状），我认为它应该处理 "Grouped" 形状，以及多项选择，并且还会忽略形状没有 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 后果自负:)

Select PowerPoint 幻灯片上的所有形状，并将所有数据返回 Excel VBA 以最终更改这些形状的文本

Select ALL shapes on a powerpoint slide, and get all data back to Excel VBA to eventually change the text of those shapes

excel

powerpoint

vba