• 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
    

      

  • 相关阅读:
    hadoop学习--搜索引擎面临的数据和计算难题
    解析excel
    sql批量入库
    tomcat-nginx配置
    友链
    Vue+ElementUI搭建一个后台管理框架
    OnePill本地保存用户的结构
    Android集成JPush(极光推送)
    Android三种风格的底部导航栏
    Android实现EditText插入表情、超链接等格式
  • 原文地址:https://www.cnblogs.com/nextseven/p/12057929.html
Copyright © 2020-2023  润新知