我在下面的实施中遇到问题。该脚本对先前选择的文件夹 (oFolder) 中的所有邮件进行循环，直到该文件夹中没有更多邮件 (MailItem)，它才会循环并发送回复。但是从模板（*.oft - Outlook 模型）创建的消息在发送后会转换为纯文本，除非发送到内部电子邮件地址，与发件人在同一域中，然后格式保持不变。
我尝试了一些解决方案，例如在创建消息后重置 .HTMLBody，但无济于事。也许我把解决方案放在错误的地方，不确定。但这是我的代码：
Dim originalMail, loopControl, newMail, headerMail, footerMail As MailItem
Dim snd2Folder As MAPIFolder
Dim myRecipient As Recipients
Dim thisRecipient As Recipient
Dim oSubject, oMessage, oMessageNew, oRecipient, oMailDate, oMailTo, thisSenderAddr, tempTemplate As String
Dim objPropNewName, objPropNewDateTime As UserProperty
Dim thisClassName As Type
While oFolder.Items.Count > 0
loopControl = oFolder.Items.GetFirst
If TypeName(loopControl) = "MailItem" Then
originalMail = loopControl
originalMail.BodyFormat = OlBodyFormat.olFormatHTML 'here tried implementing the post solution, not working
originalMail.HTMLBody = originalMail.HTMLBody
originalMail.Save()
myRecipient = originalMail.ReplyRecipients 'the original message comes from a form in a web page, that contains the persons email set in the Reply-To field
newMail = OutlookApp.CreateItemFromTemplate(tempTemplate) 'creates a new message from a template in the tempTemplate location, a local folder with *.oft files selected by the user
objPropNewName = newMail.UserProperties.Add("Custom Property", OlUserPropertyType.olText, True) 'sensitive custom property set by the organisation for control purposes
objPropNewName.Value = tmpUserName 'value to be stored in the property
objPropNewDateTime = newMail.UserProperties.Add("Another Custom Property", OlUserPropertyType.olDateTime, True)
objPropNewDateTime.Value = tmpDateTime
If originalMail.ReplyRecipients.Count > 0 Then 'since the message may come from a web form or directly via Replay, it is important to get the SMTP email address in the .To field. This block makes sure the .To field will get a valid SMTP address
Try
thisRecipient = myRecipient.Item(1)
thisRecipient.Resolve()
If thisRecipient.Resolved() Then
thisUser = thisRecipient.AddressEntry.GetExchangeUser()
If thisUser Is Nothing Then
oRecipient = myRecipient.Item(1).Address.ToString()
Else
oRecipient = thisRecipient.AddressEntry.GetExchangeUser.PrimarySmtpAddress.ToString()
End If
Else
oRecipient = myRecipient.Item(1).Address.ToString()
End If
'oRecipientMail = myRecipient.Item(1).AddressEntry.Address.ToString()
Catch ex As System.Exception
PrintCurrentLineException(ex, thisClassName.FullName, MethodBase.GetCurrentMethod().Name)
oRecipient = myRecipient.Item(1).Address.ToString() 'if there is an error because the sender is not a Exchange user, it will be a SMTP address, so get that value instead
End Try
Else
If originalMail.SenderEmailType = "EX" Then
oRecipient = originalMail.Sender.GetExchangeUser.PrimarySmtpAddress.ToString()
Else
oRecipient = originalMail.SenderEmailAddress
End If
End If
With originalMail
oSubject = .Subject
oMessage = .HTMLBody
oMailTo = .To
oMailDate = Format(.SentOn, "dddd, dd MMM yyyy - HH:mm")
End With
If originalMail.ReadReceiptRequested = True Or originalMail.OriginatorDeliveryReportRequested = True Then
Dim thisEntry, thisSubject, thisDate As String
Dim thisAccessor As PropertyAccessor
thisAccessor = originalMail.PropertyAccessor
thisEntry = thisAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x1035001E").ToString()
thisSubject = originalMail.Subject
thisDate = Format(originalMail.SentOn, "ddd dd/MM/yyyy HH:mm")
OBGWorkerModulo1.CancelAsync()
Thread.Sleep(300)
MsgBox("One of the messages in this lot of " & i1 & " messages have a delivery or a read recipe active." & vbNewLine & vbNewLine & "The application cannot work correctly. Please mark the message as read or reply to it manually." & vbNewLine & vbNewLine & "Sender: " & oRecipient & vbNewLine & "Subject: " & thisSubject & vbNewLine & "Received in: " & thisDate & vbNewLine & "Message EntryID: " & thisEntry, vbDefaultButton1 + vbExclamation + vbOKOnly + vbApplicationModal + vbMsgBoxSetForeground, "Read/Delivery Recipe")
errorLocal = True 'variable to point an internal error
Exit Try
End If
With newMail
.To = oRecipient
.Subject = oSubject
thisSenderAddr = LCase(outServer) '
Try
If tmpChkHeader = True And tmpChkFooter = False Then 'an internal option to set header or/and footer as a template to be applied to the reply message
oMessageNew = "<html><style>body {font-family: calibri; font-size: 11.25pt;}</style>" & headerMail.HTMLBody & newMail.HTMLBody & "<body><br><hr>" & "---- Your message ----<br><b>From:</b><a href="" mailto:" & oRecipient & """>" & oRecipient & "</a><br><b>Sent on:</b> " & oMailDate & "<br><b>To:</b> " & oMailTo & " (<a href=""mailto:" & thisSenderAddr & """>" & thisSenderAddr & "</a>)<br><b>Subject:</b> " & oSubject & "<br><br><blockquote>" & oMessage & "</blockquote></body></html>"
ElseIf tmpChkHeader = False And tmpChkFooter = True Then
oMessageNew = "<html><style>body {font-family: calibri; font-size: 11.25pt;}</style>" & newMail.HTMLBody & footerMail.HTMLBody & "<body><br><hr>" & "---- Your message ----<br><b>From:</b><a href="" mailto:" & oRecipient & """>" & oRecipient & "</a><br><b>Sent on:</b> " & oMailDate & "<br><b>To:</b> " & oMailTo & " (<a href=""mailto:" & thisSenderAddr & """>" & thisSenderAddr & "</a>)<br><b>Subject:</b> " & oSubject & "<br><br><blockquote>" & oMessage & "</blockquote></body></html>"
ElseIf tmpChkHeader = True And tmpChkFooter = True Then
oMessageNew = "<html><style>body {font-family: calibri; font-size: 11.25pt;}</style>" & headerMail.HTMLBody & newMail.HTMLBody & footerMail.HTMLBody & "<body><br><hr>" & "---- Your message ----<br><b>From:</b><a href="" mailto:" & oRecipient & """>" & oRecipient & "</a><br><b>Sent on:</b> " & oMailDate & "<br><b>To:</b> " & oMailTo & " (<a href=""mailto:" & thisSenderAddr & """>" & thisSenderAddr & "</a>)<br><b>Subject:</b> " & oSubject & "<br><br><blockquote>" & oMessage & "</blockquote></body></html>"
Else
oMessageNew = "<html><style>body {font-family: calibri; font-size: 11.25pt;}</style>" & newMail.HTMLBody & "<body><br><hr>" & "---- Your message ----<br><b>From:</b><a href="" mailto:" & oRecipient & """>" & oRecipient & "</a><br><b>Sent on:</b> " & oMailDate & "<br><b>To:</b> " & oMailTo & " (<a href=""mailto:" & thisSenderAddr & """>" & thisSenderAddr & "</a>)<br><b>Subject:</b> " & oSubject & "<br><br><blockquote>" & oMessage & "</blockquote></body></html>"
End If
Catch ex As System.Exception
PrintCurrentLineException(ex, thisClassName.FullName, MethodBase.GetCurrentMethod().Name)
oMessageNew = "<html><style>body {font-family: calibri; font-size: 11.25pt;}</style>" & newMail.HTMLBody & "<body><br><hr>" & "---- Your message ----<br><b>From:</b><a href="" mailto:" & oRecipient & """>" & oRecipient & "</a><br><b>Sent on:</b> " & oMailDate & "<br><b>To:</b> " & oMailTo & " (<a href=""mailto:" & thisSenderAddr & """>" & thisSenderAddr & "</a>)<br><b>Subject:</b> " & oSubject & "<br><br><blockquote>" & oMessage & "</blockquote></body></html>"
End Try
.SentOnBehalfOfName = outServer 'server mail set on a config file
.HTMLBody = oMessageNew
.Send()
End With
If sndReply = True Then 'if the sent event is all right, this variable is set to true
originalMail.Unread = False
originalMail.Move(snd2Folder) 'a outlook folder to where the original messages are moved after replied to
Marshal.ReleaseComObject(originalMail)
Marshal.ReleaseComObject(newMail)
Marshal.ReleaseComObject(objPropNewName)
Marshal.ReleaseComObject(objPropNewDateTime)
End If
intCnt += 1
i2 += 1
Else
Dim controlTypeName As String = Information.TypeName(loopControl)
MsgBox("One item in the selected folder is not a valid email message. Remove the item to another folder or select another folder before running this lot again." & vbNewLine & vbNewLine & "Control Type: " & controlTypeName & vbNewLine & $"Selected folder: {oFolder.Name}", vbDefaultButton1 + vbExclamation + vbOKOnly + vbApplicationModal + vbMsgBoxSetForeground, "Wrong control type")
errorLocal = True
Exit Try
End If
End While
我已经尝试过这篇文章中的解决方案，但到目前为止没有运气：
使用模板在 VBA 中创建的 Outlook 电子邮件在保存时转换为纯文本
我有一个非常相似的代码，没有在发送后保持格式的循环。
主要区别在于上面的代码在发送前不显示消息，因为它会减慢进程（必须在发送前显示每条消息）。
有没有一种显示而不显示的方法，比如命令消息在发送前按照模板中的方式进行格式化？