Excel区域复制为图片后发送邮件无法保持缩放尺寸的问题

用户现有VBA代码如下，需修改或调整设置实现自动化需求：

Sub myemailSender()
        'Email Set up
        Email_Subject = "my_subject"
        Email_Send_To = "my_email"
        
        Set Mail_Object = CreateObject("Outlook.Application")
        Set Mail_Single = Mail_Object.CreateItem(0)
        
        With Mail_Single
         .Subject = Email_Subject
         .To = Email_Send_To
         .Display
        End With
        
        Application.CutCopyMode = False
        Sheets("Mysheet").Calculate
        Range("MyCopyRange").Copy
        Range("MyCopyRange").CopyPicture xlScreen, xlBitmap
        
        Const wdInlineShapePicture = 3
        Set wrdDoc = Mail_Single.GetInspector.WordEditor
        wrdDoc.Range.PasteAndFormat wdChartPicture
        For Each wrdShp In wrdDoc.InlineShapes
            If wrdShp.Type = wdInlineShapePicture Then
                ' Increase the scale to make the image larger
                wrdShp.ScaleHeight = 150 ' Adjust this value as needed
                wrdShp.ScaleWidth = 150  ' Adjust this value as needed
            End If
        Next
        Mail_Single.Send
        Application.Calculation = xlAutomatic
End Sub

1. 修改VBA代码，规避Outlook自动缩放逻辑 #

问题核心在于Outlook默认的图片压缩/缩放机制，以及原代码粘贴方式的兼容性问题。修改后的代码如下：

Sub myemailSender()
        Dim Email_Subject As String, Email_Send_To As String
        Dim Mail_Object As Object, Mail_Single As Object
        Dim wrdDoc As Object, wrdShp As Object
        
        'Email Set up
        Email_Subject = "my_subject"
        Email_Send_To = "my_email"
        
        Set Mail_Object = CreateObject("Outlook.Application")
        Set Mail_Single = Mail_Object.CreateItem(0)
        
        With Mail_Single
         .Subject = Email_Subject
         .To = Email_Send_To
         ' 设置邮件为HTML格式，降低Word编辑器的默认干扰
         .BodyFormat = 2 ' olFormatHTML
         .Display
        End With
        
        Application.CutCopyMode = False
        Sheets("Mysheet").Calculate
        ' 用xlPrinter参数复制图片，生成高分辨率版本，避免屏幕缩放影响
        Range("MyCopyRange").CopyPicture Appearance:=xlPrinter, Format:=xlBitmap
        
        Set wrdDoc = Mail_Single.GetInspector.WordEditor
        ' 关闭Word编辑器的自动图片压缩
        wrdDoc.Options.PictureFormat.PictureCompression = 0 ' wdCompressionNone
        wrdDoc.Range.Paste
        
        For Each wrdShp In wrdDoc.InlineShapes
            If wrdShp.Type = 3 Then ' wdInlineShapePicture
                ' 锁定宽高比，直接设置绝对尺寸（单位：磅，1英寸=72磅）
                wrdShp.LockAspectRatio = True
                wrdShp.Height = 450 ' 按需调整
                wrdShp.Width = 600   ' 按需调整
                ' 禁用单张图片的压缩设置
                wrdShp.PictureFormat.Compress = False
            End If
        Next
        
        Mail_Single.Send
        Application.Calculation = xlAutomatic
        ' 释放对象
        Set wrdShp = Nothing
        Set wrdDoc = Nothing
        Set Mail_Single = Nothing
        Set Mail_Object = Nothing
End Sub

关键修改说明： #

• 切换邮件格式为HTML，减少Word编辑器对图片的强制处理
• 使用xlPrinter复制图片，生成的图片分辨率更高，更难被自动缩放
• 直接设置图片绝对尺寸而非缩放比例，锁定宽高比保证显示效果
• 关闭Word编辑器和单张图片的自动压缩选项

2. 调整Outlook全局设置，彻底关闭自动压缩 #

若代码修改后仍存在问题，需手动配置Outlook全局设置：

• 打开Outlook，依次点击「文件」>「选项」>「邮件」
• 点击「编辑器选项」>「高级」>「图片大小和质量」
• 勾选「不压缩文件中的图片」，将「默认分辨率」设为「高保真」
• 保存设置后，Outlook将不再自动缩放或压缩插入的图片

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