将两个工作簿的部分屏幕截图粘贴到电子邮件正文中

Question

在两个工作簿中，我需要制作一个屏幕截图（不是整个屏幕，只是一部分），并将这两个屏幕截图粘贴到 Outlook 电子邮件中。

如果这是可行的，而不是要求我写代码，你能给我指出正确的方向吗？

Answer 1

是的，我们可以。从 Outlook 运行并将捕获任意两个打开的 Excel (.xlsx) 文件的屏幕截图。更改脚本顶部的 CAPTURE_RANGE 常量。代码本身是不言自明的。

' Reference to the Microsoft Excel Object Library.
Const CAPTURE_RANGE As String = "A1:B5"

Sub CaptureAndSend()
    Dim xlApp As Object
    Dim counter As Integer
    Dim imagePaths(1 To 2) As String
    Dim currentPath As String
    Dim OutApp As Object, OutMail As Object
    
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    On Error GoTo 0
    
    If xlApp Is Nothing Then
        MsgBox "No Excel application found!"
        Exit Sub
    End If
    
    currentPath = xlApp.ActiveWorkbook.Path
    counter = 1
    
    Dim wb As Object
    For Each wb In xlApp.Workbooks
        If counter <= 2 Then
            wb.Activate
            imagePaths(counter) = currentPath & "\Image" & counter & ".png"
            CaptureRangeAsImage xlApp.ActiveSheet.Range(CAPTURE_RANGE), imagePaths(counter)
        End If
        counter = counter + 1
    Next wb
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    With OutMail
        .To = "[email protected]"
        .Subject = "Capturing Excel File"
        .HTMLBody = "<img src='" & imagePaths(1) & "'><br><img src='" & imagePaths(2) & "'>"
        .Display
    End With
    
    Set OutMail = Nothing
    Set OutApp = Nothing
    Set xlApp = Nothing
End Sub

Private Sub CaptureRangeAsImage(rng As Object, imagePath As String)
    Dim chrtObj As Object
    With rng
        .CopyPicture Appearance:=1, Format:=2
        Set chrtObj = .Parent.ChartObjects.Add(.Left, .Top, .Width, .Height)
    End With
    
    With chrtObj.Chart
        .Paste
        .Export imagePath
    End With
    
    chrtObj.Delete
End Sub