通过 Outlook 电子邮件发送 Excel 形状

Question

I already made this code, I want to send a image already exist inside the Excel (called Picture 1810 ) by e-mail. But I cant discovery how to do the .Body .

Anyone can help me?

Sub CreateMail()    
    Dim objOutlook As Object
    Dim objMail As Object
    Dim rngTo As Range
    Dim rngCC As Range
    Dim rngSubject As Range
    Dim rngBody As Shape
    Dim rngAttach As Range

    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)

    With ActiveSheet
        Set rngTo = .Range("f2")
        Set rngCC = .Range("f3")
        Set rngSubject = .Range("c2")
        Set rngBody = .Shapes("Picture 1810")
    End With

    With objMail
        .To = rngTo.Value
        .CC = rngCC.Value
        .Subject = rngSubject.Value
        .Body = rnbbody
        .Send
    End With

    Set objOutlook = Nothing
    Set objMail = Nothing
    Set rngTo = Nothing
    Set rngSubject = Nothing
    Set rngBody = Nothing
    Set rngAttach = Nothing
End Sub

Answer 1

By this you retain your standard email signature and paste the shape either floating over the body text or like a character in between:

With objMail
    .To = rngTo.Value
    .CC = rngCC.Value
    .Subject = rngSubject.Value
    .Display
    Dim wdDoc As Word.Document
    Set wdDoc = .GetInspector.WordEditor
    If Not wdDoc Is Nothing Then
        With wdDoc.Range
            .Collapse wdCollapseStart
            .InsertBefore "Hi there," & vbCrLf & "here's my shape:" & vbCrLf
            .Collapse wdCollapseEnd
            .InsertAfter vbCrLf & "Best wishes," & vbCrLf
            .Collapse wdCollapseStart

            ActiveSheet.Shapes("Picture 1810").Copy
            '.Paste ' over the text
            .PasteAndFormat wdChartPicture ' within text
        End With
        Set wdDoc = Nothing
    End If
    '.Send
End With