按顺序创建包含内容的电子邮件：文本、图像、文本、图像、文本、签名

Question

我在 Excel 工作。我想以特定格式起草电子邮件。

我找不到任何采用这种格式的电子邮件：

字数
图片
字数
图片
字数
签名

我找到了我用来构建自己的文字、图像、图像和签名。

它是这样显示的：

它应该是这样的：

我将我尝试过的所有内容都保留为注释掉的部分。

Sub EmailGenerate()
    
    Dim objOutApp As Object, objOutMail As Object
    Dim strBody As String, strSig As String, strEnd As String, strBody2 As String
    Dim rng As Range, rng2 As Range
    Dim r As Long, r2 As Long
    Dim wdDoc As Word.Document
    Dim Selection As Word.Selection
    Dim Selection2 As Word.Selection
     
    r = shEmail.Cells(Rows.Count, 15).End(xlUp).Row
    Set rng = shEmail.Range("K1:" & Cells(r, 21).Address)
    
    r2 = shEmail.Cells(Rows.Count, 23).End(xlUp).Row
    Set rng2 = shEmail.Range("W1:" & Cells(r2, 29).Address)
    
    Set objOutApp = CreateObject("Outlook.Application")
    Set objOutMail = objOutApp.CreateItem(0)
    Set wdDoc = objOutMail.GetInspector.WordEditor
     
    With objOutMail
        'If sent on behalf of another email address
        ' .SentOnBehalfOfName = ""
        'Setting the email conditions
        .To = shEmail.Cells(1, 2).Value
        .CC = shEmail.Cells(2, 2).Value
        .BCC = ""
        'Checks all email names
        .Recipients.ResolveAll
        .Subject = shEmail.Cells(4, 2).Value
        'This must be visible to get the default signature
        .Display
        'Get the html code from the signature
        strSig = .htmlbody
        'This is what the email body should say
      
       ' rng.Copy
       ' wdDoc.Application.Selection.Start = Len(strBody)
       ' wdDoc.Application.Selection.End = wdDoc.Application.Selection.Start
       ' wdDoc.Application.Selection.PasteAndFormat (wdChartPicture)
       ' wdDoc.Content.InsertParagraphAfter
       ' rng2.Copy
       ' wdDoc.Application.Selection.Start = Len(strBody) + Len(strBody2)
       ' wdDoc.Application.Selection.End = wdDoc.Application.Selection.Start
       ' wdDoc.Application.Selection.PasteAndFormat (wdChartPicture)
      
       ' rng1.Copy
       ' wdDoc.Paragraphs(2).Range.PasteSpecial , , , , wdPasteBitmap
      
        rng.Copy
        wdDoc.Content.InsertParagraphBefore
        wdDoc.Paragraphs(2).Range.PasteSpecial , , , , wdPasteBitmap
        wdDoc.Content.InsertParagraphAfter
      
        strBody = "<Body style=font-size:11pt;font-family:Calibri>" & _
          shEmail.Cells(5, 2).Value & "</p>" & _
          "<p>" & "</p>" & _
          "<p>" & shEmail.Cells(6, 2).Value & "</p>" & _
          "<p>" & shEmail.Cells(7, 2).Value & "</p>" & _
          "<p>" & "</p>" & _
          "<p>" & shEmail.Cells(8, 2).Value & "</p>"
          
        strBody2 = "<Body style=font-size:11pt;font-family:Calibri>" & _
          shEmail.Cells(10, 2).Value & "</p>" & _
          "<p>" & "</p>"
       
        rng2.Copy
        wdDoc.Content.InsertParagraphBefore
        wdDoc.Paragraphs(1).Range.PasteSpecial , , , , wdPasteBitmap
        wdDoc.Content.InsertParagraphAfter
        
        objOutMail.htmlbody = strBody2 & _
          .htmlbody
         
        ' rng2.Copy
        ' wdDoc.Application.Selection.Start = Len(strBody) + Len(strBody2)
        ' wdDoc.Application.Selection.End = wdDoc.Application.Selection.Start
        ' wdDoc.Application.Selection.PasteAndFormat (wdChartPicture)
    
        'Combines the email with image and the signature
        objOutMail.htmlbody = strBody & _
          .htmlbody
      
        'Automatically sends the email, should pop up briefly.
        '.Send
    
    End With
    
    On Error GoTo 0
    Set objOutMail = Nothing
    Set objOutApp = Nothing
     
End Sub

rng 较大 table rng2 较小 table.

.Cells(5,2) 到 (8,2) 在 rng 之前，(10,2) 在 rng 之后和 rng2 之前，然后 (12,2) 将在 rng2 之后和签名之前。

Answer 1

请尝试下一个方法。很难把WordEditor和html混在一起，至少我没做过，不知道how/if能不能做到。您需要的一切（我理解）都可以使用 WordEditor 对象或 html 使用 PropertyAccessor 和 link 来绘制路径。我仅在您的改编代码中使用 WordEditor:

Sub EmailGenerate()
 Dim objOutApp As Object, objOutMail As Object
 Dim rng As Range, rng2 As Range, shEmail As Worksheet
 Dim r As Long, r2 As Long
 Dim wdDoc As Word.document, wdRange As Word.Range
 
 Set shEmail = ActiveSheet 'use here your necessary sheet
 
 r = shEmail.cells(Rows.count, 15).End(xlUp).row
 Set rng = shEmail.Range("K1:" & cells(r, 21).Address)

 r2 = shEmail.cells(Rows.count, 23).End(xlUp).row
 Set rng2 = shEmail.Range("W1:" & cells(r2, 29).Address)

 Set objOutApp = CreateObject("Outlook.Application")
 Set objOutMail = objOutApp.CreateItem(0)
 Set wdDoc = objOutMail.GetInspector.WordEditor
  
 With objOutMail
    'If sent on behalf of another email address
    '.SentOnBehalfOfName = ""
    'Setting the email conditions
    .To = shEmail.cells(1, 2).Value
    .cc = shEmail.cells(2, 2).Value
    .BCC = ""
    'Checks all email names
    .Recipients.ResolveAll
    .subject = shEmail.cells(4, 2).Value
    'This must be visible to get the default signature
    .display 'Please, look here if its appearance is what you need.
    
    'Declare the string variables to be used:
    Dim strFrst As String, strSec As String, strThird As String, strF As String
    
    'Give values to the strings (they can take the values from the sheet...)
    strFrst = "Hello All!" & vbCrLf & vbCrLf
    strSec = "Please, receive the picture you requested:" & vbCrLf & vbCrLf
    strThird = "And the second picture is following:" & vbCrLf & vbCrLf
    strF = "The last necessary string is here..." & vbCrLf
    
    'Write the first two text lines:________________
    wdDoc.Paragraphs(1).Range.InsertAfter (strFrst)
    wdDoc.Paragraphs(2).Range.InsertAfter (vbCrLf) 'insert an empty line
    wdDoc.Paragraphs(3).Range.InsertAfter (strSec)
    '_______________________________________________
    
    'Embed the first picture__________________________________________
    rng.Copy
    wdDoc.Paragraphs(5).Range.PasteSpecial , , , , wdPasteBitmap
    '_________________________________________________________________
    
    wdDoc.Paragraphs(5).Range.InsertAfter (vbCrLf) 'empty line after first picture
    
    'insert the third string:_______________________
    wdDoc.Paragraphs(6).Range.InsertAfter (strThird)
    '_______________________________________________
      
    'Embed the second picture___________________________________
    rng2.Copy
    wdDoc.Paragraphs(8).Range.PasteSpecial , , , , wdPasteBitmap
    '___________________________________________________________
    
    'insert the fourth string:__________________
    wdDoc.Paragraphs(8).Range.InsertAfter (strF)
    '___________________________________________
    
    
    'Automatically sends the email, should pop up briefly.
    '.Send
 End With
End Sub

请测试它并发送一些反馈。

按顺序创建包含内容的电子邮件：文本、图像、文本、图像、文本、签名

Create email with contents in order: Text, Image, Text, Image, Text, Signature

excel

outlook

vba

ms-word