PowerPoint VBA如何获取沿运动路径移动的形状的当前位置？

PPT对象模型里的Shape.Top和Shape.Left是设计时静态属性，动画运行时不会自动更新为当前渲染位置，也没有直接暴露实时状态的内置属性。下面提供两种可行的解决方案：

方法一：解析运动路径+缓动函数计算位置 #

通过解析自定义路径的顶点数据，结合动画进度和缓动规则计算当前位置，精度较高，适合程序化控制。

核心代码示例 #

' 获取形状当前动画位置并生成新形状
Sub SpawnShapeAtCrosshair()
    Dim targetSlide As Slide
    Dim crosshairSh As Shape
    Dim animEffect As Effect
    Dim motionBehavior As Behavior
    Dim motionPath As MotionEffect
    Dim animProgress As Double
    Dim currentPos As Variant
    
    Set targetSlide = ActiveWindow.View.Slide
    Set crosshairSh = targetSlide.Shapes("十字准线") ' 替换为你的形状名称
    
    ' 找到十字准线的自定义路径动画
    For Each animEffect In targetSlide.TimeLine.MainSequence
        If animEffect.Shape Is crosshairSh Then
            Set motionBehavior = animEffect.Behaviors(1)
            If motionBehavior.Type = msoAnimTypeMotion Then
                Set motionPath = motionBehavior.MotionEffect
                
                ' 计算动画进度（已流逝时间/总时长）
                animProgress = animEffect.Timing.ElapsedTime / animEffect.Timing.Duration
                ' 应用缓动规则修正进度
                animProgress = ApplyEasing(animProgress, motionBehavior.Timing.Easing)
                
                ' 解析路径并计算当前位置
                currentPos = CalculateCurrentPathPosition(crosshairSh, motionPath.Path, animProgress)
                
                ' 在当前位置生成新形状（示例：椭圆形）
                targetSlide.Shapes.AddShape msoShapeOval, _
                    currentPos(0), currentPos(1), 10, 10 ' 最后两个参数是形状宽高
                
                Exit Sub
            End If
        End If
    Next
End Sub

' 应用PPT内置缓动规则修正进度
Function ApplyEasing(progress As Double, easingType As MsoAnimEasingType) As Double
    Select Case easingType
        Case msoAnimEasingLinear
            ApplyEasing = progress
        Case msoAnimEasingEaseInQuad
            ApplyEasing = progress * progress
        Case msoAnimEasingEaseOutQuad
            ApplyEasing = 1 - (1 - progress) * (1 - progress)
        Case msoAnimEasingEaseInOutQuad
            If progress < 0.5 Then
                ApplyEasing = 2 * progress * progress
            Else
                ApplyEasing = 1 - 2 * (1 - progress) * (1 - progress)
            End If
        ' 可根据需求添加更多缓动类型实现
        Case Else
            ApplyEasing = progress
    End Select
End Function

' 解析路径并计算当前位置
Function CalculateCurrentPathPosition(baseSh As Shape, pathStr As String, progress As Double) As Variant
    Dim pathPoints As Collection
    Dim parts() As String
    Dim i As Integer
    Dim x As Double, y As Double
    Dim totalLength As Double
    Dim segmentLengths() As Double
    Dim currentLength As Double
    Dim segmentProgress As Double
    
    Set pathPoints = New Collection
    parts = Split(pathStr, " ")
    
    ' 解析路径字符串（仅处理直线段M/L命令，如需曲线需扩展）
    For i = 0 To UBound(parts)
        If InStr(parts(i), ",") > 0 Then
            x = Val(Split(parts(i), ",")(0))
            y = Val(Split(parts(i), ",")(1))
            pathPoints.Add Array(x, y)
        End If
    Next
    
    ' 计算路径总长度和各段长度
    If pathPoints.Count < 2 Then
        CalculateCurrentPathPosition = Array(baseSh.Left, baseSh.Top)
        Exit Function
    End If
    
    ReDim segmentLengths(1 To pathPoints.Count - 1)
    totalLength = 0
    For i = 1 To pathPoints.Count - 1
        segmentLengths(i) = Sqr((pathPoints(i + 1)(0) - pathPoints(i)(0)) ^ 2 + _
                                (pathPoints(i + 1)(1) - pathPoints(i)(1)) ^ 2)
        totalLength = totalLength + segmentLengths(i)
    Next
    
    ' 定位当前进度对应的线段
    currentLength = 0
    For i = 1 To UBound(segmentLengths)
        If currentLength + segmentLengths(i) >= progress * totalLength Then
            segmentProgress = (progress * totalLength - currentLength) / segmentLengths(i)
            x = baseSh.Left + pathPoints(i)(0) + segmentProgress * (pathPoints(i + 1)(0) - pathPoints(i)(0))
            y = baseSh.Top + pathPoints(i)(1) + segmentProgress * (pathPoints(i + 1)(1) - pathPoints(i)(1))
            CalculateCurrentPathPosition = Array(x, y)
            Exit Function
        End If
        currentLength = currentLength + segmentLengths(i)
    Next
    
    ' 进度为1时返回路径终点
    CalculateCurrentPathPosition = Array(baseSh.Left + pathPoints(pathPoints.Count)(0), _
                                        baseSh.Top + pathPoints(pathPoints.Count)(1))
