Copy Appointments to Another Exchange Calendar

[racer25]

Hi All,

Forgive me this is my 1st post and after 3 hours searching and trying to get various solutions to work I surrender.

I am using Outlook 2010 and have 2 Exchange Accounts set-up one is my Corporate Account and one is my Personal Account (Office 365 Exchange).

My Personal Account is connected to my iPad which is great for managing diary when out of the office. At present I drag over the appointments and copy one by one - an awful PIA.

As I said at the start I have been trying to get solutions to work and realise I probably need to combine.

http://www.slipstick.com/outlook-developer/copy-new-appointments-to-another-calendar-using-vba/

and

Working with VBA and non-default Outlook Folders - Slipstick Systems

My Work Calendar appears to be Rob@workplace.com\Calendar

My Personal Calendar appears to be Rob@personalplace.com\Calendar

My VBA experience is limited to mainly copy and paste and following rather than direct coding.

I would really appreciate a dig out in getting this working.
Thanks in advance

Rob

 

[Diane Poremsky]

That first one is all you need - it includes the getfolderpath macro in the second link.




To copy work appointments to the personal calendar you need to change this line:


Set CalFolder = GetFolderPath("display name in folder list\Calendar\Test")




to Set CalFolder = GetFolderPath("Rob@personalplace.com\Calendar")




As an FYI, if the work calendar is enabled for ActiveSync and IT doesn't block ipads, you can get the calendar on the ipad directly. I have 4 exchange calendar synced to my ipad2.

 

[Diane Poremsky]

oh, and if you want to copy all appointments, not just busy ones, you need to remove this line:


If Item.BusyStatus = olBusy Then and the End If above End Sub

 

[racer25]

Hi Diane,




Thanks a million working perfectly.




If I may follow-up is it possible to change the event type during the copy process. Where I have a meeting with 5 people invited and I am required to accept etc. in my Corporate Calendar I am now required to accept in my Personal Calendar.




My rationale is my iPad will keep me informed of whats going on but not require input.




Thanks for the easy (to me) and timely reply.




Rob

 

[Forum Admin]

That code should create appointments, not meetings (and should copy meetings as well as appointments).

It will not copy recurrence data - I'll add that to it when i get a chance.

 

[RookieOne]

Hello @ *

I 've got some trouble with Diane Poremskys solution „Copy new appointments to another calendar using VBA“, too.

In these code lines

Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
   Dim oFolder As Outlook.Folder

I'll get a compilation error because of a wrong defined custom data type.

Well, I replaced .Folder with .MAPIFolder, but the VBA macro won't work - no appointment is created

A colleague gave me another code:

Dim WithEvents AppItems As Outlook.Items 
 
Private Sub Application_Startup()
   Set myOlApp = CreateObject("Outlook.Application")
   Set myNamespace = myOlApp.GetNamespace("MAPI")
   Set myCalendar = myNamespace.GetDefaultFolder(olFolderCalendar)
   Set AppItems = myCalendar.Items 
 
End Sub 
 
Private Sub AppItems_ItemAdd(ByVal Item As Object)
  If Left$(Item.Subject, 11) <> "RookieOne: " Then
       entr = MsgBox("Do you want to copy the Appointment " + Chr(13) + Chr(10) + _
                     Item.Subject + Chr(13) + Chr(10) + _
                     "in the unit calendar, too?", vbYesNo)
       If entr = vbYes Then
           If Termin2PubFolder(Item) = False Then
               result = MsgBox("Appointment couldn't be copied.", vbExclamation)
           End If
       End If
   End If 
 
End Sub 
 
Function Termin2PubFolder(myItem As AppointmentItem) As Boolean 
 
Dim myPubFolder As Folders 
 
Dim myTmpFolder As MAPIFolder 
 
Set myOlApp = CreateObject("Outlook.Application") 
 
Set myNamespace = myOlApp.GetNamespace("MAPI") 
 
Set myCalendar = myNamespace.GetDefaultFolder(olFolderCalendar) 
 
Set myPubFolder = GetNamespace("mapi").GetDefaultFolder(olPublicFoldersAllPublicFolders).Folders 
 
Set myTmpFolder = findFolder(myPubFolder, "Company") 
 
Set myTmpFolder = findFolder(myTmpFolder.Folders, "Division 1") 
 
