Created
October 16, 2020 11:13
-
-
Save GeeLaw/d426562c943654fb93c772b4dca56b36 to your computer and use it in GitHub Desktop.
Outlook macro: Create appointment from e-mail.
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Option Explicit | |
Sub CreateAppointmentFromMessage() | |
Dim activeWin As Object | |
Dim targetItem As Object | |
Dim targetMsg As MailItem | |
Dim targetFolder As Folder | |
Dim newAppointment As AppointmentItem | |
Dim msgInspector As Inspector | |
Dim aptInspector As Inspector | |
Dim wordEdit As Object | |
Dim oldInspectorCount As Integer | |
Dim newInspectorCount As Integer | |
Set activeWin = Application.ActiveWindow | |
' Case 1: Calling this from the message window. | |
If activeWin.Class = olInspector Then | |
Set targetItem = activeWin.CurrentItem | |
If targetItem.Class <> olMail Then | |
MsgBox "The current item is not a message.", vbExclamation, "Create Appointment from Message" | |
Exit Sub | |
End If | |
Set targetMsg = targetItem | |
' Case 2: Calling this from the folder window. | |
ElseIf activeWin.Class = olExplorer Then | |
' Ensure current folder is a folder of messages. | |
Set targetFolder = activeWin.CurrentFolder | |
If targetFolder Is Nothing Then | |
MsgBox "No folder is in view.", vbExclamation, "Create Appointment from Message" | |
Exit Sub | |
End If | |
If targetFolder.DefaultItemType <> olMailItem Then | |
MsgBox "The current folder is not a message folder.", vbExclamation, "Create Appointment from Message" | |
Exit Sub | |
End If | |
Set targetFolder = Nothing | |
' Ensure the unique selection is a message. | |
Set targetItem = activeWin.Selection | |
If targetItem.Count = 0 Then | |
MsgBox "No item is selected.", vbExclamation, "Create Appointment from Message" | |
Exit Sub | |
ElseIf targetItem.Count <> 1 Then | |
MsgBox "Multiple items are selected.", vbExclamation, "Create Appointment from Message" | |
Exit Sub | |
End If | |
Set targetItem = targetItem.Item(1) | |
If targetItem.Class <> olMail Then | |
MsgBox "The selected item is not a message.", vbExclamation, "Create Appointment from Message" | |
Exit Sub | |
End If | |
Set targetMsg = targetItem | |
' Case 3: Mysterious. | |
Else | |
MsgBox "The active window is neither an inspector not an explorer.", vbExclamation, "Create Appointment from Message" | |
Exit Sub | |
End If | |
' Ask the user to choose a calendar. | |
Set targetFolder = Application.GetNamespace("MAPI").PickFolder | |
If targetFolder Is Nothing Then | |
Exit Sub | |
End If | |
If targetFolder.Class <> olFolder Or targetFolder.DefaultItemType <> olAppointmentItem Then | |
MsgBox "The selected folder is not a calendar.", vbExclamation, "Create Appointment from Message" | |
Exit Sub | |
End If | |
Set newAppointment = targetFolder.Items.Add(olAppointmentItem) | |
newAppointment.Subject = targetMsg.Subject | |
Set aptInspector = newAppointment.GetInspector | |
' Open or retrieve the inspector for the message. | |
oldInspectorCount = Application.Inspectors.Count | |
Set msgInspector = targetMsg.GetInspector | |
newInspectorCount = Application.Inspectors.Count | |
' Copy the message body to the appointment. | |
If msgInspector.IsWordMail And (msgInspector.EditorType = olEditorWord) And aptInspector.IsWordMail And (aptInspector.EditorType = olEditorWord) Then | |
Set wordEdit = msgInspector.WordEditor | |
wordEdit.Select | |
wordEdit.Application.Selection.Copy | |
Set wordEdit = aptInspector.WordEditor | |
wordEdit.Select | |
' 16 = wdFormatOriginalFormatting | |
wordEdit.Application.Selection.PasteAndFormat 16 | |
' Move the cursor to the beginning. | |
wordEdit.Range(0, 0).Select | |
ElseIf (msgInspector.EditorType = olEditorWord) Or (msgInspector.EditorType = olEditorRTF) Or (msgInspector.EditorType = olEditorHTML) Then | |
newAppointment.RTFBody = targetMsg.RTFBody | |
Else | |
newAppointment.Body = targetMsg.Body | |
End If | |
' Close the message inspector if it was not open. | |
If oldInspectorCount <> newInspectorCount Then | |
msgInspector.Close olDiscard | |
End If | |
aptInspector.Activate | |
End Sub | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment