如何让Outlook默认自动压缩发送邮件中的图片（附件/HTML正文）？

一、通过Outlook内置选项设置（无需代码） #

1. 默认压缩附件中的图片 #

打开Outlook，依次点击「文件」>「选项」>「高级」，下拉找到「附件处理」区域，勾选**「自动压缩插入的图片」**（英文对应Automatically compress images in messages）。若要针对所有附件图片默认调整分辨率，点击「附件处理」旁的「图片大小和质量」按钮，在弹窗中选择默认分辨率（如「网页/屏幕」对应96dpi，压缩率最高），并勾选「所有新邮件中使用这些设置」。

2. 默认压缩正文HTML中的图片 #

上述「图片大小和质量」设置会同步应用到正文插入的图片。若要确保插入时自动压缩，可先点击「图片格式」选项卡的「压缩图片」，弹窗内勾选「删除图片的裁剪区域」和「应用于所有图片」，再点击「选项」勾选「插入时自动压缩图片」，后续插入正文的图片都会按设置自动压缩。

二、通过VBA脚本实现强制自动压缩（更彻底） #

如果内置选项无法满足自定义需求，可通过VBA在邮件发送前自动压缩所有图片：

1. 打开并配置VBA编辑器 #

按Alt + F11打开VBA编辑器，双击左侧「Project1」下的「ThisOutlookSession」，粘贴以下代码：

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim mail As MailItem
    Dim attachment As attachment
    Dim shp As Shape
    Dim inlineShp As InlineShape
    
    ' 仅处理邮件项
    If TypeName(Item) <> "MailItem" Then Exit Sub
    Set mail = Item
    
    ' 压缩正文HTML中的内嵌图片
    If mail.BodyFormat = olFormatHTML Then
        ' 处理嵌入式图片
        For Each inlineShp In mail.InlineShapes
            If inlineShp.Type = olPicture Then
                inlineShp.PictureFormat.Compress _
                    FileSize:=olCompressWeb, _
                    DeleteCroppedAreas:=True
            End If
        Next inlineShp
        ' 处理浮动图片
        For Each shp In mail.Shapes
            If shp.Type = msoPicture Then
                shp.PictureFormat.Compress _
                    FileSize:=olCompressWeb, _
                    DeleteCroppedAreas:=True
            End If
        Next shp
    End If
    
    ' 压缩附件中的图片（仅JPG/PNG格式）
    For Each attachment In mail.Attachments
        If LCase(Right(attachment.FileName, 4)) = ".jpg" Or _
           LCase(Right(attachment.FileName, 4)) = ".jpeg" Or _
           LCase(Right(attachment.FileName, 3)) = ".png" Then
            Dim tempPath As String
            tempPath = Environ("TEMP") & "\" & attachment.FileName
            attachment.SaveAsFile tempPath
            
            ' 压缩图片
            Dim img As Object
            Set img = CreateObject("WIA.ImageFile")
            img.LoadFile tempPath
            
            ' JPG质量设为70（可调整），PNG用默认压缩
            If LCase(Right(attachment.FileName, 3)) = "png" Then
                img.SaveFile tempPath
            Else
                img.SaveFile tempPath, 70
            End If
            
            ' 替换原附件
            mail.Attachments.Remove attachment.Index
            mail.Attachments.Add tempPath
            Kill tempPath
        End If
    Next attachment
    
    Set mail = Nothing
End Sub

2. 启用宏 #

• 保存代码后关闭VBA编辑器。
• 打开Outlook「文件」>「选项」>「信任中心」>「信任中心设置」>「宏设置」，选择「启用所有宏」或「通知我有关数字签署的宏的信息」，确定后重启Outlook即可生效。

注意事项 #

• 压缩附件时会临时保存图片到系统临时文件夹，发送后自动删除。
• 若代码报错，需在VBA编辑器中点击「工具」>「引用」，勾选「Microsoft Windows Image Acquisition Library v2.0」和「Microsoft Office xx.x Object Library」。

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