Email 从已发送邮件创建任务并包含附件

在Outlook 2010 VBA中，我希望在发送电子邮件时创建任务

我想将电子邮件中的所有附件添加到任务中

我尝试了

.Attachments.Add

（不受支持），

.Attachments=item.Attachments

返回属性为只读

是否可以或如何将电子邮件附加到任务

Public，事件myOlApp作为Outlook.Application
专用子应用程序\u MAPIGONCOMPLETE（）
端接头
私有子应用程序_启动（）
初始化\u处理程序
端接头
公共子处理器初始化\u处理程序（）
设置myOlApp=CreateObject（“Outlook.Application”）
端接头
私有子myOlApp_ItemSend（ByVal项作为对象，取消作为布尔值）
作为整数的Dim intRes
作为字符串的Dim strMsg
将对象任务设置为任务项
Set objTask=Application.CreateItem（olTaskItem）
作为字符串的Dim strRecip
将收件人作为邮件项
将objMail设置为Outlook.MailItem
strMsg=“是否要为此邮件创建任务？”
intRes=MsgBox（strMsg，vbYesNo+vb惊叹号，“创建任务”）
如果intRes=vbNo，则
取消=错误
其他的
对于项中的每个收件人。收件人
strRecip=strRecip&vbCrLf&Recipient.Address
下一个收件人
带任务
'.Body=strRecip&vbCrLf&Item.Body
.Body=项目.Body
.Subject=项目.Subject
.StartDate=项目.ReceivedTime
.提醒集=真
.rementerTime=日期序列（年（现在）、月（现在）、日（现在+1））+#上午8:00:00#
**.Attachments.Add（项.附件）**
拯救
以
取消=错误
如果结束
设置objTask=Nothing
端接头

Attachments.Add允许将字符串作为参数（完全查询的附件文件名）或Outlook项目（如MailItem）传递。如果要将附件集合作为参数传递，则无法执行此操作

对于每个附件，请先保存附件（attachment.SaveAsFile），然后将文件名作为参数一次一个地添加到任务中。

这是我的最终代码

Public WithEvents myOlApp As Outlook.Application

Private Sub Application_MAPILogonComplete()

End Sub

Private Sub Application_Startup()
 Initialize_handler
End Sub

Public Sub Initialize_handler()
 Set myOlApp = CreateObject("Outlook.Application")
End Sub

Private Sub myOlApp_ItemSend(ByVal item As Object, Cancel As Boolean)

Dim intRes As Integer
Dim strMsg As String
Dim objTask As TaskItem
Set objTask = Application.CreateItem(olTaskItem)
Dim strRecip As String
Dim att As MailItem
Dim objMail As Outlook.MailItem
Dim Msg As Variant

strFolderPath = "C:\temp" ' path to target folder


strMsg = "Do you want to create a task for this message?"
intRes = MsgBox(strMsg, vbYesNo + vbExclamation, "Create Task")


If intRes = vbNo Then
  Cancel = False
Else

For Each Recipient In item.Recipients
    strRecip = strRecip & vbCrLf & Recipient.Address
Next Recipient

item.SaveAs strFolderPath & "\" & "test" & ".msg", olMSG

'item.Save

With objTask
    '.Body = strRecip & vbCrLf & Item.Body
    .Body = item.Body
    .Subject = item.Subject
    .StartDate = item.ReceivedTime
    .ReminderSet = True
    .ReminderTime = DateSerial(Year(Now), Month(Now), Day(Now + 1)) + #8:00:00 AM#
    .Attachments.Add item
    .Save
End With

Cancel = False

End If

Set objTask = Nothing

End Sub

---

如果有人需要，这里是最后的代码