pptvba指定自定义动画旋转中心

lss001

'PPT设置动画对象绕指定点旋转
'    第一种方法
'　　1.插入你需要的形状，设置好图形的样式（这里以三角形为例）
'　　2.复制一个形状，这样你会有两个一模一样的形状。把其中一个水平翻转，上下翻转，拖到一起。
'　　3.按住shift键分别选中这两个图形，在上面点击右键，在弹出的菜单中选中“组合”。
'　　4.这样，两个图形就组合成为了一个图形，其中心点也改变为两个图形的对称点。
'　　5.把其中一个图形的填充设置为“无填充”，线条设置为“无线条”，也就是让它透明。
'　　至此“大功告成”，看起来中心点已经改变了。后面你自己设置动画就行了。
'
'    第二种方法
'　　1.这种方法俗称“添圆法”。就是在原来已有图形的基础上添加一个圆，还是通过组合来改变图形中心的位置。下面以三角形为例。
'　　2.单击“插入”选项卡，在“插图”组中单击“形状”按钮，在打开的形状面板中选择“基本形状”中的“椭圆”。
'　　3.同时按着shift和Ctrl键，按鼠标左键在A点处向外拖动，绘制出一个覆盖三角形的以A点为圆心的正圆。
'　　4.同时选中三角形和绘制的覆盖三角形的正圆，把它们组合起来。
'　　5.选中组合图形中的圆形，设置“无轮廓”“无填充”。
'    其它和刚才讲的第一种方法一样了?


Sub 添圆法设置旋转中心点()
    Dim sld As slide, shpSquare As Shape, shpCircle As Shape
    Dim left As Single, top As Single, sideLength As Single
    Dim centerX As Single, centerY As Single

    ' 指定旋转中心点
    '中间点:x=left+sideLength/2=150,y=top+sideLength/2=150;
    '左上角:x=left=100,y=top=100;
    '右上角:x=left+sideLength=200,y=top=100;
    '左下角:x=left=100,y=top+sideLength=200;
    '右下角:x=left+sideLength=200,y=top+sideLength=200;
    centerX = 100 ' 指定中心点X坐标//左上角
    centerY = 100 ' 指定中心点Y坐标
    ' 设置幻灯片和正方形的参数
    Set sld = ActivePresentation.Slides(1)
    sideLength = 100 ' 磅
    left = 100 ' 起始X坐标
    top = 100 ' 起始Y坐标

    ' 添加正方形
    Set shpSquare = sld.Shapes.AddShape( _
        msoShapeRectangle, left, top, sideLength, sideLength)
    ' 添加圆形//辅助形状
    Set shpCircle = sld.Shapes.AddShape( _
        msoShapeOval, left, top, sideLength * 2, sideLength * 2)


    ' 设置圆形属性
    With shpCircle
        ' 这里使用白色，或根据背景设置相应颜色
        .Fill.ForeColor.RGB = RGB(255, 255, 255)
        .Fill.BackColor.RGB = RGB(255, 255, 255)
        .Line.Visible = False ' 无轮廓线
        .ZOrder msoSendToBack ' 置于底层
    End With


    ' 将辅助形状的中心点移动到指定的旋转中心
    offsetX = centerX - (shpSquare.left + shpSquare.Width)
    offsetY = centerY - (shpSquare.top + shpSquare.Height)
    shpCircle.left = shpCircle.left + offsetX
    shpCircle.top = shpCircle.top + offsetY

    ' 将原始形状组合到辅助形状上
    Set groupShape = ActivePresentation.Slides(1).Shapes.Range( _
        Array(shpCircle.Name, shpSquare.Name)).Group

    ' 将组合形状移动到辅助形状的位置，以便它们共享相同的中心点
    groupShape.left = shpCircle.left - (groupShape.Width - shpCircle.Width) / 2
    groupShape.top = shpCircle.top - (groupShape.Height - shpCircle.Height) / 2


'    ' 解组合形状并删除辅助形状
'    'groupShape.Ungroup
'    'shpCircle.Delete
End Sub

lss001

Sub 自定义旋转动画()
    Dim w, h, w1, h1 ' effRandom As Effect
    Dim bhvEffect1 As AnimationBehavior
    Dim aniPoint1 As AnimationPoint
    With ActivePresentation.Slides(1)
        'Set shp = ActiveWindow.Selection.ShapeRange(1)
        Set shp = ActivePresentation.Slides(1).Shapes(1)

        With .TimeLine.MainSequence.AddEffect( _
            Shape:=shp, effectId:=msoAnimEffectCustom) 'msoAnimEffectCustom自定义
            .Timing.RepeatCount = 3 '重复动画的次数//可用2 ^ 30表示无限次

            With .Behaviors(1)
                .SetEffect.Property = msoAnimVisibility '可见性
                .SetEffect.To = 1 '
            End With

            With .Behaviors.Add(msoAnimTypeMotion) 'msoAnimTypeMotion路径1
                .Accumulate = msoAnimAccumulateNone '与其他动画行为进行不累加
                .Additive = msoAnimAdditiveAddBase '不将当前动画与其他动画合并
