如何在循环遍历多个内网URL时将所有表格截图粘贴至同一Outlook邮件

你的问题核心是每次循环都在创建新的Outlook邮件对象，所以每张截图都会被放到新邮件里。只需要把邮件的初始化逻辑移到循环外面，循环内只做截图粘贴的操作就可以了。

这里是修改后的完整代码：

Sub test()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim my_urls(1 To 2) As String '修正变量名，原代码定义与赋值变量不一致
    Dim item As Variant
    Dim wordDoc As Word.document '提前定义Word编辑器对象
    Dim ie As InternetExplorerMedium
    
    '初始化需要访问的URL数组
    my_urls(1) = "work intranet url 1 - removed"
    my_urls(2) = "work intranet url 2 - removed"
    
    --- 关键：把Outlook邮件初始化移到循环外，只创建一次 ---
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)
    
    '设置邮件基础信息并获取编辑器
    On Error Resume Next
    With OutMail
        .To = "someone@org.com"
        .Subject = "test"
        .Display '显示邮件，才能获取Word编辑器
        Set wordDoc = .GetInspector.WordEditor
    End With
    On Error GoTo 0
    
    '初始化IE浏览器
    Set ie = New InternetExplorerMedium
    ie.Visible = True
    ie.Width = 1400 '提前设置窗口宽度，避免循环内重复操作
    
    '开始遍历URL截图
    For Each item In my_urls
        ie.navigate item
        
        '等待页面完全加载（包括异步请求）
        Do While ie.readyState <> 4 Or ie.Busy
            DoEvents
        Loop
        
        '等待JS渲染完成，时长根据实际页面调整
        Application.Wait (Now + TimeValue("0:00:7"))
        
        '执行截图操作
        Application.SendKeys "(%{1068})"
        DoEvents '给系统留时间把截图存入剪贴板
        
        --- 聚焦已有邮件并粘贴 ---
        OutMail.GetInspector.Activate '激活邮件窗口
        wordDoc.Application.Selection.EndKey Unit:=wdStory '光标移到邮件末尾
        wordDoc.Application.Selection.Paste '粘贴截图（比SendKeys更稳定）
        
        '裁剪图片
        For Each shp In wordDoc.InlineShapes
            shp.PictureFormat.CropTop = 200
            shp.PictureFormat.CropBottom = 200
        Next
        
        '可选：添加换行分隔不同截图
        wordDoc.Application.Selection.TypeParagraph
    Next item
    
    '清理资源
    ie.Quit
    Set ie = Nothing
    Set wordDoc = Nothing
End Sub

关键改动说明： #

• 邮件对象只初始化一次：将OutApp和OutMail的创建逻辑移到循环外，确保所有截图都粘贴到同一封邮件中。
• 替换不稳定的SendKeys粘贴：用wordDoc.Application.Selection.Paste替代SendKeys "^v"，避免焦点偏移导致粘贴失败。
• 修正变量名错误：原代码中数组定义为ob_urls但赋值用my_urls，统一为my_urls避免运行错误。
• 优化页面等待逻辑：用Do While ie.readyState <> 4 Or ie.Busy更严谨地判断页面加载状态，防止提前截图。
• 自动定位光标到末尾：每次粘贴前把光标移到邮件最后，保证新截图不会覆盖之前的内容。

额外提示： #

• 如果SendKeys截图不稳定，可以考虑使用Windows API实现更可靠的区域截图（针对网页表格精准截图）。
• 等待JS加载的时长0:00:7可以根据内网页面的实际加载速度调整，太短可能导致截图不全。

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