在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 :)