End Function

注意事项 #

• 代码默认处理直线段路径，如需支持贝塞尔曲线（C命令），需补充贝塞尔曲线点的计算逻辑。
• 缓动函数仅实现了几种常见类型，可根据PPT内置的MsoAnimEasingType枚举扩展其他类型。

方法二：通过Windows API捕获屏幕位置 #

直接获取形状在屏幕上的显示坐标，再转换为幻灯片内部坐标，适合快速实现，精度受窗口缩放和分辨率影响。

核心代码示例 #

Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type POINTAPI
    X As Long
    Y As Long
End Type

' 获取形状当前屏幕位置并转换为幻灯片坐标
Function GetShapeRenderPosition(targetSh As Shape) As Variant
    Dim pptWnd As Window
    Dim pptHwnd As LongPtr
    Dim slideRect As RECT
    Dim shapeScreenPos As POINTAPI
    Dim slideClientPos As POINTAPI
    Dim scaleX As Double, scaleY As Double
    Dim slideWidthPix As Double, slideHeightPix As Double
    
    Set pptWnd = Application.ActiveWindow
    pptHwnd = pptWnd.hwnd
    
    ' 获取PPT窗口和幻灯片显示区域尺寸
    GetWindowRect pptHwnd, slideRect
    slideWidthPix = pptWnd.View.Slide.Width * 96 / 72 ' 英寸转像素（96DPI）
    slideHeightPix = pptWnd.View.Slide.Height * 96 / 72
    scaleX = (slideRect.Right - slideRect.Left) / slideWidthPix
    scaleY = (slideRect.Bottom - slideRect.Top) / slideHeightPix
    
    ' 计算形状中心的屏幕坐标
    shapeScreenPos.X = slideRect.Left + (targetSh.Left * 96 / 72 + targetSh.Width / 2 * 96 / 72) * scaleX
    shapeScreenPos.Y = slideRect.Top + (targetSh.Top * 96 / 72 + targetSh.Height / 2 * 96 / 72) * scaleY
    
    ' 转换为幻灯片客户区坐标
    ScreenToClient pptHwnd, shapeScreenPos
    
    ' 转换回幻灯片英寸坐标
    Dim currentLeft As Double, currentTop As Double
    currentLeft = (shapeScreenPos.X / scaleX) * 72 / 96 - targetSh.Width / 2
    currentTop = (shapeScreenPos.Y / scaleY) * 72 / 96 - targetSh.Height / 2
    
    GetShapeRenderPosition = Array(currentLeft, currentTop)
End Function

' 使用示例：生成新形状
Sub SpawnShapeAtRenderPosition()
    Dim targetSlide As Slide
    Dim crosshairSh As Shape
    Dim currentPos As Variant
    
    Set targetSlide = ActiveWindow.View.Slide
    Set crosshairSh = targetSlide.Shapes("十字准线")
    
    currentPos = GetShapeRenderPosition(crosshairSh)
    targetSlide.Shapes.AddShape msoShapeOval, currentPos(0), currentPos(1), 10, 10
End Sub

注意事项 #

• 需确保PPT窗口处于激活状态，且形状完全显示在屏幕内，否则坐标转换会出错。
• 依赖系统DPI设置（代码默认96DPI），非标准DPI环境需调整转换系数。

内容的提问来源于stack exchange，提问作者Timothy Ryan