基于电子邮件自动创建约会

Question

我希望尝试让 Outlook 根据传入电子邮件的主题行自动创建约会。例如，如果我收到一封主题为“Demo Downloaded”的电子邮件，我希望它为此电子邮件创建一个约会，将邮件正文显示为约会上的“Note”。另外，我希望约会时间在电子邮件发送给我的日期后 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

但是我注意到有时我会收到一条错误消息，指出无法加载此脚本。有谁知道更好的方法或我可能缺少的东西？