在Word中，用VBA将选中内容替换为图片

Option Explicit

Dim 输出 As Double
Dim leftDistance As Double
Dim 公式边距  As Integer
Dim 原来高度 As Double

Sub 选中内容转图片()
    Dim j, k As Long
    Dim rng As Range
    Set rng = Selection.Range
    j = rng.Start
    k = rng.End
    
    '检查是否有选中内容
    If Selection.Type <> wdSelectionNormal Then
        MsgBox "请选中要处理的内容！"
        Exit Sub
    End If
    With Selection
        ' 前后插入换行符
        .SetRange Start:=k, End:=k
        .TypeParagraph '回车
        .SetRange Start:=j, End:=j
        .TypeParagraph '回车
        rng.Start = rng.Start + 1
        rng.Select
        
            原来高度 = 30
            
        Call 自动放大字体并转化为图片(15)
        
        Call 按比例调整选中的图片高度V10
        ActiveDocument.Range(j, j + 1).Delete
        ActiveDocument.Range(j + 1, j + 2).Delete
        ActiveDocument.Range(j, j + 1).Select
        
        .SetRange Start:=j, End:=j
        .ParagraphFormat.BaseLineAlignment = wdBaselineAlignCenter '段落中心对齐
    End With
    
End Sub


Sub 按比例调整选中的图片高度V10()
    Dim pic As InlineShape
    Dim ratio As Double
    Dim isVerticalSelection As Boolean
    Dim 高度0, 宽度0, 宽度1 As Double
    
    '检查是否有选中内容
    If Selection.InlineShapes.Count <> 1 Then
        MsgBox "请选中单个图片！"
        Exit Sub
    End If
    
    '获取选中的图片对象
    Set pic = Selection.InlineShapes(1)
    
    '获取宽高比例
    高度0 = pic.Height
    宽度0 = pic.Width
    ratio = 宽度0 / 高度0
    宽度1 = ratio * 原来高度
    '按比例调整宽度和高度
    If ratio <> 0 Then
        pic.Height = 原来高度
        pic.Width = 宽度1
    End If
End Sub


Function 自动放大字体并转化为图片(公式边距1 As Integer)
    
    Dim selRange As Range
    Dim NewFontSize As Double
    Dim i As Integer
    Set selRange = Selection.Range
    
    公式边距 = 公式边距1
    Selection.ParagraphFormat.Reset
    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
    
    Do
        i = i + 1
        Call 获取Word文档中选定区域与页面边缘的距离
        If leftDistance < 公式边距1 Or i >= 128 Then
            Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
            Call 选中公式转化图片
            Exit Do
        End If
        NewFontSize = Selection.Range.Font.Size
        
        输出 = leftDistance * 0.1
        If Abs(输出) < 0.5 Or leftDistance < 30 Then
            输出 = 0.5
        End If
'        Debug.Print "误差: " & Last误差 & " 第" & i & "次继续加大: " & 输出 & vbNewLine
        Selection.Range.Font.Size = NewFontSize + 输出
        Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
    Loop
    
    selRange.Delete

End Function

Function 获取Word文档中选定区域与页面边缘的距离()
    Dim sel As Range
    Dim topDistance As Single
    
    ' 获取当前选定区域
    Set sel = Selection.Range
    
    ' 获取选定区域左侧与页面左边缘的距离（以磅为单位）
    leftDistance = sel.Information(wdHorizontalPositionRelativeToPage) - sel.PageSetup.LeftMargin
    
    ' 获取选定区域顶部与页面顶部的距离（以磅为单位）
    topDistance = sel.Information(wdVerticalPositionRelativeToPage) - sel.PageSetup.TopMargin
    
    ' 显示距离（以磅为单位）
'    Debug.Print "左侧距离: " & leftDistance '& " 磅" & vbNewLine & _
        "顶部距离: " & topDistance & " 磅" & vbNewLine
End Function

Sub 选中公式转化图片()
        '转化为图片
        With Selection
            .CopyAsPicture
            .MoveRight Unit:=wdCharacter, Count:=1 ' 向右一位
            Call 延时秒(1)
            .PasteSpecial DataType:=wdPasteMetafilePicture
            .MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend ' 向前选中一位
        End With
End Sub
Sub 选中公式替换为图片()
        '转化为图片
        With Selection
            .CopyAsPicture
            Call 延时秒(1)
            .PasteSpecial DataType:=wdPasteMetafilePicture
        End With
End Sub


Function 延时秒(时长 As Single)
    Dim endTime As Double
    
    endTime = Timer + 时长
    
    Do While Timer < endTime
        ' 空循环等待
    Loop
    
    ' 在这里写下你要延时执行的代码
'    MsgBox "延时执行完成！"
End Function

代码还不够完善，比如不能自动获选中的高度，还有就是运行时，粘贴为图片的部分总是间歇性报错，点调试后继续运行有没有问题，需要的可以谨慎使用