Question

我正在尝试粘贴 excel 范围内的图片，我已经找到了解决方案，但由于某种原因，它一直在删除我的签名。我曾尝试使用 vbNewline、.body 和其他东西，但由于某种原因，它们都不起作用，或者我将它们插入了错误的位置。

Sub SendEmail()
    'This macro use the function named : CopyRangeToJPG
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim MakeJPG As String

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    'If you want to include a message in body of email
    'strbody = ""

              
    'Create JPG file of the range
    'Only enter the Sheet name and the range address
    MakeJPG = CopyRangeToJPG("Sheet1", "A2:P50")

    If MakeJPG = "" Then
        MsgBox "Something went wrong, can't create email"
        With Application
            .EnableEvents = True
            .ScreenUpdating = True
        End With
        Exit Sub
    End If

    On Error Resume Next
    
    With OutMail
        .SentOnBehalfOfName = "My Company"
        .BodyFormat = olFormatHTML
        .Display
    End With
        
        
            
    With OutMail
        .To = "Customer"
        .cc = ""
        .BCC = ""
        .Subject = "Customer - " & Date + 1
        .Attachments.Add MakeJPG, 1, 0
        'Note: Change the width and height as needed
        .HTMLBody = "<html><p>" & strbody & "</p><img src=""cid:NamePicture.jpg"" width=750 height=700></html>"
        .Attachments.Add ActiveWorkbook.FullName
        .Display 'or use .Send
    End With
        
                
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
        

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub



Function CopyRangeToJPG(NameWorksheet As String, RangeAddress As String) As String
    Dim PictureRange As Range

    With ActiveWorkbook
        On Error Resume Next
        .Worksheets(NameWorksheet).Activate
        Set PictureRange = .Worksheets(NameWorksheet).Range(RangeAddress)
        
        If PictureRange Is Nothing Then
            MsgBox "Sorry this is not a correct range"
            On Error GoTo 0
            Exit Function
        End If
        
        PictureRange.CopyPicture
        With .Worksheets(NameWorksheet).ChartObjects.Add(PictureRange.Left, PictureRange.Top, PictureRange.Width, PictureRange.Height)
            .Activate
            .Chart.Paste
            .Chart.Export Environ$("temp") & Application.PathSeparator & "NamePicture.jpg", "JPG"
        End With
        .Worksheets(NameWorksheet).ChartObjects(.Worksheets(NameWorksheet).ChartObjects.Count).Delete
    End With
    
    CopyRangeToJPG = Environ$("temp") & Application.PathSeparator & "NamePicture.jpg"
    Set PictureRange = Nothing
End Function

从excel粘贴图片后将默认签名添加到电子邮件正文

0 个答案: