Hi, I am using the below code which converts a messge to an appointment on another mailbox's calendar that I have complete control to. It's great.
In some cases I would want to have a different Start and End dates so I guess a new 'sub' could be created, if this makes sense. To enhance this process I would appreicate some help to update the Start and End times.
I added in .display and update from it. But doing so saves the changes to my default calendar and not the other calendar. If I manually do a 'save as' to the other calendar I end up with two appts. on the other calendar (one for the ReceivedTime and one for the updated time ) . What code can be added to eliminate the original appt and keep only the updated one. Or is there a better way?
Thanks very much in advance.
----------------------------------------------------------------Sub ConvertMailtoAccountAppt()
Dim objAppt As Outlook.AppointmentItem
Dim objMail As Outlook.MailItem
Set objAppt = Application.CreateItem(olAppointmentItem)
Set CalFolder = GetFolderPath("zz_helpdesk\Calendar-Systems Schedules")
For Each objMail In Application.ActiveExplorer.Selection
objAppt.Subject = objMail.Subject
'sets it for recd. time AND not tomorrow at 9 AM per sample
objAppt.Start = objMail.ReceivedTime
objAppt.Body = objMail.Body
objAppt.ReminderSet = False
objAppt.Move CalFolder
objAppt.Display
Next
Set objAppt = Nothing
Set objMail = Nothing
'MsgBox ("added to Calendar-Systems Schedules")
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
In some cases I would want to have a different Start and End dates so I guess a new 'sub' could be created, if this makes sense. To enhance this process I would appreicate some help to update the Start and End times.
I added in .display and update from it. But doing so saves the changes to my default calendar and not the other calendar. If I manually do a 'save as' to the other calendar I end up with two appts. on the other calendar (one for the ReceivedTime and one for the updated time ) . What code can be added to eliminate the original appt and keep only the updated one. Or is there a better way?
Thanks very much in advance.
----------------------------------------------------------------Sub ConvertMailtoAccountAppt()
Dim objAppt As Outlook.AppointmentItem
Dim objMail As Outlook.MailItem
Set objAppt = Application.CreateItem(olAppointmentItem)
Set CalFolder = GetFolderPath("zz_helpdesk\Calendar-Systems Schedules")
For Each objMail In Application.ActiveExplorer.Selection
objAppt.Subject = objMail.Subject
'sets it for recd. time AND not tomorrow at 9 AM per sample
objAppt.Start = objMail.ReceivedTime
objAppt.Body = objMail.Body
objAppt.ReminderSet = False
objAppt.Move CalFolder
objAppt.Display
Next
Set objAppt = Nothing
Set objMail = Nothing
'MsgBox ("added to Calendar-Systems Schedules")
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