如何用VBA计算PowerPoint中3D模型外包长方体底部中心坐标

需求背景 #

需要在PowerPoint中计算任意3D形状外包长方体底部面的中心X、Y坐标，用于元素对齐操作，支持批量处理。已知目标形状基础参数：Left=100pt、Top=50pt，2D宽度300px、高度215pt，可访问形状的.Model3D和.ThreeD对象。

实现思路 #

• 准备三个同模型形状：目标形状、正面视角参考形状、俯视视角参考形状
• 通过参考形状获取外包长方体的真实Width、Height、Depth参数
• 结合目标形状的RotationX旋转角度，利用三角函数计算2D平面上的坐标偏移量
• 计算底部中心坐标并绘制标记点

VBA代码实现 #

Dim sld             As PowerPoint.Slide
Dim shp             As PowerPoint.Shape
Dim vShpTgt         As Variant

Dim dbLeft          As Double
Dim dbTop           As Double

Dim dbWidth         As Double
Dim dbHeight        As Double
Dim dbDepth         As Double

Dim dbAngleX        As Double
Dim dbAngleY        As Double
Dim dbAngleZ        As Double
Dim dbOpp           As Double
Dim dbAdj           As Double
Dim dbHyp           As Double

Dim dbOffsetBackY   As Double
Dim dbOffsetBackH   As Double
Dim dbOffsetFrontY  As Double

Dim dbOffsetSpotX   As Double
Dim dbOffsetSpotY   As Double

Dim iShp            As Integer

Set sld = ActivePresentation.Slides(1)

' 删除临时测试形状
For iShp = sld.Shapes.Count To 1 Step -1
    If Left(sld.Shapes(iShp).Name, 7) = "shpTemp" Then
        sld.Shapes(iShp).Delete
    End If
Next

' 引用目标3D形状（需用Variant类型访问.Model3D属性）
Set vShpTgt = sld.Shapes("modTarget")
dbLeft = vShpTgt.Left
dbTop = vShpTgt.Top

' 通过参考形状获取外包长方体尺寸
' modFront：正面视角的同模型形状，用于获取Width、Height
' modAbove：俯视视角的同模型形状，用于获取Depth
dbWidth = sld.Shapes("modFront").Width ' 最终未使用，直接取目标形状宽度中点已满足需求
dbHeight = sld.Shapes("modFront").Height
dbDepth = sld.Shapes("modAbove").Height

' 获取目标形状的旋转参数
dbAngleX = vShpTgt.Model3D.RotationX
dbAngleY = vShpTgt.Model3D.RotationY ' 最终未使用
dbAngleZ = vShpTgt.Model3D.RotationZ ' 最终未使用

' 计算长方体背面在Y轴的偏移量
dbOffsetBackY = -1 * (dbHeight - (Sin(Deg2Rad(90 - dbAngleX)) * dbHeight))

' 计算长方体背面在2D平面上的有效高度
dbOffsetBackH = dbHeight + dbOffsetBackY

' 计算长方体正面顶部边缘因X轴旋转产生的Y轴偏移
dbOffsetFrontY = Sin(Deg2Rad(dbAngleX)) * dbDepth

' 计算底部中心X坐标：直接取目标形状宽度的中点
dbOffsetSpotX = dbLeft + (vShpTgt.Width / 2)

' 计算底部中心Y坐标：结合顶部位置、背面高度偏移和正面边缘偏移
dbOffsetSpotY = dbTop + dbOffsetBackH + (dbOffsetFrontY / 2)

' 绘制黄色圆形标记底部中心位置
Set shp = sld.Shapes.AddShape(msoShapeOval, dbOffsetSpotX - 5, dbOffsetSpotY - 5, 10, 10)
shp.Name = "shpTempSpot"
shp.Fill.Solid
shp.Fill.ForeColor.RGB = RGB(192, 192, 0)
shp.Line.Visible = False
shp.ZOrder msoBringToFront

' 释放对象
Set shp = Nothing
Set vShpTgt = Nothing
Set sld = Nothing

注：代码中调用的Deg2Rad函数需自行实现，用于将角度转换为弧度，示例代码如下：

Function Deg2Rad(deg As Double) As Double
    Deg2Rad = deg * Application.WorksheetFunction.Pi() / 180
End Function

方案说明 #

• 该方案通过参考形状规避了直接读取.Model3D属性无法获取真实外包尺寸的问题
• 仅基于RotationX计算Y轴偏移，X轴直接取目标形状宽度中点，在多数对齐场景下精度足够
• 代码自动清理历史临时标记，保持幻灯片整洁
• 可扩展支持批量处理：遍历幻灯片中的目标形状，重复执行坐标计算和标记逻辑

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