VBA to send outlook appointment with recurrence

[pmellor]

Hi,

I've got the below code and it works apart from the recurrence does't pick up, can anyone make any suggestions as to what I've got wrong here?

[/CODE]

Public Sub CreateOutlookAppointments()
   Sheets("Delivery Timeline").Select
    On Error GoTo Err_Execute
    
    Dim olApp As Outlook.Application
    Dim olAppt As Outlook.AppointmentItem
    Dim blnCreated As Boolean
    Dim olNs As Outlook.Namespace
    Dim CalFolder As Outlook.MAPIFolder
    Dim olRecurrPatt As RecurrencePattern
    Dim xRg As Range
    
    Dim i As Long
    
    On Error Resume Next
    Set olApp = Outlook.Application
    
    If olApp Is Nothing Then
        Set olApp = Outlook.Application
         blnCreated = True
        Err.Clear
    Else
        blnCreated = False
    End If
    
    On Error GoTo 0
    
    Set olNs = olApp.GetNamespace("MAPI")
    Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
    Set xRg = Range("E10:N10")
    For i = 1 To xRg.Rows.Count
    
    Set olAppt = CalFolder.Items.Add(olAppointmentItem)
    Set olRecurrPatt = olAppt.GetRecurrencePattern
    
    olAppt.MeetingStatus = olMeeting
    
        With olRecurrPatt
        .RecurrenceType = olRecursWeekly
        .Duration = 10
        .StartTime = #9:00:00 AM#
        .EndTime = #9:10:00 AM#
        .DayOfWeekMask = olMonday
        .PatternStartDate = xRg.Cells(i, 1)
        .Interval = 3
        .PatternEndDate = xRg.Cells(i, 2)
        End With
    With olAppt
        'Define calendar item properties
        .Subject = xRg.Cells(i, 3)
        .Body = xRg.Cells(i, 8)
        .BusyStatus = xRg.Cells(i, 6)
        .ReminderMinutesBeforeStart = xRg.Cells(i, 7)
        .ReminderSet = True

' get the recipients
        Dim RequiredAttendee As Outlook.Recipient
        Set RequiredAttendee = .Recipients.Add(xRg.Cells(i, 10).Value)
            RequiredAttendee.Type = olRequired
            
            

 ' For meetings or Group Calendars
' use .Display instead of .Send when testing or if you want to review before sending
        .Display
        

    End With
    
    Next
    
    Set olAppt = Nothing
    Set olApp = Nothing
    Set myRecurrPatt = Nothing
        
    Exit Sub
    
Err_Execute:
    MsgBox "An error occurred - Exporting items to Calendar."
    
End Sub

 

[Tric19999]

Hi! I had a similar problem. The following worked for me:

Sub CreateAppt()
Dim oRecipt As Outlook.Recipient

    Set OApp = CreateObject("Outlook.Application")
    Set oAppt = OApp.CreateItem(olAppointmentItem)
        
        oAppt.MeetingStatus = Outlook.OlMeetingStatus.olMeeting
        oAppt.Subject = "Begivenhed 700"
        
      
        oAppt.ReminderSet = True
        'oAppt.BusyStatus = Outlook.OlBusyStatus.olFree
        oAppt.Start = "24-10-1983"
        oAppt.AllDayEvent = True
        'oAppt.MeetingStatus = olMeeting
        oAppt.Recipients.Add ("mymail@gmail.com")

        
        oAppt.ResponseRequested = False
        Set objRecurrencePattern = oAppt.GetRecurrencePattern
        objRecurrencePattern.RecurrenceType = olRecursYearly
        oAppt.Send
        
    
End Sub

Hope it helps!

(also, if you keep having the same problem - turn off your computer and start again! I had problems with this and other issues and a restart somehow helped).