使用VBA在PowerPoint中取消分組后如何按型別重新組合形狀

根據對我

預期結果

uj5u.com熱心網友回復：

我的一個同事總是告訴我使用 F8 來查看宏的作用，而以上所有這些都清楚地表明我沒有這樣做。不夠。我意識到我試圖在函式中對專案進行分組，而實際上這應該在取消分組后發生在宏本身中。我從這個答案中得到靈感（記住它下面的評論：形狀必須有不同的名稱）現在一切都按預期作業。

我不明白的一件事：在Debug.Print Parent.name即時視窗顯示的行中Microsoft Excel，但我在 PowerPoint 中運行它并且 Excel 已關閉。

Sub GiveNamesToShapes_Center_AndThenRegroup()
    Dim oSlide As slide
    Set oSlide = ActivePresentation.Slides(ActiveWindow.View.slide.SlideIndex)
    
    Dim x As Long
    Dim sTemp As String
    
    Dim ShapeList() As String
    Dim ShapeCount As Long
    
    Dim TextList() As String
    Dim TextCount As Long
    
    Dim shp As Shape
    For Each shp In oSlide.shapes
        If shp.Type = msoGroup Then
            NameGroup shp
            
        Else
        
                For x = 1 To oSlide.shapes.Count

            If oSlide.shapes(x).TextFrame.HasText = msoFalse Then
                ShapeCount = ShapeCount   1
                
                
            Else
                TextCount = TextCount   1
            End If
        Next


        ReDim ShapeList(1 To ShapeCount)
        ReDim TextList(1 To TextCount)

        ShapeCount = 0
        TextCount = 0

        For x = 1 To oSlide.shapes.Count

            If oSlide.shapes(x).TextFrame.HasText = msoFalse Then
                ShapeCount = ShapeCount   1
                ShapeList(ShapeCount) = oSlide.shapes(x).name
                
            Else
                TextCount = TextCount   1
                TextList(TextCount) = oSlide.shapes(x).name
            End If
        Next

        If UBound(ShapeList) > 0 Then
            oSlide.shapes.Range(ShapeList).Group
        End If
        If UBound(TextList) > 0 Then
            oSlide.shapes.Range(TextList).Group
        End If
            

        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
    

    
    Dim Shp_Cntr As Double
    Dim Shp_Mid As Double
    
    Dim ShapeLeft As Double
    Dim ShapeTop As Double
    Dim ShapeWidth As Double
    Dim ShapeHeight As Double
    
    
    groupName = oShpGroup.name
    Debug.Print oShpGroup.name
    Dim oSlide As slide: Set oSlide = oShpGroup.Parent
    Debug.Print Parent.name

    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 = msoFalse Then
            
                shp.name = txt
            
                ShapeLeft = shp.Left

                ShapeTop = shp.Top

                ShapeWidth = shp.Width

                ShapeHeight = shp.Height

                
                Shp_Cntr = ShapeLeft   ShapeWidth / 2
                Shp_Mid = ShapeTop   ShapeHeight / 2

            Else

                With shp
                                shp.name = "Textbox " & txt
                    .TextFrame.WordWrap = False
                    .TextFrame.AutoSize = ppAutoSizeShapeToFitText
                    .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
                    .TextFrame.VerticalAnchor = msoAnchorMiddle
                    
                    .Left = Shp_Cntr - (.Width / 2)
                    .Top = Shp_Mid - (.Height / 2)
                End With


            End If
        End If
    Next shp
    

    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

             NameGroup shp

        End If
    Next shp

End Function

標籤：VBA微软幻灯片软件

上一篇：在另一列中列印if-then陳述句的輸出

下一篇：根據單元格顏色和字串定義范圍