以下代码不需要懂，直接复制即可

文本动作

拆分多段

'拆分合并-拆成多段
Sub bt_TextSplitParagraph()
    On Error GoTo hexit 'hexit:
    Dim oSld As Slide
    Dim oShp As Shape
    Dim oRng As TextRange
    Dim oCount As Long
    Dim i As Integer
   If ActiveWindow.Selection.Type = ppSelectionNone Then Exit Sub
   If ActiveWindow.Selection.Type = ppSelectionSlides Then Exit Sub
    Set oSld = ActiveWindow.Selection.SlideRange(1)
    ' add tag
    For Each oShp In ActiveWindow.Selection.ShapeRange
        If oShp.HasTextFrame Then
            oShp.Tags.add "select", "y"
        End If
    Next
    For Each oShp In oSld.Shapes
        If oShp.Tags("select") = "y" Then
            For oCount = 1 To oShp.TextFrame.TextRange.Paragraphs.Count
                Set oRng = oShp.TextFrame.TextRange.Paragraphs(oCount)
                If oRng.Text = "" Or oRng.Text = Chr(13) Or oRng.Text = Chr(10) Then
                Else
                    With oShp.Duplicate
                        If .Tags("select") = "y" Then .Tags.Delete ("select")
                        .top = oRng.BoundTop - .TextFrame.MarginTop
                        .left = oShp.left
                        .TextFrame.TextRange.Text = oRng.TrimText
                        .Tags.add "line", "y"
                    End With
                End If
            Next
        End If
    Next
    For i = oSld.Shapes.Count To 1 Step -1
        With oSld.Shapes(i)
            If .Tags("select") = "y" Then
                .Tags.Delete ("select")
                .Delete
            End If
        End With
    Next
    For i = oSld.Shapes.Count To 1 Step -1
        With oSld.Shapes(i)
            If .Tags("line") = "y" Then
                .Select msoFalse
                .Tags.Delete ("line")
            End If
        End With
    Next
    Exit Sub
hexit:
End Sub

拆成多行

'拆分合并-拆成多行
Sub bt_TextSplitLines()
    On Error GoTo hexit 'hexit:
    Dim oSld As Slide
    Dim oShp As Shape
    Dim oRng As TextRange
    Dim oCount As Long
    Dim i As Integer
   If ActiveWindow.Selection.Type = ppSelectionNone Then Exit Sub
   If ActiveWindow.Selection.Type = ppSelectionSlides Then Exit Sub
    Set oSld = ActiveWindow.Selection.SlideRange(1)
    ' add tag
    For Each oShp In ActiveWindow.Selection.ShapeRange
        If oShp.HasTextFrame Then
            oShp.Tags.add "select", "y"
        End If
    Next
    For Each oShp In oSld.Shapes
        If oShp.Tags("select") = "y" Then
            For oCount = 1 To oShp.TextFrame.TextRange.Lines.Count
                Set oRng = oShp.TextFrame.TextRange.Lines(oCount)
                If oRng.Text = "" Or oRng.Text = Chr(13) Then
                Else
                    With oShp.Duplicate
                        If .Tags("select") = "y" Then .Tags.Delete ("select")
                        .top = oRng.BoundTop - .TextFrame.MarginTop
                        .left = oShp.left
                        .TextFrame.TextRange.Text = oRng.TrimText
                        .Tags.add "line", "y"
                    End With
                End If
            Next
        End If
    Next
    For i = oSld.Shapes.Count To 1 Step -1
        With oSld.Shapes(i)
            If .Tags("select") = "y" Then
                .Tags.Delete ("select")
                .Delete
            End If
        End With
    Next
    For i = oSld.Shapes.Count To 1 Step -1
        With oSld.Shapes(i)
            If .Tags("line") = "y" Then
                .Select msoFalse
                .Tags.Delete ("line")
            End If
        End With
    Next
    Exit Sub
hexit:
End Sub

合并文字

'拆分合并-合并文字
Sub bt_TextMerge()
    On Error GoTo hexit 'hexit:
    ' This will merge the text from all selected text boxes into the
    ' first selected box then delete the other text boxes
    Dim oRng As ShapeRange
    Dim oFirstShape As Shape
    Dim oSh As Shape
    Dim X As Long
    Dim owidth As Long
    Set oRng = ActiveWindow.Selection.ShapeRange
    If oRng.Count <= 1 Then Exit Sub
    Set oFirstShape = oRng(1)
    owidth = ArrGroupSize()(3)
    oFirstShape.Width = owidth
    For X = 2 To oRng.Count
        oFirstShape.TextFrame.TextRange.Text = _
            oFirstShape.TextFrame.TextRange.Text _
            & oRng(X).TextFrame.TextRange.Text
        If X < oRng.Count Then
            oFirstShape.TextFrame.TextRange.Text = _
                oFirstShape.TextFrame.TextRange.Text
        End If
    Next
    For X = oRng.Count To 2 Step -1
        oRng(X).Delete
    Next
    Set oRng = Nothing
    Set oFirstShape = Nothing
    Set oSh = Nothing
hexit:
End Sub
'选定组大小
Function ArrGroupSize()
    On Error GoTo hexit
    Dim oSld As Slide
    Dim oShp As Shape
    Dim oCount As Integer
    Dim x As Integer
    Dim L_left As Double
    Dim L_right As Double
    Dim L_top As Double
    Dim L_bottom As Double
    Dim pWidth As Double
    Dim pheight As Double
    Dim oleft As Double
    Dim oTop As Double
    Dim owidth As Double
    Dim oheight As Double
    Dim Offset_x As Double
    Dim Offset_y As Double
    Dim oSize(5) As Double
    If ActiveWindow.Selection.Type <> ppSelectionShapes Then
        ArrGroupSize = oSize()
        Exit Function
    End If
    ' 幻灯片大小
    With ActivePresentation.PageSetup
        pWidth = .SlideWidth
        pheight = .SlideHeight
    End With
    Set oSld = ActiveWindow.Selection.SlideRange(1)
    oCount = ActiveWindow.Selection.ShapeRange.Count
    ' 单个元素
    If oCount = 1 Then
        Exit Function
    End If
    With ActiveWindow.Selection.ShapeRange(1)
        L_left = .left
        L_right = .left + .Width
        L_top = .top
        L_bottom = .top + .Height
    End With
    For x = 2 To oCount
        With ActiveWindow.Selection.ShapeRange(x)
            If .left < L_left Then L_left = .left
            If .left + .Width > L_right Then L_right = .left + .Width
            If .top < L_top Then L_top = .top
            If .top + .Height > L_bottom Then L_bottom = .top + .Height
        End With
    Next
    '    Debug.Print "左: " & ConvertPointToCm(L_left) & " 厘米"
    '    Debug.Print "右: " & ConvertPointToCm(L_right) & " 厘米"
    '    Debug.Print "上: " & ConvertPointToCm(L_top) & " 厘米"
    '    Debug.Print "下: " & ConvertPointToCm(L_bottom) & " 厘米"
    ' 整体大小
    oleft = L_left
    oTop = L_top
    owidth = L_right - L_left
    oheight = L_bottom - L_top
    oSize(0) = 1
    oSize(1) = oleft
    oSize(2) = oTop
    oSize(3) = owidth
    oSize(4) = oheight
    ArrGroupSize = oSize()
    '    Debug.Print "整体-宽" & ConvertPointToCm(oWidth) & " 厘米"
    '    Debug.Print "整体-高" & ConvertPointToCm(oHeight) & " 厘米"
hexit:
End Function

拆分字符

'拆分合并-拆成单字
Sub bt_TextSplitCharacter()
    On Error GoTo hexit 'hexit:
    Dim oSld As Slide
    Dim oShp As Shape
    Dim oRng As TextRange
    Dim oCount As Long
    Dim i As Long
   If ActiveWindow.Selection.Type = ppSelectionNone Then Exit Sub
   If ActiveWindow.Selection.Type = ppSelectionSlides Then Exit Sub
    Set oSld = ActiveWindow.Selection.SlideRange(1)
    Set oShp = ActiveWindow.Selection.ShapeRange(1)
    With oShp
        If .HasTextFrame Then
            If Len(.TextFrame.TextRange.Text) = 0 Then Exit Sub
            For oCount = 1 To .TextFrame.TextRange.Characters.Count
                Set oRng = .TextFrame.TextRange.Characters(oCount)
                With oShp.Duplicate
                    .top = oRng.BoundTop - .TextFrame.MarginTop
                    .left = oRng.BoundLeft - .TextFrame.MarginLeft
                    .Width = oRng.BoundWidth
                    .Width = oRng.BoundHeight
                    .TextFrame.TextRange.Text = oRng.TrimText
                    .TextFrame.TextRange.Font.Color.RGB = oRng.Font.Color
                    .TextFrame.TextRange.Font.Bold = oRng.Font.Bold
                    .Tags.add "Split", "y"
                End With
            Next
        End If
    End With
    oShp.Visible = msoFalse
    For i = oSld.Shapes.Count To 1 Step -1
        With oSld.Shapes(i)
            If .Tags("Split") = "y" Then
                .Select msoFalse
                .Tags.Delete ("Split")
            End If
        End With
    Next
hexit:
End Sub

动画组合添加形状

'动画组合添加形状
Sub bt_GroupAddShape()
    On Error GoTo hexit 'hexit:
    Dim oSld As Slide
    Dim oShp As Shape
    Dim oShp2 As Shape
    Dim hasFlash As Boolean
    Dim oName As String
    Dim i As Integer
    Set oSld = ActiveWindow.Selection.SlideRange(1)
    Set oShp = ActiveWindow.Selection.ShapeRange(1)
    Set oShp2 = ActiveWindow.Selection.ShapeRange(2)
    If oShp.Type = msoGroup Then
        If hasAnimation(oSld, oShp) Then
            oShp.PickupAnimation
            hasFlash = True
        End If
        oName = oShp.Name
        CommandBars.ExecuteMso ("ObjectsUngroup")
        oShp2.Select msoFalse
        CommandBars.ExecuteMso ("ObjectsGroup")
        With ActiveWindow.Selection.ShapeRange(1)
            .Name = oName
            If hasFlash = True Then
                 .ApplyAnimation
            End If
        End With
    End If
hexit:
End Sub

分离形状文本

'形状-分离形状文本
Sub bt_ShapeSeparateText()
    On Error GoTo hexit 'hexit:
    Dim oShp As Shape
    For Each oShp In ActiveWindow.Selection.ShapeRange
        If oShp.HasTextFrame Then
            If oShp.TextFrame.TextRange.Text <> "" Then
                With oShp.Duplicate
                    .Fill.Visible = msoFalse
                    .Line.Visible = msoFalse
                    .left = oShp.left
                    .top = oShp.top
                End With
                   oShp.TextFrame.TextRange.Text = ""
            End If
        End If
    Next
hexit:
End Sub

PPT插件萌新入门

PPT插件-动作手册

以下代码不需要懂，直接复制即可

文本动作

拆分多段

拆成多行

合并文字

拆分字符

动画组合添加形状

分离形状文本

更多动作