Public Sub CreatePatternsAppointmentSeries()
  Dim objAppt, objAppt1, objAppt2, objAppt3, objAppt4 As Outlook.AppointmentItem
  Dim objAppt5, objAppt6, objAppt7 As Outlook.AppointmentItem
  Dim NumOfDays, NumAppt As Long
  Dim Offset1, Offset2, Offset3, Offset4 As Long
  Dim Offset5, Offset6, Offset7, Offset8 As Long
  Dim nextAppt, pdtmdate As Date
 
 Set objAppt = GetCurrentItem()
 If TypeName(objAppt) = "AppointmentItem" Then
    
pdtmdate = InputBox("Enter Beginning Month and Year in mm/yyyy Format", _
      "First month of series", Format(Now, "mm/yyyy"))
NumAppt = InputBox("Enter Number Of Months you want Appiontments Generated", _
 "For Example: Enter 12 for One Year")  'Months in the Series?
 
Offset1 = -58 'Last Date to Public Noticing & Mail/post Tos(cc EO)
Offset2 = -29 'DC's Send Draft Agenda Items Titles to EA; DCs Provide Item Status at next Manager Mtg.
Offset3 = -28 'EA Emails Tenative Agenda to Translation Service for Spanish Version
Offset4 = -16 'Mail/ Post Final Agenda; Packages(SSR, TO, etc.)due to EO,Ready Production
Offset5 = -14 'Staff Sends Items in PDF for web posting through Track-it, once Ok'd by EO
Offset6 = -7  'Mail Board Packages & Post Board Items on Board Website ( HARD DATE!)
Offset7 = 2   'Schedule Outlook Apptointment with EO to Digitaly sign Final Board Items
 
'Change this line for other dates
pdtmdate = FirstWedofMonth(Format(pdtmdate, "MM/dd/yyyy"))
  
For x = 1 To NumAppt

' To calculate other dates in this line, "pdtmdate +14,"
      pdtmdate = Format(pdtmdate + 7, "MM/dd/yyyy", vbWednesday)
      
' Test Holiday For Board Meeting
   pdtmdate = TestHoliday(pdtmdate)
 
' ( Board Meeting )
Set objAppt0 = Application.CreateItem(olAppointmentItem)
    With objAppt
        objAppt0.Subject = "Board Meeting"
        objAppt0.Location = ""
        objAppt0.Body = .Body
        objAppt0.Start = Format(pdtmdate, "MM/dd/yyyy") & _
           " " & Format(objAppt.Start, "hh:mm AMPM")
        objAppt0.Duration = .Duration
        objAppt0.Categories = .Categories
      End With
      On Error Resume Next
      objAppt0.Save

' Initialize Objects
 newDate1 = objAppt0.Start + Offset1
 newDate2 = objAppt0.Start + Offset2
 newDate3 = objAppt0.Start + Offset3
 newDate4 = objAppt0.Start + Offset4
 newDate5 = objAppt0.Start + Offset5
 newDate6 = objAppt0.Start + Offset6
 newDate7 = objAppt0.Start + Offset7
 
 'Check for Holidays
nextDate1 = TestHoliday(Format(newDate1, "MM/dd/yyyy"))
nextDate2 = TestHoliday(Format(newDate2, "MM/dd/yyyy"))
nextDate3 = TestHoliday(Format(newDate3, "MM/dd/yyyy"))
nextDate4 = TestHoliday(Format(newDate4, "MM/dd/yyyy"))
nextDate5 = TestHoliday(Format(newDate5, "MM/dd/yyyy"))
nextDate6 = TestHoliday(Format(newDate6, "MM/dd/yyyy"))
nextDate7 = TestHoliday(Format(newDate7, "MM/dd/yyyy"))

