Public Sub CreatePatternsAppointmentSeries()
  Dim objAppt As Outlook.AppointmentItem
  Dim objAppt2 As Outlook.AppointmentItem
  Dim NumOfDays As Long
  Dim Offset As Long
  Dim NumAppt As Long
  Dim nextAppt '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("How many months in the series? (1 appointment per month)")

'change this line for other dates
pdtmdate = LastMondayofMonth(Format(pdtmdate, "MM/dd/yyyy"))


For x = 1 To NumAppt
Set objAppt2 = Application.CreateItem(olAppointmentItem)
      
 ' calculate other dates in this line, "pdtmdate +14,"
      pdtmdate = Format(pdtmdate, "MM/dd/yyyy")

With objAppt
' I'm using a limited number of fields, you can
' add others.
        objAppt2.Subject = .Subject
        objAppt2.Location = .Location
        objAppt2.Body = .Body
        objAppt2.Start = Format(pdtmdate, "MM/dd/yyyy") & _
           " " & Format(objAppt.Start, "hh:mm AMPM")
        objAppt2.Duration = .Duration
        objAppt2.Categories = .Categories
      End With
      On Error Resume Next
      objAppt2.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 = LastMondayofMonth(Format(pdtmdate, "MM/dd/yyyy"))

Next x
 
End If
   
    Set objAppt = Nothing
    Set objAppt2 = Nothing
     

End Sub




Function LastMondayofMonth(pdtmdate As Date) As Date
 Dim dtmLastOfMonth As Date
  
    dtmLastOfMonth = DateSerial(Year(pdtmdate), Month(pdtmdate) + 1, 0)
    Select Case Weekday(dtmLastOfMonth)
         Case vbMonday: LastMondayofMonth = dtmLastOfMonth - 4
         Case vbTuesday: LastMondayofMonth = dtmLastOfMonth - 4
         Case vbWednesday: LastMondayofMonth = dtmLastOfMonth - 2
         Case vbThursday: LastMondayofMonth = dtmLastOfMonth - 2
         Case vbFriday: LastMondayofMonth = dtmLastOfMonth - 2
         Case vbSaturday: LastMondayofMonth = dtmLastOfMonth - 3
         Case vbSunday: LastMondayofMonth = dtmLastOfMonth - 4
    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