Copy calendar items to all calendars - Outlook

[esib]

Hello everyone

I would like to find a way to copy all items from a calendar in one of my personal folders to all my calendars, which are spread accross multiple folders. I am not aware of a setting to synchronize all of them, so figured I could do this through VBA. Problem is I have not worked with outlook in a while and was wondering if someone could give me a jumpstart of how I might do this.

Thanks for any help

Eric

 

[rdgerken]

Add the Microsoft Outlook Object library reference for starters...

here is just a chunk of code I used to extract my appointments from one of my calendars. You could use this as a starting point... hope this helps

Private Sub Calendar1_Click()

Dim myOlApp As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myFolder As Outlook.MAPIFolder
Dim myItems As Outlook.Items
Dim myAppItem As Outlook.AppointmentItem
Dim varDate As Variant
Dim varAppDate As Variant
Dim strAppStart As String
Dim strAppEnd As String
Dim i As Integer
Dim lstItem As ListItem

    ListView1.ListItems.Clear
    
    While Weekday(Calendar1.Value) <> 7
        Calendar1.PreviousDay
    Wend
    
    Set myOlApp = New Outlook.Application
    Set myNameSpace = myOlApp.GetNamespace("MAPI")
    Set myFolder = myNameSpace.GetDefaultFolder(olFolderCalendar)
    Set myItems = myFolder.Items
    varDate = Split(Calendar1.Value, "/")
    ProgressBar1.Min = 0
    ProgressBar1.Max = myItems.Count
    ProgressBar1.Value = 0
    Set myAppItem = myItems.GetFirst
    For Each myAppItem In myItems
        ProgressBar1.Value = ProgressBar1.Value + 1
        varAppDate = Split(myAppItem.Start, "/")
        strAppStart = Trim(Right(myAppItem.Start, 11))
        strAppEnd = Trim(Right(myAppItem.End, 11))
        If (CInt(varAppDate(0)) = CInt(varDate(0))) And (CInt(varAppDate(1)) >= CInt(varDate(1)) And CInt(varAppDate(1)) <= (CInt(varDate(1)) + 6)) And (CInt(Left(varAppDate(2), 4)) = CInt(varDate(2))) Then
            'MsgBox myAppItem.Location & " - " & myAppItem.Subject & " - " & strAppStart & " to " & strAppEnd
            Set lstItem = ListView1.ListItems.Add(, , myAppItem.Location)
            lstItem.ListSubItems.Add 1, , myAppItem.Subject
            lstItem.ListSubItems.Add 2, , strAppStart
            lstItem.ListSubItems.Add 3, , strAppEnd
            If myAppItem.Categories = "Business" Then
                lstItem.Checked = True
            End If
        End If
    Next
    
Set myOlApp = Nothing

End Sub

 

[rdgerken]

Sorry, I guess I should mention that the code above was written in VB6 - but it should be very similar in VBA