' Create 1st event(Last Date to Public Noticing & Mail/post TOs(cc EO))
 Set objAppt1 = Application.CreateItem(olAppointmentItem)
      With objAppt
        objAppt1.Subject = "Last Date to Public Noticing & Mail/post TOs(cc EO)"
        objAppt1.Location = ""
        objAppt1.Body = .Body
        objAppt1.Start = nextDate1
        objAppt1.Duration = .Duration
        objAppt1.Categories = .Categories
      End With
      On Error Resume Next
      objAppt1.Save
   
    
      ' Create 2nd event( DC's Send Draft Agenda Items Titles to EA; DCs Provide Item Status at next Manager Mtg.)
 Set objAppt2 = Application.CreateItem(olAppointmentItem)
      With objAppt
        objAppt2.Subject = "DC's Send Draft Agenda Items Titles to EA; DCs Provide Item Status at next Manager Mtg."
        objAppt2.Location = ""
        objAppt2.Body = .Body
        objAppt2.Start = nextDate2
        objAppt2.Duration = .Duration
        objAppt2.Categories = .Categories
      End With
      On Error Resume Next
      objAppt2.Save
           
  ' Create 3th Event ( EA Emails Tenative Agenda to Translation Service for Spanish Version )
  Set objAppt3 = Application.CreateItem(olAppointmentItem)
      With objAppt
        objAppt3.Subject = " EA Emails Tenative Agenda to Translation Service for Spanish Version"
        objAppt3.Location = ""
        objAppt3.Body = .Body
        objAppt3.Start = nextDate3
        objAppt3.Duration = .Duration
        objAppt3.Categories = .Categories
      End With
      On Error Resume Next
      objAppt3.Save
       
      ' Create 4th event(Mail/ Post Final Agenda; Packages(SSR, TO, etc.)due to EO,Ready Production)
 Set objAppt4 = Application.CreateItem(olAppointmentItem)
      With objAppt
        objAppt4.Subject = "Mail/ Post Final Agenda; Packages(SSR, TO, etc.)due to EO,Ready Production"
        objAppt4.Location = ""
        objAppt4.Body = .Body
        objAppt4.Start = nextDate4
        objAppt4.Duration = .Duration
        objAppt4.Categories = .Categories
      End With
      On Error Resume Next
      objAppt4.Save
               
    ' Create 5th event(Staff Sends Items in PDF for web posting through Track-it, once Ok'd by EO)
 Set objAppt5 = Application.CreateItem(olAppointmentItem)
      With objAppt
        objAppt5.Subject = "Staff Sends Items in PDF for web posting through Track-it, once Ok'd by EO"
        objAppt5.Location = ""
        objAppt5.Body = .Body
        objAppt5.Start = nextDate5
        objAppt5.Duration = .Duration
        objAppt5.Categories = .Categories
      End With
      On Error Resume Next
      objAppt5.Save
        
' Create 6th Event ( Mail Board Packages & Post Board Items on Board Website (HARD DATE!))(6)
 Set objAppt6 = Application.CreateItem(olAppointmentItem)
      With objAppt
        objAppt6.Subject = " Mail Board Packages & Post Board Items on Board Website (HARD DATE!)"
        objAppt6.Location = ""
        objAppt6.Body = .Body
        objAppt6.Start = nextDate6
        objAppt6.Duration = .Duration
        objAppt6.Categories = .Categories
      End With
      On Error Resume Next
      objAppt6.Save
        
' Create 7th event(Schedule Outlook Apptointment with EO to Digitaly sign Final Board Items)(7)
 Set objAppt7 = Application.CreateItem(olAppointmentItem)
      With objAppt
        objAppt7.Subject = "Schedule Outlook Apptointment with EO to Digitaly sign Final Board Items"
        objAppt7.Location = ""
        objAppt7.Body = .Body
        objAppt7.Start = nextDate7
        objAppt7.Duration = .Duration
        objAppt7.Categories = .Categories
      End With
      On Error Resume Next
      objAppt7.Save
        
     ' Get the next month before looping back through
If Format(pdtmdate, "mm") < 12 Then
    pdtmdate = Format(pdtmdate, "mm") + 1 & "/" & Format(pdtmdate, "yyyy")
Else
   pdtmdate = Format("1/1/2009", "mm") & "/" & (Format(pdtmdate, "yyyy") + 1)
End If
 
 
pdtmdate = FirstWedofMonth(Format(pdtmdate, "MM/dd/yyyy"))
 
