我想把活动工作簿中的图片范围和一些文字一起添加到单元格中。
但出于某种原因,它会跳过文本并仅粘贴电子邮件正文中的图像。
我该如何解决这个问题?
Option Explicit
Public Sub POSTRUN()
Dim olApp As Outlook.Application
Set olApp = New Outlook.Application
Dim Olobj As Outlook.Application
Set Olobj = CreateObject("Outlook.Application")
Dim olNs As Outlook.Namespace
Set olNs = olApp.GetNamespace("MAPI")
Dim Inbox As Outlook.MAPIFolder
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Dim subject As String
subject = ThisWorkbook.Sheets("SendMail").Range("I5").Text
Debug.Print subject
Dim i As Long
Dim Filter As String
Filter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " >= '01/01/1900' And " & _
Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " < '12/31/2100' And " & _
Chr(34) & "urn:schemas:httpmail:subject" & _
Chr(34) & "Like '%" & subject & "%'"
Dim Items As Outlook.Items
Set Items = Inbox.Items.Restrict(Filter)
Items.Sort "[ReceivedTime]", False
For i = Items.Count To 1 Step -1
DoEvents
If TypeOf Items(i) Is MailItem Then
Dim Item As Object
Set Item = Items(i)
Debug.Print Item.subject ' Print on Immediate Window
Debug.Print Item.ReceivedTime ' Print on Immediate Window
Dim r As Range
Set r = ThisWorkbook.Sheets("post").Range("A1:M30")
r.Copy
Dim outMail As Outlook.MailItem
Set outMail = Olobj.CreateItem(olMailItem)
Dim body
Dim ReplyAll As Outlook.MailItem
Set ReplyAll = Item.ReplyAll
Dim wordDoc As Word.Document
Set wordDoc = ReplyAll.GetInspector.WordEditor
With ReplyAll
.HTMLBody = "<font size=""3"" face=""Calibri"">" & _
"Hi <br><br>" & _
"The " & Left(ActiveWorkbook.Name, _
InStr(ActiveWorkbook.Name, ".") - 1) & _
"</B> has been posted.<br>" & _
.HTMLBody
wordDoc.Range.PasteAndFormat wdChartPicture
.Display
Exit For
End With
End If
Next
End Sub
答案 0 :(得分:1)
它没有跳过,你只是用你的粘贴图像覆盖了HTMLBody
,所以你需要做的就是使用Paragraphs Object (Word)
实施例
With ReplyAll
.HTMLBody = "<font size=""3"" face=""Calibri"">" & _
"Hi <br><br>" & _
"The " & Left(ActiveWorkbook.Name, _
InStr(ActiveWorkbook.Name, ".") - 1) & _
"</B> has been posted.<br>" & .HTMLBody
.Display
With wordDoc.Paragraphs(2)
.Range.InsertParagraphAfter
.Range.PasteAndFormat Type:=wdChartPicture
.Range.ParagraphFormat.LineSpacingRule = wdLineSpaceDouble
End With
Exit For
End With
同时删除以下代码
Dim Olobj As Outlook.Application Set Olobj = CreateObject("Outlook.Application") Dim outMail As Outlook.MailItem Set outMail = Olobj.CreateItem(olMailItem) Dim body
你已经拥有它
Dim olApp As Outlook.Application Set olApp = New Outlook.Application Dim Item As Object Set Item = Items(i)