Question

我正在尝试让Outlook根据传入电子邮件的主题行自动创建约会。例如，如果我收到一封主题为“Demo Downloaded”的电子邮件，我希望它为这封电子邮件创建一个约会，该约会将该消息的正文显示为约会上的“注释”。此外，我希望约会时间是在电子邮件发送给我之后2小时。因此，如果我在东部时间下午1点收到电子邮件，我希望约会自动设置为东部时间下午3点。

我知道我需要使用VBA并让outlook运行一个脚本，我知道如何完成所有这些操作。但是我现在所知道的是如何根据所选的电子邮件而不是已收到的电子邮件手动创建约会。另外，我不知道如何让它自动设置时间或类似的任何东西......

这是我现在所有的......

Sub CreateTask(Item As Outlook.MailItem)
    Dim objTask As Outlook.TaskItem
    Set objTask = Application.CreateItem(olTaskItem)
With objTask
    .Subject = Item.Subject
    .StartDate = Item.ReceivedTime
    .Body = Item.Body
    .Save
End With
    Set objTask = Nothing
End Sub

Answer 1

在您编辑的版本中......

从Sub CreateTask（ msg As MailItem ）知道邮件项目

尝试替换

Sub CreateTask(msg As MailItem)
    Dim app As New Outlook.Application
    Dim item As Object
    Set item = GetCurrentItem()
    If item.Class <> olMail Then Exit Sub

    Dim email As MailItem

    Set email = item

    Dim meetingRequest As AppointmentItem

    Set meetingRequest = app.CreateItem(olAppointmentItem)

与

Sub CreateTask(msg As MailItem) 
    Dim meetingRequest As AppointmentItem
    Set meetingRequest = Application.CreateItem(olAppointmentItem)

除了.SenderEmailAddress

之外，用msg替换电子邮件

Answer 2

在玩完代码并阅读其他一些内容之后，我已经弄明白了。这就是我想出来的。

Sub CreateTask(msg As MailItem)
    Dim app As New Outlook.Application
    Dim item As Object
    Set item = GetCurrentItem()
    If item.Class <> olMail Then Exit Sub

    Dim email As MailItem

    Set email = item

    Dim meetingRequest As AppointmentItem

    Set meetingRequest = app.CreateItem(olAppointmentItem)

    meetingRequest.Categories = email.Categories
    meetingRequest.Body = email.Body
    meetingRequest.Subject = email.Subject
    meetingRequest.Start = Date & " " & DateAdd("h", 3, Time)

    Dim attachment As attachment
    For Each attachment In email.Attachments
        CopyAttachment attachment, meetingRequest.Attachments
    Next attachment

    Dim recipient As recipient

    Set recipient = meetingRequest.Recipients.Add(email.SenderEmailAddress)
    recipient.Resolve

    For Each recipient In email.Recipients
        RecipientToParticipant recipient, meetingRequest.Recipients
    Next recipient

    Dim inspector As inspector

    Set inspector = meetingRequest.GetInspector

    meetingRequest.Save
    meetingRequest.Send

End Sub

但是我注意到有时候我收到错误，说无法加载此脚本。有谁知道更好的方法或我可能会遗漏的东西？

根据电子邮件自动创建约会

2 个答案: