Excel VBA粘贴表格至Outlook邮件放大致打印分页问题求助

方法1：通过Word对象模型控制邮件正文表格宽度 #

Outlook邮件正文基于Word编辑器，直接操作Word对象可精准调整粘贴后的表格尺寸，确保适配打印页面。

修改后的VBA代码如下：

Sub CopyRangeToOutlookEmail()
    Dim olApp As Object
    Dim olMail As Object
    Dim wdDoc As Object
    Dim rngCopy As Range
    
    ' 设置要复制的Excel区域，替换为你的目标区域
    Set rngCopy = ThisWorkbook.Sheets("Sheet1").Range("A1:G20")
    
    ' 创建Outlook邮件
    Set olApp = CreateObject("Outlook.Application")
    Set olMail = olApp.CreateItem(0)
    
    With olMail
        .To = "recipient@example.com" ' 替换为实际收件人
        .Subject = "邮件主题"
        .Display ' 必须先显示邮件才能获取Word编辑器
        
        ' 获取邮件的Word文档对象
        Set wdDoc = .GetInspector.WordEditor
        
        ' 复制Excel区域
        rngCopy.Copy
        
        ' 粘贴并保留源格式
        wdDoc.Range.PasteAndFormat Type:=16 ' 对应wdFormatOriginalFormatting
        
        ' 调整粘贴后的表格尺寸
        If wdDoc.Tables.Count > 0 Then
            With wdDoc.Tables(1)
                ' 设置表格宽度为页面的95%（预留边距）
                .PreferredWidthType = 2 ' 对应wdPreferredWidthPercent
                .PreferredWidth = 95
                ' 自动适配窗口宽度
                .AutoFitBehavior 2 ' 对应wdAutoFitWindow
            End With
        End If
        
        ' 清除剪贴板
        Application.CutCopyMode = False
    End With
    
    ' 释放对象
    Set olApp = Nothing
    Set olMail = Nothing
    Set wdDoc = Nothing
    Set rngCopy = Nothing
End Sub

方法2：转为图片粘贴（无需编辑场景） #

如果不需要邮件正文中的内容可编辑，直接将Excel区域转为图片粘贴，能完美保留原尺寸：

Sub CopyRangeAsImageToOutlook()
    Dim olApp As Object
    Dim olMail As Object
    Dim rngCopy As Range
    
    Set rngCopy = ThisWorkbook.Sheets("Sheet1").Range("A1:G20")
    
    ' 将区域复制为图片
    rngCopy.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    
    Set olApp = CreateObject("Outlook.Application")
    Set olMail = olApp.CreateItem(0)
    
    With olMail
        .To = "recipient@example.com"
        .Subject = "图片格式邮件"
        .Display
        
        ' 粘贴图片并保持原始尺寸
        .GetInspector.WordEditor.Range.Paste
        With .GetInspector.WordEditor.InlineShapes(1)
            .ScaleHeight = 100
            .ScaleWidth = 100
        End With
    End With
    
    Application.CutCopyMode = False
    Set olApp = Nothing
    Set olMail = Nothing
    Set rngCopy = Nothing
End Sub

方法3：复制前调整Excel打印缩放 #

若坚持直接粘贴，可先在Excel中设置区域的打印缩放规则，让Outlook继承适配比例：
在复制代码前添加以下片段：

' 设置目标工作表的打印缩放为1页宽
rngCopy.Parent.PageSetup.FitToPagesWide = 1
rngCopy.Parent.PageSetup.FitToPagesTall = False

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