從電子郵件創建任務時保留html格式

Question

我有一個腳本，可以將電子郵件轉換爲我的Outlook中的任務。

我的主要挫折是它不會保留html格式，並將嵌入圖像作爲附件進行處理。我想知道有沒有人可以幫忙。我知道這是可能的，因爲我已經手動將電子郵件的正文直接複製到任務的正文，並且保存得很好。

Sub ConvertSelectedMailtoTask() 
    Dim objApp As Outlook.Application 
    Dim objTask As Outlook.TaskItem 
    Dim objMail As Outlook.MailItem 

    Set objTask = Application.CreateItem(olTaskItem) 
    Set objApp = Application 

    If TypeName(objApp.ActiveWindow) = "Explorer" Then 
     For Each objMail In Application.ActiveExplorer.Selection 
      If Left(objMail.Subject, 3) = "RE:" Or Left(objMail.Subject, 3) = "FW:" Then 
       subj = Right(objMail.Subject, Len(objMail.Subject) - 4) 
      Else 
       subj = objMail.Subject 
      End If 
      With objTask 
       .Subject = subj 
       .Importance = objMail.Importance 
       .StartDate = objMail.ReceivedTime 
       .Body = objMail.Body 
       .DueDate = Date + 3 
       If objMail.Attachments.Count > 0 Then 
        CopyAttachments objMail, objTask 
       End If 
       .ReminderSet = True 
       .ReminderTime = Date + 2.5 
       .Sensitivity = olPrivate 
       .Save 
      End With 
     Next 
    ElseIf TypeName(objApp.ActiveWindow) = "Inspector" Then 
     Set objMail = objApp.ActiveInspector.CurrentItem 

     If Left(objMail.Subject, 3) = "RE:" Or Left(objMail.Subject, 3) = "FW:" Then 
       subj = Right(objMail.Subject, Len(objMail.Subject) - 4) 
      Else 
       subj = objMail.Subject 
      End If 
      With objTask 
       .Subject = subj 
       .Importance = objMail.Importance 
       .StartDate = objMail.ReceivedTime 
       .Body = objMail.Body 
       .DueDate = Date + 3 
       If objMail.Attachments.Count > 0 Then 
        CopyAttachments objMail, objTask 
       End If 
       .ReminderSet = True 
       .ReminderTime = Date + 2.5 
       .Sensitivity = olPrivate 
       .Save 
      End With 
    End If 
    Set objTask = Nothing 
    Set objMail = Nothing 
    Set objApp = Nothing 
End Sub 

這裏是附件

腳本

Sub CopyAttachments(objSourceItem, objTargetItem) 
    Set fso = CreateObject("Scripting.FileSystemObject") 
    Set fldTemp = fso.GetSpecialFolder(2) ' TemporaryFolder 
    strPath = fldTemp.Path & "\" 
    For Each objAtt In objSourceItem.Attachments 
     strFile = strPath & objAtt.FileName 
     objAtt.SaveAsFile strFile 
     objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName 
     fso.DeleteFile strFile 
    Next 

    Set fldTemp = Nothing 
    Set fso = Nothing 
End Sub 

更新：

我發現一些代碼，使用word文檔保存格式：

Sub CopyFullBody(sourceItem As Object, targetItem As Object) 
    Dim objDoc As Word.Document 
    Dim objSel As Word.Selection 
    Dim objDoc2 As Word.Document 
    Dim objSel2 As Word.Selection 
    On Error Resume Next 
    ' get a Word.Selection from the source item 
    Set objDoc = sourceItem.GetInspector.WordEditor 
    If Not objDoc Is Nothing Then 
     Set objSel = objDoc.Windows(1).Selection 
     objSel.WholeStory 
     objSel.Copy 
     Set objDoc2 = targetItem.GetInspector.WordEditor 
     If Not objDoc2 Is Nothing Then 
      Set objSel2 = objDoc2.Windows(1).Selection 
      objSel2.PasteAndFormat wdPasteDefault 
     Else 
      MsgBox "Could not get Word.Document for " & _ 
        targetItem.Subject 
     End If 
    Else 
     MsgBox "Could not get Word.Document for " & _ 
       sourceItem.Subject 
    End If 
    Set objDoc = Nothing 
    Set objSel = Nothing 
    Set objDoc2 = Nothing 
    Set objSel2 = Nothing 
End Sub 

這似乎並不是唯一的解決方案因此更新我自己的帖子，而不是回答我的問題，因爲這似乎有點冗長（使用另一個應用程序只是爲了給我格式化，當我可以手動複製和粘貼文本，只需在Outlook中罰款）。如果有人對此/定義附件類型有任何其他想法，請繼續回答！

Answer 1

在該行

.Body = objMail.Body 

你只問FOT非格式化的正文。嘗試改爲：

.Body = objMail.htmlBody 

和完全不同的東西：我只是把提醒到郵件本身，所以我沒有必要再創建額外的任務......

Answer 2

請記住，Outlook任務，約會並且任務與RTF一起使用，而不是HTML。因此TaksItem，ContactItem和AppointmentItem對象僅公開RtfBody屬性，但不包含HTMLBody（如MailItem一樣）。

你要麼需要將HTML轉換成RTF（你可以嘗試爲Word對象模型），或使用Redemption：與Outlook對象模型，它暴露了RDOTaskItem .HTMLBody性能和動態HTML轉換到本機（用於任務）設置該屬性時的RTF。