none
Copy Calendars programmatically RRS feed

  • Question

  • Hi, I am struggling to get what I believe is a simple piece of code to work.  

    I need to be able to automatically copy a collection of ever changing calendars (26 of them) in one key project (Project1) for use later on in another project (project2).

    My code is as per below and keeps going into an infinite loop and trying to copy the 26 calendars for a 2nd, 3rd, 4th.... time etc.

    Any ideas please?

    Thanks in advance.

    Sub CopyCal() 

    Dim c As Calendar<u5:p></u5:p>

     

    For Each c In ActiveProject.BaseCalendars<u5:p></u5:p>

    <u5:p> </u5:p>

        If Not c Is Nothing Then<u5:p></u5:p>

    <u5:p> </u5:p>

        OrganizerMoveItem Type:=5, FileName:="Project1", ToFileName:="Project2"<u5:p></u5:p>

      <u5:p></u5:p>

        End If<u5:p></u5:p>

      <u5:p></u5:p>

    Next c<u5:p></u5:p>

    <u5:p> </u5:p>

    <u5:p> </u5:p>

    MsgBox ("calendars copied")<u5:p></u5:p>

    <u5:p> </u5:p>

        <u5:p></u5:p>

    End Sub<u5:p></u5:p>

    <u5:p></u5:p>

    Monday, January 8, 2018 9:36 AM

All replies

  • This works just fine for me:


    Sub CopyCal()
        Dim c As Calendar
        For Each c In ActiveProject.BaseCalendars
            If Not c Is Nothing Then
                'MsgBox c.Name
                If c.Name <> "Standard" Then OrganizerMoveItem Type:=5, FileName:=ActiveProject.Name, ToFileName:="Project1", Name:=c.Name
            End If
        Next c
        MsgBox ("calendars copied")
    End Sub
    


    Thursday, January 18, 2018 7:59 PM
  • Bill.B,

    Pardon my bump in. I have just a couple comments to your excellent response.

    Good catch about avoiding the alert for the "Standard" calendar. Although normally a good practice, the "If Not c is Nothing Then" statement is not needed since in any project the base calendar object is never null, there is always the Standard calendar. Also I had to add the ".mpp" extension to the filenames to avoid a File not found error.

    John

    Thursday, January 18, 2018 8:33 PM