如何使用VBA在PowerPoint中重命名分組中的形狀

我有一組形狀，其??中相關的是由形狀和文本框組成的對（整個繪圖被匯入為 SVG 影像并取消分組以使其可編輯）。對于每一對，我希望在文本框中寫入的內容之后重命名形狀，但我找不到訪問這些形狀的方法。我在“目標”處收到錯誤objects does not support property or method，我嘗試了幾種命名方法（oSh(G).GroupItems(i)除其他外），但不是正確的方法，有人可以幫我嗎？

Sub GiveNamesToShapes()
Dim oSlide As slide
Dim oSh As Shape
Dim i As Integer
Dim Source As String
Dim Target As Shape
Dim Group As Shape
Dim G As Integer


    For Each oSh In ActivePresentation.Slides(1).Shapes
        For G = 1 To ActivePresentation.Slides(1).Shapes.Count
            If ActivePresentation.Slides(1).Shapes(G).Type = msoGroup Then
    
                For i = 1 To oSh.GroupItems.Count
    
                    If oSh.GroupItems(i).TextFrame2.HasText = True Then
    
                    Source = oSh.GroupItems(i).TextFrame2.TextRange
                        
                    ElseIf oSh.GroupItems(i).TextFrame2.HasText = False Then
                    
                        With ActivePresentation.Slides(1).Shapes.Range.GroupItems
                        Target = oSh.GroupItems(i) ''here the error
                        End With
                        
                    End If
    
                    With oSh.GroupItems(i) = Target
                          Set .Name = Source
                    End With
                Next
            End If
        Next
    Next
End Sub

uj5u.com熱心網友回復：

這比預期的要困難得多，因為您不能使用 VBA 直接訪問形狀組的子組。

此解決方案使用遞回并通過取消組合“父”組然后重新組合它來訪問子組。

Sub GiveNamesToShapes()
    Dim oSlide As Slide
    Set oSlide = ActivePresentation.Slides(1)
    
    Dim shp As Shape
    For Each shp In oSlide.Shapes
        If shp.Type = msoGroup Then
            NameGroup shp
        End If
    Next shp
End Sub

Function NameGroup(ByVal oShpGroup As Object) As Long
    Dim groupName As String, shp As Shape, shpRng As ShapeRange, txt As String
    groupName = oShpGroup.Name
    Dim oSlide As Slide: Set oSlide = oShpGroup.Parent
    'Ungroup the group and look at each shape inside the group
    Set shpRng = oShpGroup.Ungroup
    For Each shp In shpRng
        If Not shp.Type = msoGroup Then
            If shp.TextFrame.HasText = msoTrue Then _
                txt = shp.TextFrame.TextRange.Text
        End If
    Next shp
    For Each shp In shpRng
        If Not shp.Type = msoGroup Then
            If shp.TextFrame.HasText = msoTrue Then
                'You can name the TextBox here if desired
                'item.name =
            Else
                'The item that is grouped with the TextBox,
                'except for the TextBox itself, will be named here:
                shp.Name = txt
            End If
        End If
    Next shp
    
    'We need to get the shape ids to group the shpRng again
    Dim ids() As Long, i As Long: ReDim ids(1 To shpRng.Count): i = 1
    For Each shp In shpRng
        If shp.Type = msoGroup Then
            'For shapes that are groups themselves, call the funct. recursively.
            'Because NameGroup dis- and then reassembles the group, shpRng.Group
            'won't work anymore after this. That's why we need to get the ids.
            'NameGroup returns the id of the reassembled group.
            ids(i) = NameGroup(shp): i = i   1
        Else
            ids(i) = shp.id: i = i   1
        End If
    Next shp
    
    'Get the indices of the shapes with the ids in the 'ids' array
    Dim indices() As Long, j As Long: ReDim indices(LBound(ids) To UBound(ids))
    For i = LBound(ids) To UBound(ids)
        For j = 1 To oSlide.Shapes.Count
            If oSlide.Shapes(j).id = ids(i) Then indices(i) = j: Exit For
        Next j
    Next i
    Set shp = oSlide.Shapes.Range(indices).Group
    'You can name the group here if desired. By default, it will get its
    'original name back
    shp.Name = groupName
    NameGroup = shp.id 'Return the id of the reassembled group
End Function

標籤：vba微软幻灯片软件

上一篇：在此ExcelVBA代碼中，我將如何指定僅包含Sheet1中的A1:M500其他所有內容都相同？

下一篇：添加兩個小時的計時器以根據修改日期移動檔案