Create an Outlook appointment from an email message

Status
Not open for further replies.

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange

Patrick Corun

New Member
Outlook version
Outlook 2013 32 bit
Email Account
IMAP
Hello Diane, I am trying to work through a few issues with outlook 2013. My employer does not use an exchange server for emails and this makes it difficult to use some of the canned features within outlook. for example I can't create an appointment from an email, since my data file is for another account set up under outlook.com. So I tried the VBA code you recommended in this article and it works fine. Howver, I would like to know how I can have the appointment detail windo open up so that I can edit, modify or change things to the appointment. What would need to be added to the VBA code to make this happen and where would I need to add the code? I am not very good at VBA programming and would need some direction. Thanks in advance!! Here is the code.


Sub ConvertMailtoAccountAppt()
Dim objAppt As Outlook.AppointmentItem
Dim objMail As Outlook.MailItem

Set objAppt = Application.CreateItem(olAppointmentItem)
Set CalFolder = GetFolderPath("mailbox-name\Calendar")

Set objMail = Application.ActiveExplorer.Selection.Item(1)
With objAppt
.Subject = objMail.Subject

'sets it for tomorrow at 9 AM
.Start = DateSerial(Year(Now), Month(Now), Day(Now) + 1) + #9:00:00 AM#
.Body = objMail.Body

.Save
.Move CalFolder

End With

Set objAppt = Nothing
Set objMail = Nothing
End Sub

Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
Dim oFolder As Outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer

On Error GoTo GetFolderPath_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.Item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetFolderPath = Nothing
End If
Next
End If
'Return the oFolder
Set GetFolderPath = oFolder
Exit Function

GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function
End Function
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
Sorry I missed this earlier. You'd normally add .Display after this line

.Body = objMail.Body

but since you are moving it, add .display after the move.
 
P

pcorun

Sorry I missed this earlier. You'd normally add .Display after this line

.Body = objMail.Body

but since you are moving it, add .display after the move.

Here is the structure I used, but it was not successful:
.Save
.Move CalFolder
.Display


Do I need to set something after the .Display??
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
Here is the structure I used, but it was not successful:
.Save
.Move CalFolder
.Display


Do I need to set something after the .Display??
No, and you don't need display if you are just moving and don't want to make any changes to it.
 
Status
Not open for further replies.
Top