☰

我可以创建 Outlook 规则以从邮件正文创建日历警报吗

tag-icon • tag-icon microsoft-outlook-2013
我可以创建 Outlook 规则以从邮件正文创建日历警报吗

我想要做的是从邮件主题行创建一个日历事件，如下所示。

如果我收到任何邮件正文为到期日：2015 年 1 月 1 日的邮件，它应该在日历中创建一个事件，并且在该日期和时间到来时提醒我。

这可以通过规则或宏来实现吗？任何帮助都将不胜感激。

我至今尝试过的宏：

Sub CreateAppt(Item As Outlook.MailItem)
Dim newOrder As Outlook.MailItem
Dim thebody As String
Dim date1 As Date
Dim strdate As String
Dim time As String
Dim address As String
Dim TI As Outlook.AppointmentItem

thebody = Item.Body

strdate = Mid(thebody, InStr(1, thebody, "date1: ") + 7, _
InStr(InStr(1, thebody, "date1: "), thebody, vbCrLf) - _
InStr(1, thebody, "date1: ") - 7)

Date = DateSerial(Split(strdate, "/")(2), _
Split(strdate, "/")(1), _
Split(strdate, "/")(0))

time = Mid(thebody, InStr(1, thebody, "time: ") + 5, _
InStr(InStr(1, thebody, "time: "), thebody, vbCrLf) - _
InStr(1, thebody, "time: ") - 5)

address = Mid(thebody, InStr(1, thebody, "address: ") + 7, _
InStr(InStr(1, thebody, "address: "), thebody, vbCrLf) - _
InStr(1, thebody, "address: ") - 7)

Set TI = Application.CreateItem(olAppointmentItem)
With TI
 .Subject = Item.Subject
 .Location = address
 .Start = date1 & time
 .Duration = 0
 .Body = Item.Body
 .ReminderMinutesBeforeStart = 15
 .Save
 '.Display
End With
End Sub

答案1

我在微软博客。我已经很多年没有做过任何编码了，但也许这会对你有所帮助。

作者：Felix Boehme 2013 年 6 月 19 日下午 4:46

Option Explicit

Dim item As Object

Sub NewMeetingReadingPane()

   Set item = Application.ActiveExplorer.Selection(1)

   NewMeetingRequestFromEmail

End Sub

Sub NewMeetingOpenEmail()

   Set item = Application.ActiveInspector.CurrentItem

   NewMeetingRequestFromEmail

End Sub

' Create a New Meeting request from an email

' Written by Michael S. Scherotter ([email protected])

' 1. If the current item is an email, create a new appointment item

' 2. Copy the categories, body, and subject

' 3. Copy the attachments

' 4. Add the sender as a meeting participant

' 5. Add each email recipient as a meeting participant

' 6.    Each To: participant will be required

' 7.    Each CC: or BCC: participant will be optional

Sub NewMeetingRequestFromEmail()

   Dim app As New Outlook.Application

   'Dim item As Object

   'Set item = app.ActiveInspector.CurrentItem

   'Set item = Application.ActiveExplorer.Selection(1)

   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.Attachments.Add item, olEmbeddeditem

'    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

   meetingRequest.MeetingStatus = olMeeting

   Dim inspector As inspector

   Set inspector = meetingRequest.GetInspector

   'inspector.CommandBars.FindControl

   inspector.Display

End Sub

Private Sub RecipientToParticipant(recipient As recipient, participants As Recipients)

   Dim participant As recipient

   If LCase(recipient.Address) <> LCase(Session.CurrentUser.Address) Then

       Set participant = participants.Add(recipient.Address)

       Select Case recipient.Type

       Case olBCC:

           participant.Type = olOptional

       Case olCC:

           participant.Type = olOptional

       Case olOriginator:

           participant.Type = olRequired

       Case olTo:

           participant.Type = olRequired

       End Select

       participant.Resolve

   End If

End Sub

Private Sub CopyAttachment(source As attachment, destination As Attachments)

   On Error GoTo HandleError

   Dim filename As String

   filename = Environ("temp") & "\" & source.filename

   source.SaveAsFile (filename)

   destination.Add (filename)

   Exit Sub

HandleError:

   Debug.Print Err.Description

End Sub

相关内容