Use VBA Excel userform to create an annual recurring appointment in Microsoft outlook

[Meat4grinder]

TRying to make a simple Appointment that is recurring annually in outlook.

Need the code to include
Subject - userform (clientname)
Location - userform (Address)
all day event
mark as unbusy
Body - Multiple userform entry (Phone number-email-description)
categorize orange Name of it is "Annual Service"
recurrance - yearly from date of creation
(would be great if i can have it automatically choose first monday of that specific month)


found some code online but have no clue what its referring to and even how to put it together.

Any help would be great.

 

[Meat4grinder]

Well got it semi working i can not get it to send idk why but this is in VBA Excel book

Private Sub CommandButton1_Click()
 Dim oAppt As AppointmentItem
 Dim oPattern As RecurrencePattern
 
 Set MyOLApp = CreateObject("Outlook.application")
 Set oAppt = MyOLApp.CreateItem(olAppointmentItem)
 Set oPattern = oAppt.GetRecurrencePattern
 
 
 
        With oPattern
           
           ' Appointment occurs every n-th year (with n indicated by the Interval property).
           .RecurrenceType = olRecursYearNth
           ' Appointment occurs on Monday.
           .DayOfWeekMask = olMonday
           ' Appointment occurs in June.
           .MonthOfYear = Month(Date)
           ' Appointment occurs on week generated
           .Instance = GetCalendarTypeMonthWeek(Now - 1)
           ' Appointment occurs three times.
           .Occurrences = 10
           ' Appointment lasts for 180 minutes each time.
           .Duration = 0
           ' Appointment becomes effective on June 1, 2009.
           .PatternStartDate = (Date)
           ' Appointment starts at 2 P.M.
           .StartTime = #8:00:00 AM#
           ' Appointment ends at 5 P.M.
           .EndTime = #8:00:00 AM#
           ' Appointment recurs every 2 years (per a RecurrenceType of olRecursYearNth).
        End With
    oAppt.Subject = "Recurring every 1 year YearNth Appointment"
    oAppt.Location = "Here"
    oAppt.Body = "more information here"
    oAppt.Categories = "Annual Service"
    oAppt.OptionalAttendees = "me@hotmail.com" 'Change the email addy  i can not get it to send yet idk why
    oAppt.AllDayEvent = True
    oAppt.ResponseRequested = True
    oAppt.Display
    oAppt.Send
End Sub


Function GetCalendarTypeMonthWeek(dt As Date) As String


    Dim lngDayOfMonth As Long
    Dim lngWeekDay As Long
    Dim dtFirstDayOfMonth As Date
    Dim lngFactor As Long


    lngDayOfMonth = Day(dt)
    lngWeekDay = Weekday(dt, vbSunday) '<~~ Sunday=1, Monday=2, etc


    'does month start on Sunday?
    dtFirstDayOfMonth = DateValue("01-" & Month(dt) & "-" & Year(dt))
    If Weekday(dtFirstDayOfMonth, vbSunday) = 1 Then
        lngFactor = 1
    Else
        lngFactor = 2
    End If


    'get calendar week number for date
    GetCalendarTypeMonthWeek = CStr(Int((lngDayOfMonth - lngWeekDay) / 7) + lngFactor)


End Function

 

[Meat4grinder]

One more addition i need done i would like this to go to a specific calender call it (Test Calender)


Any help in finishing up this would be great.

 

[Meat4grinder]

Ok i got it working now with automatic sending.

Still can not figure out this to go to a specific calender, someone please help.

Sub EmailClient()


Dim O As Outlook.Application
Dim OAPT As Outlook.Appointmentitem
Dim oPattern As RecurrencePattern




Set O = New Outlook.Application
Set OAPT = O.CreateItem(olAppointmentitem)
Set oPattern = OAPT.GetRecurrencePattern




        
OAPT.MeetingStatus = olmeeting


        With oPattern
           ' Appointment occurs every n-th year (with n indicated by the Interval property).
           .RecurrenceType = olRecursYearNth
           ' Appointment occurs on Monday.
           .DayOfWeekMask = olSunday
           ' Appointment occurs in June.
           .MonthOfYear = Month(Date)
           ' Appointment occurs on week generated
           .Instance = GetCalendarTypeMonthWeek(Now - 1)
           ' Appointment occurs three times.
           .Occurrences = 20
           ' Appointment lasts for 180 minutes each time.
           .Duration = 0
           ' Appointment becomes effective on June 1, 2009.
           .PatternStartDate = DateAdd("yyyy", 1, (Date))
           ' Appointment starts at 2 P.M.
           .StartTime = #8:00:00 AM#
           ' Appointment ends at 5 P.M.
           .EndTime = #8:00:00 AM#
           ' Appointment recurs every 2 years (per a RecurrenceType of olRecursYearNth).
        End With
    With OAPT
        .Subject = "Annual Service for Overhead door Reminder for " & Me.TB_Name.Value
        .Location = Me.TB_Address.Value & ". " & Me.TB_City
        .Body = "Respond to this email and confirm service for this reminder.  Without the confirmation service will not be scheduled" & vbNewLine _
                & "Phone: " & Me.TB_Phone.Value & vbNewLine _
                & "Cell: " & Me.TB_Cell.Value & vbNewLine _
                & Me.TB_Description.Value
        .Categories = "Annual Service"
        .OptionalAttendees = Me.TB_Email.Value
        .AllDayEvent = True
        .ResponseRequested = True
        .display
        '.Send
    End With


End Sub