Wps自带的批量修改图片大小会导致图片像素降低，批量裁剪功能也感觉不好用，还需要会员。Vba虽说之前系统学习过，但用不上几次忘得一干二净，AI小助手文言一心、deepseek启动！写出来的代码多半能用，但经常会达不到想要的效果，多试几次，多结合几个不同的平台。

一、嵌入型图片与浮动型图片的区别

文档中除了嵌入型图片，其他的四周型环绕、紧密型环绕等都是浮动型图片。如果是浮动型图片，就可以通过开始>>选择>>选择窗格来批量选择图片，但是嵌入型就不行！其实类似于批量修改图片的操作只要能选中所有图片就很好办，所以我们只需要先把文档中所有嵌入型图片改为浮动型图片，改完后再变回浮动型图片。

二、安装Vba及运行代码

Word可以直接使用Vba，但Wps不行，需要额外安装一下。>下载链接：https://zhuanlan.zhihu.com/p/578753749

Sub 图片内嵌转浮动()
    Dim doc As Document
    Dim shp As InlineShape
    Dim convertedCount As Integer
    Dim errorLog As String
    convertedCount = 0
    errorLog = "以下图片转换失败：" & vbCrLf
    
    ' 获取当前文档对象
    Set doc = ActiveDocument
    
    ' 检查是否存在嵌入型图片
    If doc.InlineShapes.count = 0 Then
        MsgBox "文档中未发现嵌入型图片！", vbExclamation
        Exit Sub
    End If
    
    ' 倒序遍历避免集合动态变化
    For i = doc.InlineShapes.count To 1 Step -1
        Set shp = doc.InlineShapes(i)
        
        ' 尝试转换图片类型
        On Error Resume Next
        Dim newShape As Shape
        Set newShape = shp.ConvertToShape
        
        ' 检查转换是否成功
        If Not newShape Is Nothing Then
            ' 设置环绕属性（使用WPS兼容数值）
            newShape.WrapFormat.Type = 1  ' 四周型环绕
            newShape.RelativeHorizontalPosition = 0  ' 相对页面定位
            newShape.RelativeVerticalPosition = 0
            newShape.Top = CentimetersToPoints(5)  ' 初始位置
            newShape.Left = CentimetersToPoints(5)
            
            ' 记录成功转换
            convertedCount = convertedCount + 1
        Else
            ' 记录失败原因
            errorLog = errorLog & "- 图片 " & i & ": " & Err.Description & vbCrLf
        End If
        On Error GoTo 0
    Next i
    
    ' 结果反馈
    Dim resultMsg As String
    resultMsg = "成功转换 " & convertedCount & " 张嵌入型图片为浮动型！" & vbCrLf
    
    ' 处理错误日志
    If convertedCount < doc.InlineShapes.count Then
        resultMsg = resultMsg & errorLog
    End If
    
    MsgBox resultMsg, vbInformation
End Sub

' 辅助函数：厘米转磅
Function CentimetersToPoints(cm As Single) As Single
    CentimetersToPoints = cm * 28.35
End Function

Sub 图片浮动转内嵌()
    Dim shp As Shape
    Dim i As Integer
    ' 倒序遍历避免动态元素变化导致的跳过
    For i = ActiveDocument.Shapes.count To 1 Step -1
        Set shp = ActiveDocument.Shapes(i)
        If shp.Type = msoPicture Then
            shp.ConvertToInlineShape
        End If
    Next i
    MsgBox "所有图片已成功转换为嵌入型！"
End Sub

Sub 裁剪图片()
    Dim img As Shape
    ' 遍历文档中的所有形状对象（包括图片）
    For Each img In ActiveDocument.Shapes
        ' 判断该形状是否是图片
        If img.Type = msoPicture Then
            ' 开始设置裁剪值，单位是“磅”（Points）
            With img.PictureFormat
                .CropLeft = 10    ' 左侧裁剪10磅
                .CropRight = 10   ' 右侧裁剪10磅
                .CropTop = 10     ' 顶部裁剪10磅
                .CropBottom = 10  ' 底部裁剪10磅
            End With
        End If
    Next img
End Sub

三、对选择指定范围内的图片进行裁剪

进行多次试验，office和wps在嵌入型图片和浮动型图片一些适用范围上有所不同

测试代码：

Sub 裁剪选中图片_优化版()
    Dim shp As Shape
    Dim inlShp As InlineShape
    Dim count As Long
    Dim hasSelection As Boolean
    count = 0
    
    ' 更灵活的选中检测（兼容WPS）
    hasSelection = (ActiveWindow.Selection.Type <> wdSelectionNoSelection) And _
                   (ActiveWindow.Selection.Type <> wdSelectionIP)
    
    If Not hasSelection Then
        MsgBox "请先选中包含图片的内容（可拖动鼠标选择图片或图片+文字）！", vbExclamation
        Exit Sub
    End If
    
    ' 处理浮动图片（Shape）
    On Error Resume Next
    For Each shp In ActiveWindow.Selection.ShapeRange
        If shp.Type = msoPicture Then
            With shp.PictureFormat
                .CropLeft = 0
                .CropRight = 0
                .CropTop = 0  ' 1cm ≈ 28.35磅
                .CropBottom = 50
            End With
            count = count + 1
        End If
    Next shp
    On Error GoTo 0
    
    ' 处理嵌入图片（InlineShape）
    On Error Resume Next
    For Each inlShp In ActiveWindow.Selection.InlineShapes
        If inlShp.Type = wdInlineShapePicture Then
            With inlShp.PictureFormat
                .CropLeft = 0
                .CropRight = 0
                .CropTop = 30
                .CropBottom = 10
            End With
            count = count + 1
        End If
    Next inlShp
    On Error GoTo 0
    
    ' 结果反馈
    If count > 0 Then
        MsgBox "成功裁剪 " & count & " 张选中图片。", vbInformation
    Else
        MsgBox "选中的内容中未找到可裁剪的图片。", vbExclamation
    End If
End Sub