'                .MotionEffect.ByX = 100
'                .MotionEffect.ByY = 100
'                .MotionEffect.FromX = 0
'                .MotionEffect.FromY = 0
'                .MotionEffect.ToX = 100
'                .MotionEffect.ToY = 100

'                Set slidp = ActivePresentation.PageSetup
'                w = slidp.SlideWidth '幻灯片宽度
'                h = slidp.SlideHeight '幻灯片高度
'                w1 = shp.Width '形状宽度
'                h1 = shp.Height '形状高度

                .MotionEffect.Path = "M 0 0 C 0 0 0 0 0 0 Z" '自定义路径
            End With

            With .Behaviors.Add(msoAnimTypeRotation) 'msoAnimTypeRotation旋转
                .Accumulate = msoAnimAccumulateNone '与其他动画行为进行不累加
                .Additive = msoAnimAdditiveAddBase '不将当前动画与其他动画合并

                .RotationEffect.By = 360 '0原地旋转，360顺时针绕圈，-360逆时针绕圈
'                .RotationEffect.From = 0
'                .RotationEffect.To = 360 'Form(转换前角度)配合To(转换后角度)表示转换角度
            End With

        End With
    End With
End Sub

自定义旋转中心.rar (48.71 KB, 下载次数: 18)

2024-5-25 14:23 上传

点击文件名下载附件

dongdonggege

看我的，PPT2003版

