PPT宏代码

以下代码适用于：当每张幻灯片由一张图制作，快速统一图片格式。

1、将所有ppt中所有幻灯片中的图更改为宽度34cm，固定纵横比

Sub ResizeAllPictures()
    Dim sld As Slide
    Dim shp As Shape
    Dim targetWidth As Single
    Dim aspectRatio As Single
    
    ' 设置目标宽度为34厘米
    ' 1厘米 = 28.34646磅 (Points)，这是PowerPoint内部单位
    targetWidth = 34 * 28.34646
    
    ' 遍历所有幻灯片
    For Each sld In ActivePresentation.Slides
        ' 遍历幻灯片中的所有形状
        For Each shp In sld.Shapes
            ' 判断形状是否为图片
            If shp.Type = msoPicture Then
                ' 计算当前图片的宽高比
                aspectRatio = shp.Height / shp.Width
                
                ' 设置宽度为34厘米（转换为磅值）
                shp.Width = targetWidth
                
                ' 根据原始宽高比设置高度
                shp.Height = targetWidth * aspectRatio
            End If
        Next shp
    Next sld
    
    MsgBox "已将所有图片宽度设置为34厘米，并保持纵横比！", vbInformation, "操作完成"
End Sub

2、将ppt所有幻灯片中的图片使用代码一键上下居中、左右居中

Sub CenterAllPicturesEnhanced()
    Dim sld As Slide
    Dim shp As Shape
    Dim slideWidth As Single
    Dim slideHeight As Single
    Dim picCount As Integer
    Dim originalAspectRatio As Boolean
    
    On Error GoTo ErrorHandler
    
    picCount = 0
    
    ' 遍历所有幻灯片
    For Each sld In ActivePresentation.Slides
        slideWidth = sld.Master.Width
        slideHeight = sld.Master.Height
        
        ' 遍历幻灯片中的所有形状
        For Each shp In sld.Shapes
            ' 检查形状是否为图片且可见
            If shp.Type = msoPicture And shp.Visible Then
                ' 保存原始纵横比设置
                originalAspectRatio = shp.LockAspectRatio
                ' 确保纵横比锁定，防止图片变形
                shp.LockAspectRatio = msoTrue
                
                ' 计算居中位置:cite[1]
                shp.Left = (slideWidth - shp.Width) / 2
                shp.Top = (slideHeight - shp.Height) / 2
                
                ' 恢复原始纵横比设置
                shp.LockAspectRatio = originalAspectRatio
                
                picCount = picCount + 1
            End If
        Next shp
    Next sld
    
    If picCount > 0 Then
        MsgBox "成功将 " & picCount & " 张图片在各自幻灯片中居中对齐。", vbInformation, "操作完成"
    Else
        MsgBox "未在演示文稿中找到任何图片。", vbExclamation, "提示"
    End If
    
    Exit Sub
    
ErrorHandler:
    MsgBox "发生错误：" & Err.Description, vbCritical, "错误"
End Sub