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返回一个形状集合（如果选择了任何形状），我认为它应该处理＆＃34; Grouped＆＃34;形状，以及多个选择，也忽略了没有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：）

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

1 个答案: