xxxxxxx

Sub AddConnector(ByVal sld As Slide, ByVal beginshp As Shape, ByVal endshp As Shape, ByVal curshp As Shape, ByVal CnnType As MsoConnectorType, _
        Optional SelectLastShape As Boolean = True, Optional order As OrderType = AfterSibling, Optional SingleLine As Boolean = False)
 
    On Error Resume Next
    Set sld = Application.ActiveWindow.Selection.SlideRange(1)
    Dim cshp As Shape
    Dim insertPos As Long
    Dim oneshp  As Shape
    Dim cnFormat As ConnectorFormat
    For Each oneshp In sld.Shapes
        If oneshp.AutoShapeType = -2 Then
            If oneshp.ConnectorFormat.BeginConnectedShape.Name = beginshp.Name And _
                oneshp.ConnectorFormat.EndConnectedShape.Name = endshp.Name Then
                vbresult = MsgBox("当前选定节点已存在连接符，是否覆盖？", vbYesNo, "覆盖提示")
                If vbresult = vbYes Then
                    oneshp.Delete
                End If
            End If
        End If
    Next oneshp
    Set cshp = sld.Shapes.AddConnector(CnnType, 0, 0, 0, 0)
    Set cnFormat = cshp.ConnectorFormat
    With cnFormat
        .BeginConnect beginshp, 1
        .EndConnect endshp, 1
        .Parent.RerouteConnections
        .Parent.Line.ForeColor.RGB = RGB(0, 112, 192)
        .Parent.Line.Weight = 1
    End With
    Dim eff As Effect
    If AutoAction Then
        For Each eff In sld.TimeLine.MainSequence
            If eff.Shape.Name = cshp.Name Or eff.Shape.Name = endshp.Name Then
                eff.Delete
            End If
        Next eff
        '计算动画添加位置
        Dim hasSibling As Boolean
        hasSibling = False
        For Each eff In sld.TimeLine.MainSequence
            If eff.Shape.AutoShapeType = -2 Then '找到连接符动画的位置
                If eff.Shape.ConnectorFormat.BeginConnectedShape.Name = beginshp.Name Then
                    hasSibling = True
                End If
            End If
        Next eff
        '后添加的必须在同层次的最后
        lastPos = sld.TimeLine.MainSequence.Count + 1 '设置初始位置
        insertPos = lastPos
        If hasSibling Then
            Set dic = CreateObject("scripting.dictionary")
            Set dRest = CreateObject("scripting.dictionary")
            Call GetDecendants(curshp)
            Index = 0
            For Each eff In sld.TimeLine.MainSequence
                Index = Index + 1
                If eff.Shape.AutoShapeType <> -2 Then
                    If order = AfterSibling Then
                        'If eff.Shape.Name = curshp.Name Then
                        If dic.exists(eff.Shape.Name) Then
                            insertPos = Index + 1
                        End If
                    Else
                        If eff.Shape.Name = curshp.Name Then
                            insertPos = Index - 1
                            Exit For
                        End If
                    End If
                End If
            Next eff
            Debug.Print "HasSiblings", "insertPos", insertPos
            Set dRest = Nothing
            Set dic = Nothing
        Else
            Index = 0
            For Each eff In sld.TimeLine.MainSequence
                Index = Index + 1
                If eff.Shape.AutoShapeType <> -2 Then
                    If eff.Shape.Name = beginshp.Name Then
                        insertPos = Index + 1
                        'Debug.Print , "insertPos", insertPos
                        Exit For
                    End If
                End If
            Next eff
            Debug.Print "HasNoSibling", "insertPos", insertPos
        End If
        sld.TimeLine.MainSequence.AddEffect cshp, msoAnimEffectAppear, msoAnimationLevelNone, msoAnimTriggerOnPageClick, insertPos
        'Stop
        sld.TimeLine.MainSequence.AddEffect endshp, msoAnimEffectAppear, msoAnimationLevelNone, msoAnimTriggerAfterPrevious, insertPos + 1
    End If
    If SelectLastShape Then endshp.Select
    If SingleLine Then Call AutoSizeShapeToFitText
End Sub

Sub GetDecendants(ByVal curshp As Shape)
    On Error Resume Next
    Dim shp As Shape, oneshp As Shape
    Dim pre As Presentation, sld As Slide
    Set pre = Application.ActivePresentation
    Set sld = Application.ActiveWindow.Selection.SlideRange(1)
    'Set shp = Application.ActiveWindow.Selection.ShapeRange(1)
    'Set dic = CreateObject("scripting.dictionary")
    'Set dRest = CreateObject("scripting.dictionary")
    For Each oneshp In sld.Shapes
        If oneshp.Name <> curshp.Name Then
            dRest(oneshp.Name) = ""
        End If
    Next
    If curshp.AutoShapeType <> -2 Then
        dic(curshp.Name) = "Shp1"
        Level = 0
        FindDecendant dic
    End If
 
    '添加操作
    'Set dRest = Nothing
    'Set dic = Nothing
End Sub