Sub 原地顺时针旋转() '
    'Dim effRandom As Effect
    Dim bhvEffect1 As AnimationBehavior
    Dim aniPoint1 As AnimationPoint
    Set sld = ActivePresentation.Slides(1)
    'Set shp = ActiveWindow.Selection.ShapeRange(1)
    Set shp = sld.Shapes.AddShape(msoShapeRectangle, 200, 200, 170, 60)
    Set effNew = sld.TimeLine.MainSequence.AddEffect(Shape:=shp, effectId:=msoAnimEffectCustom, trigger:=msoAnimTriggerWithPrevious) 'msoAnimEffectCustom自定义
   
    effNew.Timing.RepeatCount = 3
   
    'Debug.Print sld.TimeLine.MainSequence(1).Behaviors(2).MotionEffect.Path
   
    With effNew.Behaviors(1)
        .SetEffect.Property = msoAnimVisibility '可见性
        .SetEffect.To = 1 '
        
        .Timing.Accelerate = 0 '
        .Timing.AutoReverse = msoFalse '是否应该正向播放效果后再反向播放效果
        
        .Timing.Decelerate = 0 '减速过程持续时间的百分比
        .Timing.Duration = 0.001 '行为时间长度
        
        .Timing.RepeatCount = 1 '重复动画的次数
        .Timing.RepeatDuration = 0 '重复动作持续的时间动画时长
        
        .Timing.Restart = msoAnimEffectRestartNever '重新启动动画节点的动作
        .Timing.RewindAtEnd = msoFalse '效果结束后对象是否返回其开始位置
        .Timing.SmoothEnd = msoFalse '效果结束时是否减速
        .Timing.SmoothStart = msoFalse '效果启动时是否加速
        .Timing.Speed = 1 '速度
        .Timing.TriggerDelayTime = 0 '启用触发产生的延迟时间(以秒为单位)
    End With
   
    Set bhvEffect2 = effNew.Behaviors.Add(msoAnimTypeMotion) 'msoAnimTypeMotion路径1
    With bhvEffect2
        .Accumulate = msoAnimAccumulateNone '与其他动画行为进行不累加
        .Additive = msoAnimAdditiveAddBase '不将当前动画与其他动画合并
        
        .MotionEffect.ByX = 100
        .MotionEffect.ByY = 100
        .MotionEffect.FromX = 0
        .MotionEffect.FromY = 0
        .MotionEffect.Path = "M 0 0 C  0 0 -1.276567E-03 1.558454E-02 -4.563395E-03 3.063682E-02 C -4.563395E-03 3.063682E-02 -9.760624E-03 4.469938E-02 -1.671037E-02 5.734496E-02" & _
        " C -1.671037E-02 5.734496E-02 -2.520146E-02 6.818932E-02 -3.497586E-02 7.690305E-02 C -3.497586E-02 7.690305E-02 -4.573661E-02 8.322126E-02 -5.715671E-02 .0869521" & _
        " C -5.715671E-02 .0869521 -6.888924E-02 8.798212E-02 -8.057768E-02 8.628003E-02 C -8.057768E-02 8.628003E-02 -9.186685E-02 8.189759E-02 -.1024138 7.496796E-02" & _
        " C -.1024138 7.496796E-02 -.111898 6.570163E-02 -.1200312 5.438018E-02 C -.1200312 5.438018E-02 -.1265665 4.134765E-02 -.1313052 2.699997E-02" & _
        " C -.1313052 2.699997E-02 -.1341033 1.177317E-02 -.1348758 -3.870194E-03 C -.1348758 -3.870194E-03 -.1335993 -1.945476E-02 -.1303124 -3.450699E-02" & _
        " C -.1303124 -3.450699E-02 -.1251152 -4.856955E-02 -.1181655 -6.121515E-02 C -.1181655 -6.121515E-02 -.1096744 -7.205955E-02 -9.989997E-02 -8.077325E-02" & _
        " C -9.989997E-02 -8.077325E-02 -8.913922E-02 -8.709149E-02 -7.771911E-02 -9.082229E-02 C -7.771911E-02 -9.082229E-02 -6.598659E-02 -9.185231E-02 -5.429815E-02 -9.015025E-02" & _
        " C -5.429815E-02 -9.015025E-02 -4.300898E-02 -8.576779E-02 -3.246206E-02 -7.883812E-02 C -3.246206E-02 -7.883812E-02 -2.297787E-02 -6.957183E-02 -.0148446 -.0582504" & _
        " C -.0148446 -.0582504 -8.309301E-03 -4.521784E-02 -3.570599E-03 -.0308702 C -3.570599E-03 -.0308702 -7.725186E-04 -1.564337E-02 0 0 Z"

        .MotionEffect.ToX = 100
        .MotionEffect.ToY = 100
        
        .Timing.Accelerate = 0 '
        .Timing.AutoReverse = msoFalse '是否应该正向播放效果后再反向播放效果
        
        .Timing.Decelerate = 0 '减速过程持续时间的百分比
        .Timing.Duration = 5 '行为时间长度
        
        .Timing.RepeatCount = 1 '重复动画的次数
        .Timing.RepeatDuration = 0 '重复动作持续的时间动画时长
        
        .Timing.Restart = msoAnimEffectRestartNever '重新启动动画节点的动作
        .Timing.RewindAtEnd = msoFalse '效果结束后对象是否返回其开始位置
        .Timing.SmoothEnd = msoFalse '效果结束时是否减速
        .Timing.SmoothStart = msoFalse '效果启动时是否加速
        .Timing.Speed = 1 '速度
        .Timing.TriggerDelayTime = 0 '启用触发产生的延迟时间(以秒为单位)
    End With
        
    Set bhvEffect3 = effNew.Behaviors.Add(msoAnimTypeRotation) 'msoAnimTypeRotation旋转4
    With bhvEffect3
        .Accumulate = msoAnimAccumulateNone '与其他动画行为进行不累加
        .Additive = msoAnimAdditiveAddBase '不将当前动画与其他动画合并
        
        .RotationEffect.By = 360 '0原地旋转，360绕圈。
        .RotationEffect.From = 0
        .RotationEffect.To = 360 '有变化
        
        .Timing.Accelerate = 0 '
        .Timing.AutoReverse = msoFalse '是否应该正向播放效果后再反向播放效果
        
        .Timing.Decelerate = 0 '减速过程持续时间的百分比
        .Timing.Duration = 5 '行为时间长度
        
        .Timing.RepeatCount = 1 '重复动画的次数
        .Timing.RepeatDuration = 0 '重复动作持续的时间动画时长
        
        .Timing.Restart = msoAnimEffectRestartNever '重新启动动画节点的动作
        .Timing.RewindAtEnd = msoFalse '效果结束后对象是否返回其开始位置
        .Timing.SmoothEnd = msoFalse '效果结束时是否减速
        .Timing.SmoothStart = msoFalse '效果启动时是否加速
        .Timing.Speed = 1 '速度
        .Timing.TriggerDelayTime = 0 '启用触发产生的延迟时间(以秒为单位)
    End With
End Sub

dongdonggege

这个旋转是有一个系列的，比如以左边为中心的旋转，以右边为中心的旋转，以上边为中心的旋转，以下边为中心的旋转，顺时针旋转，逆时针旋转，绕圈旋转。
我只研究成功，以左边为中心的旋转，以下边为中心的旋转，绕圈旋转三类。

dongdonggege

老师你好，向你请教！
我改编了lee1892老师的作品，把Excel改成ppt2003，已经成功。《美丽的数学之珍珠项链》27楼，https://club.excelhome.net/forum.php?mod=redirect&goto=findpost&ptid=1157988&pid=8387090。总体很像了，但是他是按照从一个方向到另一个方向，而我的四面八方同时画，方向不同。而且我的第二个参数，aPnts(1, 1) 向aPnts(1, 2) 画，然后aPnts(2, 1) 向aPnts(2, 2) ， ……一直到aPnts(30000, 1) 向aPnts(30000,2)。。再开始aPnts(1, 3) 向aPnts(1, 4) 画，然后aPnts(2, 3) 向aPnts(2, 4) 画，我是这样推测的。请老师帮助修改。
截图不完整。

lss001

请参考一下附件代码！
珍珠项链.zip (195.7 KB, 下载次数: 5)

2024-11-9 19:58 上传

点击文件名下载附件