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