调整从Excel复制到Outlook邮件的单元格区域图片尺寸

一、尺寸无法调整的问题分析与修复 #

你的代码存在几个关键问题导致尺寸设置无效、宽高比无法解锁：

1. 冗余的Excel图片生成步骤：先将区域粘贴为Excel图片再剪切，完全没必要，反而可能丢失原始格式信息。
2. 未定义的常量问题：wdChartPicture和msoFalse是Office对象库的常量，晚绑定场景下未定义会被当作0值，导致pasteandFormat和LockAspectRatio设置失效。
3. HTMLBody覆盖问题：最后用.HTMLBody = 前缀 & .HTMLBody会重新渲染邮件内容，之前设置的图片尺寸可能被重置。

修正后的代码（解决尺寸调整） #

Dim OutApp2 As Object
Dim OutMail2 As Object
Dim table2 As Range
Dim ws2 As Worksheet
Dim WordDoc2 As Object
Dim name As String

' 定义晚绑定所需的常量（避免引用库）
Const wdChartPicture As Long = 10
Const msoFalse As Long = 0
Const olSave As Long = 0

Set OutApp2 = CreateObject("Outlook.Application")
Set OutMail2 = OutApp2.CreateItem(0)

Set ws2 = ThisWorkbook.Sheets("ISK VS OSA Chart")
Set table2 = ws2.Range("E1:Ab34")
name = slItem2.name

With OutMail2
    .Subject = name & " Score Card"
    .Display ' 必须先Display才能获取WordEditor
    
    Set WordDoc2 = .GetInspector.WordEditor
    
    ' 先写入前缀文本，再粘贴图片，避免HTMLBody覆盖问题
    With WordDoc2.Range
        .Text = "Hi Team," & vbCrLf & vbCrLf & "Please see the table below:" & vbCrLf & vbCrLf
        .Collapse Direction:=1 ' 光标移到文本末尾
        table2.Copy ' 直接复制Excel区域
        .PasteAndFormat Type:=wdChartPicture
        ' 定位到刚粘贴的形状，解锁宽高比并调整尺寸
        With .ShapeRange(1)
            .LockAspectRatio = msoFalse
            .Width = 600 ' 根据需求设置宽度
            .Height = 400 ' 根据需求设置高度
        End With
        .InsertParagraphAfter ' 图片后换行
    End With
    
    .Save
    .Close (olSave)
End With

' 释放对象
Set WordDoc2 = Nothing
Set OutMail2 = Nothing
Set OutApp2 = Nothing
Set table2 = Nothing
Set ws2 = Nothing

二、拆分大区域为多张独立图片插入 #

如果原区域过大，可按行或列拆分多个子区域，逐个复制粘贴到邮件中。以下示例按每15行拆分区域：

Dim OutApp2 As Object
Dim OutMail2 As Object
Dim ws2 As Worksheet
Dim totalRows As Long, splitRow As Long, startRow As Long, endRow As Long
Dim WordDoc2 As Object
Dim name As String

Const wdChartPicture As Long = 10
Const msoFalse As Long = 0
Const olSave As Long = 0

Set OutApp2 = CreateObject("Outlook.Application")
Set OutMail2 = OutApp2.CreateItem(0)

Set ws2 = ThisWorkbook.Sheets("ISK VS OSA Chart")
totalRows = ws2.Range("E1:Ab34").Rows.Count
splitRow = 15 ' 每15行拆分为一张图
name = slItem2.name

With OutMail2
    .Subject = name & " Score Card"
    .Display
    
    Set WordDoc2 = .GetInspector.WordEditor
    
    ' 写入前缀文本
    With WordDoc2.Range
        .Text = "Hi Team," & vbCrLf & vbCrLf & "Please see the split tables below:" & vbCrLf & vbCrLf
        .Collapse Direction:=1
    End With
    
    ' 循环拆分区域并插入图片
    startRow = 1
    Do While startRow <= totalRows
        endRow = startRow + splitRow - 1
        If endRow > totalRows Then endRow = totalRows
        
        ' 复制当前子区域
        ws2.Range("E" & startRow & ":Ab" & endRow).Copy
        
        ' 粘贴到邮件
        With WordDoc2.Range
            .Collapse Direction:=1
            .PasteAndFormat Type:=wdChartPicture
            With .ShapeRange(1)
                .LockAspectRatio = msoFalse
                .Width = 600
                .Height = 250 ' 对应拆分后的行高调整
            End With
            .InsertParagraphAfter
            .InsertParagraphAfter ' 图片之间加空行
        End With
        
        startRow = endRow + 1
    Loop
    
    .Save
    .Close (olSave)
End With

' 释放对象
Set WordDoc2 = Nothing
Set OutMail2 = Nothing
Set OutApp2 = Nothing
Set ws2 = Nothing

关键注意点 #

• 必须先调用.Display才能获取WordEditor，否则会报错。
• 晚绑定场景下务必手动定义所需常量，避免因未引用库导致的数值错误。
• 先写入文本再粘贴图片，避免使用HTMLBody拼接时重置图片格式。

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