Next x
  
End If
    
    Set objAppt = Nothing
    Set objAppt0 = Nothing
    Set objAppt1 = Nothing
    Set objAppt2 = Nothing
    Set objAppt3 = Nothing
    Set objAppt4 = Nothing
    Set objAppt5 = Nothing
    Set objAppt6 = Nothing
    Set objAppt7 = Nothing
    
 
End Sub
 
 
Function FirstWedofMonth(pdtmdate As Date) As Date
Dim dtmFirstOfMonth As Date

dtmFirstOfMonth = DateSerial(Year(pdtmdate), Month(pdtmdate), 1)
Select Case Weekday(dtmFirstOfMonth)
Case vbMonday: FirstWedofMonth = dtmFirstOfMonth + 2
Case vbTuesday: FirstWedofMonth = dtmFirstOfMonth + 1
Case vbWednesday: FirstWedofMonth = dtmFirstOfMonth
Case vbThursday: FirstWedofMonth = dtmFirstOfMonth + 6
Case vbFriday: FirstWedofMonth = dtmFirstOfMonth + 5
Case vbSaturday: FirstWedofMonth = dtmFirstOfMonth + 4
Case vbSunday: FirstWedofMonth = dtmFirstOfMonth + 3

End Select
End Function
 
 
Function GetCurrentItem() As Object
    Dim objApp As Outlook.Application
             
    Set objApp = Application
    On Error Resume Next
    Select Case TypeName(objApp.ActiveWindow)
        Case "Explorer"
            Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
        Case "Inspector"
            Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
    End Select
         
    Set objApp = Nothing
End Function

Function TestHoliday(pdate As Date) As Date
  Dim nDate As Date

 nDate = pdate

' Check for California State Holidays entered as mm/dd/yyyy format
 Dim arrHolidays  As Variant
arrHolidays = Array("12/25/2013", "12/25/2014", "12/25/2015", "12/26/2016", "12/25/2017", "12/25/2018", "12/25/2019", "12/25/2020", _
"7/4/2013", "7/4/2014", "7/4/2015", "7/4/2016", "7/4/2017", "7/4/2018", "7/4/2019", "7/4/2020", _
"9/2/2013", "9/1/2014", "9/7/2015", "9/5/2016", "9/4/2017", "9/3/2018", "9/2/2019", "9/7/2020", _
"1/20/2014", "1/19/2015", "1/18/2016", "1/16/2017", "1/15/2018", "1/21/2019", "1/20/2020", _
"5/27/2013", "5/26/2014", "5/25/2015", "5/30/2016", "5/29/2017", "5/28/2018", "5/27/2019", "5/25/2020", _
"1/1/2014", "1/1/2015", "1/1/2016", "1/2/2017", "1/1/2018", "/1/2019", "1/1/2020", _
"11/27/2014", "11/26/2015", "11/24/2016", "11/23/2017", "11/22/2018", "11/28/2019", "11/26/2020", _
"11/29/2013", "11/28/2014", "11/26/2015", "11/25/2016", "11/24/2017", "11/23/2018", "11/29/2019", "11/27/2020", _
"11/11/2013", "11/11/2014", "11/11/2015", "11/11/2016", "11/11/2017", "11/11/2018", "11/11/2019", "11/11/2020", _
"2/17/2014", "2/16/2015", "2/15/2016", "2/20/2017", "2/19/2018", "2/18/2019", "2/17/2020", _
"3/31/2014", "3/31/2015", "3/31/2016", "3/31/2017", "3/31/2018", "4/1/2019", "3/31/2020")

' Go through the array and look for a match, then do something
For i = LBound(arrHolidays) To UBound(arrHolidays)
If InStr(nDate, arrHolidays(i)) Then nDate = DateAdd("d", -1, nDate)
   
  Select Case Weekday(nDate, vbUseSystemDayOfWeek)
  Case vbSunday
    nDate = DateAdd("d", -2, nDate)
  Case vbSaturday
    nDate = DateAdd("d", -1, nDate)
  End Select
 
Next i
 
  TestHoliday = CDate(nDate)
  
End Function