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

Meat4grinder

Board Regular
Joined
May 20, 2012
Messages
62
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.
 
Last edited:

Meat4grinder

Board Regular
Joined
May 20, 2012
Messages
62
Well got it semi working i can not get it to send idk why but this is in VBA Excel book

Code:
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

Board Regular
Joined
May 20, 2012
Messages
62
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

Board Regular
Joined
May 20, 2012
Messages
62
Ok i got it working now with automatic sending.

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

Code:
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
 

Forum statistics

Threads
1,081,415
Messages
5,358,533
Members
400,502
Latest member
price83

Some videos you may like

This Week's Hot Topics

  • VBA (Userform)
    Hi All, I just would like to know why my code isn't working. Here is my VBA code: [CODE=vba]Private Sub OKButton_Click() Dim i As Integer...
  • List box that changes fill color
    Hello, I have gone through so many pages trying to figure this out. I have a 2020 calendar that depending on the day needs to have a certain...
  • Remove duplicates and retain one. Cross-linked cases
    Hi all I ran out of google keywords to use and still couldn't find a reference how to achieve the results of a single count. It would be great if...
  • VBA Copy and Paste With Duplicates
    Hello All, I'm in need of some input. My VBA skills are sub-par at best. I've assembled this code from basic research and it works but is...
  • Macro
    is it possible for a macro to run if the active cell value is different to the value above it
  • IF DATE and TIME
    I currently use this to check if date has passed but i also need to set a time on it too. Is it possible? [CODE=vba]=IF(B:B>TODAY(),"Not...
Top