Set myTmpFolder = findFolder(myTmpFolder.Folders, "Unit 11") 
 
Set myTmpFolder = findFolder(myTmpFolder.Folders, "Calendar") 
 
If myTmpFolder.Name = "Calendar" Then
   myItem.Subject = "RookieOne: " + myItem.Subject
   Set myCopiedItem = myItem.Copy
   myCopiedItem.ReminderSet = False
   myCopiedItem.Move myTmpFolder
   Termin2PubFolder = True 
 
Else
   Termin2PubFolder = False 
 
End If 
 
End Function 
 
Function findFolder(myFold As Folders, srchStrng As String) As MAPIFolder 
 
Set myActFolder = myFold.GetFirst 
 
While (Not myActFolder.Name = srchStrng) And (Not myActFolder = "")
   Set myActFolder = myFold.GetNext 
 
Wend 
 
If myActFolder.Name <> srchStrng Then
   Set findFolder = Nothing 
 
Else
   Set findFolder = myActFolder 
 
End If 
 
End Function

But this code doesn't work, too

Do you have any idea?

Thanks in advance, regards,

Daniel

 

[Diane Poremsky]

It may be due to subtle changes between versions - but I'm pretty sure GetFolderPath was written for Outlook 2003.

I'll check it in 2003 and see if i can repro. Is it stopping on that first line?

 

[RookieOne]

Hello, Diane,

I didn't mentioned it before: You're right: At work, we have Outlook 2003.

... Is it stopping on that first line?

Yes, there it stops.

I set some breaking points in the VBA code to force code stop at an earlier stage, but it seems to me, that the breaking stops will be completely ignored.

Only a „hard“ stop word stopped the code.

Regards, Daniel

 

[bednarol]

Create appointment in Default Outlook Calendar based on an Internet Calendar

I am using Outlook 2013 for office appointments, Gmail for personal. I imported several Gmail calendars to Outlook as Internet Calendars. If there is an event on a certain Internet calendar, e.g. "Family Events", I want to create an event in my default Outlook calendar (lucie@work.com) that will show me busy and the subject will be e.g. "Personal". One thing I struggle with is how do I define that I want to use a certain internet calendar in Outlook (e.g. \\Internet Calendar\Family Events and not \\Internet Calendar\Birthdays). I tried to modify VBA tiny bit but not with much success. I wrote quite a bit of code for Excel but I have zero experience in Outlook..... Here is where I am. I would appreciate any help!!!




Dim WithEvents newCal As Items




Private Sub Application_Startup()


Dim NS As Outlook.NameSpace


Set NS = Application.GetNamespace("MAPI")


Set newCal = NS.GetDefaultFolder(olFolderCalendar).Items


Set NS = Nothing


End Sub




Private Sub newCal_ItemAdd(ByVal Item As Object)


Dim cAppt As AppointmentItem


Dim moveCal As AppointmentItem


' On Error Resume Next


Set CalFolder = GetFolderPath("lucie@work.com")




If Item.BusyStatus = olBusy Then




Set cAppt = Application.CreateItem(olAppointmentItem)




With cAppt


> Subject = "Personal"


> Start = Item.Start


> Duration = Item.Duration


End With




' set the category after it's moved to force EAS to sync changes


Set moveCal = cAppt.Move(CalFolder)


moveCal.Categories = "moved"


moveCal.Save




End If


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

 

[Forum Admin]

Re: Create appointment in Default Outlook Calendar based on an Internet Calend

You need to swap the two lines that identify the calendar -

Set newCal = NS.GetDefaultFolder(olFolderCalendar).Items

should be

Set CalFolder = GetFolderPath("Internet Calendar\Family Events").items

This is the calendar you are creating the new appt in:

Set CalFolder = GetFolderPath("lucie@work.com")

Since its your default calendar, you can use

Set newCal = NS.GetDefaultFolder(olFolderCalendar)

 

[bednarol]

Re: Create appointment in Default Outlook Calendar based on an Internet Calend

Back after Thanksgiving....Thanks for the reply!!! I made the two changes you suggested but I am getting run time error 91 after running the line "Set CalFolder = GetFolderPath("Internet Calendar\Family Events").items". Do I perhaps need to declare CalFolder? Is "Internet Calendar\Family Events" the right way to point to an imported internet calendar?

 

[Diane Poremsky]

Re: Create appointment in Default Outlook Calendar based on an Internet Calend

Right click on the calendar folder and choose properties. the location path and the Calendar name field are what you need to put together to create the path - don't use the leading \\,

Do you have the GetFolderPath function?

 

[bednarol]

Re: Create appointment in Default Outlook Calendar based on an Internet Calend

Right click on the calendar folder and choose properties. the location path and the Calendar name field are what you need to put together to create the path - don't use the leading \\,

Yes, that's how I got the path. But still big thanks for this comment - it made me look at the path again only to realize that I have a typo in there. It should be "Internet Calendars" ;-) and that solved error 91. I felt really stupid, sorry for wasting your time.

Do you have the GetFolderPath function?

Yes, I have been using this function. When I debug, "Application_Startup()" sub runs, calls GetFolderPath function and that's where it seems to finish. The sub "newCal_ItemAdd" does not want to run. Tried to save the code, restart Outlook, no change. What else can I try?

Thanks!

 

[Diane Poremsky]

Re: Create appointment in Default Outlook Calendar based on an Internet Calend

I felt really stupid, sorry for wasting your time.

Look on the bright side - it might help someone else figure out the same problem too.

So its still not working?

 

[bednarol]

Re: Create appointment in Default Outlook Calendar based on an Internet Calend

No, unfortunately, it's not. I am not getting any error code. I think the problem is that the sub newCal_ItemAdd is not triggered. I understand I cannot run that sub as stand alone because of the argument. But I think it should be triggered in the Sub Application_Startup() . So I should either add line to Sub Application_Startup() or I need to make some changes to the newCal_ItemAdd routine. Here is the code after I made the 2 changes you suggested. Hopefully I understood your recommendations correctly.....:

Dim WithEvents newCal As Items

Private Sub Application_Startup()

Dim NS As Outlook.NameSpace

Set NS = Application.GetNamespace("MAPI")

Set CalFolder = GetFolderPath("Internet Calendars\Family Events").Items

Set NS = Nothing

End Sub

Private Sub newCal_ItemAdd(ByVal Item As Object)

Dim cAppt As AppointmentItem

Dim moveCal As AppointmentItem

' On Error Resume Next

Set newCal = NS.GetDefaultFolder(olFolderCalendar)

If Item.BusyStatus = olBusy Then

Set cAppt = Application.CreateItem(olAppointmentItem)

With cAppt

> Subject = "Personal"

> Start = Item.Start

> Duration = Item.Duration

End With

' set the category after it's moved to force EAS to sync changes

Set moveCal = cAppt.Move(CalFolder)

moveCal.Categories = "moved"

moveCal.Save

End If

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]

Re: Create appointment in Default Outlook Calendar based on an Internet Calend

It's possible it won't work with internet calendars, that it won't detect new items.

This tells it where to watch for new items in the app startup:

Set CalFolder = GetFolderPath("Internet Calendars\Family Events").Items

This is the calendar we're moving into:
Set newCal = NS.GetDefaultFolder(olFolderCalendar)

This is where it's moved:
Set moveCal = cAppt.Move(CalFolder)

Hmmm. Something isn't right. You're moving into the watched calendar and not using the newCal.

Back to the original code to make sure I didn't screw up (it's been known to happen). The app start has:
Set newCal = NS.GetDefaultFolder(olFolderCalendar).Items

So... what you need to do is switch the two Set variables.

In app start up, use

Set newCal = GetFolderPath("Internet Calendars\Family Events").Items

and this in the itemadd macro
Set CalFolder = NS.GetDefaultFolder(olFolderCalendar)

(In hindsight, newCal is a bad name for the calendar - it seems like it should be the new calendar you are moving to, not the calendar with the new appointment.)

 

[bednarol]

Re: Create appointment in Default Outlook Calendar based on an Internet Calend

Diane, I went through a very similar thought process yesterday before I posted..... I tried exactly what you have suggested. And it did not work so I sent you a msg.

It's possible it won't work with internet calendars, that it won't detect new items.

I think it should work because when I debug, I can see that the newCal variable does get populated with the internet calendar items. So it is "just" question of syncing those items from the newCal to CalFolder. Sounds simple ;-)

So now I have:

Dim WithEvents newCal As Items

Private Sub Application_Startup()

Dim NS As Outlook.NameSpace

Set NS = Application.GetNamespace("MAPI")

