Можно ли создать правило Outlook для создания оповещения календаря из сообщения электронной почты?

Question

Я пытаюсь создать событие календаря из строки темы письма, как показано ниже.

Если я получу какое-либо письмо с телом сообщения в качестве срока исполнения:01.01.2015, оно должно создать событие в календаре, а также предупредить меня, когда произойдет эта дата и время.

Это возможно по правилу или макросу? Любая помощь приветствуется.

Макрос я пробовал до сих пор:

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

Answer 1

Я нашел эту подсказку в блогах MSDN . Я не занимался кодированием годами, но, возможно, это поможет вам.

Феликс Беме 19 июня 2013 16: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 (mischero@microsoft.com)

' 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