excel 在电子表格中通过电子邮件发送选定范围

kuuvgm7e 于 2023-05-19 发布在其他

关注(0)|答案(3)|浏览(138)

我需要的是给我的同事发电子邮件，在Excel中的某些单元格（从A列到Q列），这些单元格在我的电子邮件中显示为图片。下面是我的代码。但是，我电子邮件草稿中的图片是空白的。它没有显示细胞。有趣的是图片（包含我需要的单元格）被复制到我的剪贴板中，我可以删除空白图片并单击粘贴。但我想使它更加自动化，因为这个宏最终将在整个部门中可用。有人能帮我吗？

Sub CAS_Reminder()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim Rng As Range
    Dim LastRow As Long
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim Recipient_Name As String
    Dim StringBody As String
    Dim Manager_Name As String
    Dim RngHeight As Long
    Dim RngWidth As Long
    
    'set last row
    LastRow = Range("A1").End(xlDown).Row
    
    ' Set the range to be copied
    Set Rng = Range("A1", "Q" & LastRow)
    
    ' Copy the range and paste as picture
    Rng.CopyPicture xlScreen, xlPicture
    
    ' Create a temporary file to hold the image
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "SelectedRanges.png"
    
    ' Save the image to the temporary file
    With ActiveSheet.ChartObjects.Add(0, 0, Rng.Width, Rng.Height)
        .Chart.Paste
        .Chart.Export FileName:=TempFilePath & TempFileName, FilterName:="PNG"
        .Delete
    End With
    
    ' Store range dimensions in variables
    RngHeight = Rng.Height
    RngWidth = Rng.Width
    
    ' Create a new email
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    ' Set the recipients
    Recipient_Name = Range("Q2").Value & "@harriscomputer.com"
    Manager_Name = Range("D2").Value & "@harriscomputer.com"
    
    OutMail.To = Recipient_Name
    OutMail.CC = Manager_Name
    
    ' set subject of the email
    OutMail.Subject = "xxx"
    
    'set the body of the email
    StringBody = "xxx" & _
              "<img src='cid:SelectedRanges.png' height='" & RngHeight & "' width='" & RngWidth & "'>" 
    OutMail.HTMLBody = StringBody
    OutMail.Attachments.Add TempFilePath & TempFileName, 1, 0

    OutMail.Display
    
    ' Clean up
    Kill TempFilePath & TempFileName
    Set OutMail = Nothing
    Set OutApp = Nothing
    Sheets(1).Delete
    Application.DisplayAlerts = False
End Sub

excel

来源：https://stackoverflow.com/questions/76258639/email-selected-range-in-a-spreadsheet

3条答案

按热度按时间

ozxc1zmp1#

似乎单个.Paste并不总是有效-有时您需要在图表填充图像之前尝试多次。我在尝试将复制的图像粘贴到工作表时看到过同样的情况（但在这种情况下，失败会生成运行时错误）。例如，参见https://stackoverflow.com/a/60582628/478884
这对我来说非常一致：

Sub CAS_Reminder()
    Const RNG_PIC As String = "SelectedRanges.png"
    
    Dim OutApp As Object, OutMail As Object
    Dim Rng As Range, LastRow As Long, ws As Worksheet
    Dim TempFileName As String, Recipient_Name As String
    Dim StringBody As String, Manager_Name As String
    Dim RngHeight As Long, RngWidth As Long, attach As Object
    
    Set ws = ActiveSheet
    LastRow = ws.Range("A1").End(xlDown).Row
    Set Rng = ws.Range("A1:Q" & LastRow)
    RngHeight = Rng.Height
    RngWidth = Rng.Width
    Rng.CopyPicture xlScreen, xlPicture
    
    TempFileName = Environ$("temp") & "\" & RNG_PIC
     
    With ws.ChartObjects.Add(0, 0, RngWidth, RngHeight)
        '.Chart.Paste 'pic in mail is blank....
        CheckPaste .Chart 'make sure paste succeeded
        .Chart.Export Filename:=TempFileName, FilterName:="PNG"
        .Delete
    End With
    
    Set OutApp = GetObject(, "Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    'from Dmitry...
    Set attach = OutMail.Attachments.Add(TempFileName)
    attach.PropertyAccessor.SetProperty _
       "http://schemas.microsoft.com/mapi/proptag/0x3712001F", RNG_PIC
    
    StringBody = "xxx" & _
              "<img src='cid:" & RNG_PIC & "' height='" & RngHeight & "' width='" & RngWidth & "'>"
    OutMail.HTMLBody = StringBody
    
    OutMail.Display
End Sub

'try >1 paste if needed....
Sub CheckPaste(cht As Chart)
    Dim i As Long
    Do While cht.DrawingObjects.Count = 0 And i < 5
        cht.Paste
        DoEvents
        i = i + 1
    Loop
    Debug.Print "Paste count= " & i
End Sub

赞(0）回复(0）举报 2023-05-19

vmpqdwk32#

您的代码指定了cid属性，但从未将附件上的PR_ATTACH_CONTENT_ID属性设置为匹配值。
换一条线

OutMail.Attachments.Add TempFilePath & TempFileName, 1, 0

至

dim attach
set attach = OutMail.Attachments.Add(TempFilePath & TempFileName)
attach.PropertyAccessor.SetProperty("http://schemas.microsoft.com/mapi/proptag
/0x3712001F", "SelectedRanges.png")

赞(0）回复(0）举报 2023-05-19

2j4z5cfb3#

尝试

Sub SendEmailWithRange()
    Dim MyRange As Range
    Dim doc As Object, x
    Dim LastRow As Long
    
    LastRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
    
    Set MyRange = Sheets(1).Range("A1:Q" & LastRow)
    
    With CreateObject("outlook.application").CreateItem(0)
        .Display   'Change to .Send to send the email immediately
        
        .Body = "xxx"  '& vbNewLine
        Set doc = .GetInspector.WordEditor
        
        x = doc.Range.End - 1
        MyRange.Copy
        doc.Range(x).Paste
            
        .To = Sheets(1).Range("Q2").Value & "@harriscomputer.com"
        .CC = Sheets(1).Range("D2").Value & "@harriscomputer.com"
        .Subject = "xxx"
        
        Application.CutCopyMode = 0
    End With
    
    Sheets(1).Delete
End Sub

赞(0）回复(0）举报 2023-05-19

我来回答

excel 在电子表格中通过电子邮件发送选定范围

3条答案

相关问题

热门标签

最新问答