Set newCal = GetFolderPath("Internet Calendars\Lucie").Items

Set NS = Nothing

End Sub

Private Sub newCal_ItemAdd(ByVal Item As Object)

Dim cAppt As AppointmentItem

Dim moveCal As AppointmentItem

' On Error Resume Next

Set CalFolder = NS.GetDefaultFolder(olFolderCalendar)

If Item.BusyStatus = olBusy Then

Set cAppt = Application.CreateItem(olAppointmentItem)

> ..

> ...

> ..

Staring at the routine some more, it seems to me that I am looking for new app in the default calendar and trying to create items there while I should be searching the internet calendar and creating an item in the default. I may not understand the routine 100% correctly but it's just a thought that could lead to some new ideas why it is not working.

 

[bednarol]

Re: Create appointment in Default Outlook Calendar based on an Internet Calend

Diane, your comment about possibly not being able to copy from an internet calendar made me think......So I created a new calendar in my current Outlook profile, was able to copy app from new calendar to the default one but not the other way round.......hmmmm......security settings, permissions came to my mind immediately....Heureka! Sure enough, my default calendar did not have edit permissions. Then switched to internet calendar and it works perfectly! Thanks so much for the ideas that helped resolve the issues. I have one more thing that poped up to make this code useful but not annoying. Here is the code that I am using now:

Dim WithEvents CalToCopy As Items

Private Sub Application_Startup()

'calendar from which new appointments will be copied

Set CalToCopy = GetFolderPath("Internet Calendars\Family").Items

End Sub

Private Sub CalToCopy_ItemAdd(ByVal Item As Object)

Dim cAppt As AppointmentItem

Dim moveCal As AppointmentItem

'define calendar to which the appointments will be copied

Dim NS As Outlook.NameSpace

Set NS = Application.GetNamespace("MAPI")

'using default Outlook calendar, needs to be modified if using different calendar

Set newCalFolder = NS.GetDefaultFolder(olFolderCalendar)

'create new appointment

If Item.BusyStatus = olBusy Then

Set cAppt = Application.CreateItem(olAppointmentItem)

With cAppt

> Subject = "meeting"

> Start = Item.Start

> Duration = Item.Duration

> Location = Item.Location

> ReminderSet = False

End With

' set the category after it's moved to force EAS to sync changes

Set moveCal = cAppt.Move(newCalFolder)

moveCal.Categories = "copied"

moveCal.Save

End If

Set NS = 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

The problem this code has is that it copies all the appointments from the internet calendar to the default one every time Outlook syncs....... So you end up with many duplicates and if you reschedule/cancel something on your internet calendar, it will not change/disappear in the default Outlook calendar. Not ideal.......So since all my copied appointments in the default calendar have the same subject, on each sync I can delete all appointment with certain subject from the default calender and then I can copy all the appointments from internet calendar to the Outlook default one. I am thinking to use something like this for deleting all appointments with given subject:

Private Sub DeleteOldCopies()

Dim NS As Outlook.NameSpace​

Set NS = Application.GetNamespace("MAPI")

Set newCalFolder = NS.GetDefaultFolder(olFolderCalendar)

Dim strbody As String

StrSubject = "Pr: meeting"

Set newCalFolderItems = newCalFolder.Items

For Each AppointmentItem In newCalFolderItems​

If AppointmentItem.Subject = StrSubject Then​

AppointmentItem.Delete​

End If​

Next AppointmentItem​

End Sub

Now I do not know how to pull evething together so that on calendar folder sync Sub DeleteOldCopies() runs first and then Sub CalToCopy_ItemAdd(ByVal Item As Object) is initiated. Obviously, the sequence is important so that the two routines do not fight each other. Any thoughts on how to accomplish this?

 

[RookieOne]

Well, me again

@ Diane: Recently, I have Office 2013 in our company .

When using your code sample „Copy new appointments to another calendar using VBA“ in Outlook 2013, I get an error on this code line

' set the category after it's moved to force EAS to sync changes
Set moveCal = cAppt.Move(newCalFolder)

While moveCal is „Nothing“, newCalFolder gives back the correct folder name instead.

What's wrong here?

Regards, Daniel

 

[Diane Poremsky]

What is the error message?

I got one that said newcalfolder not defined - added
Dim newCalFolder As Folder

under the other dim's and it works.