Sub FindAppts()
Dim myStart As Date
Dim myEnd As Date
Dim oCalendar As Outlook.Folder
Dim oItems As Outlook.items
Dim oItemsInDateRange As Outlook.items
Dim oFinalItems As Outlook.items
Dim oAppt As Outlook.AppointmentItem
Dim strRestriction As String
Dim farout As Integer
Dim timeperiod As Integer
Dim strAppt As String
Dim itm, apptSnapshot As Object
Dim morning As Date, afternoon As Date
Dim counter As Integer


   Dim CalItems As Outlook.items
   Dim ResItems As Outlook.items
   Dim sFilter, strSubject
   Dim iNumRestricted As Integer
   Dim tStart As Date, tEnd As Date, tFullWeek As Date
   Dim wd As Integer


' Use the default calendar folder
Set oCalendar = Session.GetDefaultFolder(olFolderCalendar)
Set CalItems = oCalendar.items
' Sort all of the appointments based on the start time
   CalItems.Sort "[Start]"
   CalItems.IncludeRecurrences = True

   tStart = Format(Date + 1, "Short Date")
 
farout = InputBox("How many days out?")

tEnd = DateAdd("d", farout, tStart)
tEnd = Format(tEnd, "Short Date")

sFilter = "[Start] >= '" & tStart & "' AND [Start] <= '" & tEnd & "'"

Debug.Print sFilter
   Set ResItems = CalItems.Restrict(sFilter)

   iNumRestricted = 0

   'Loop through the items in the collection.
   For Each itm In ResItems
   If itm.Duration >= 240 Then
   Debug.Print ResItems.Count
      iNumRestricted = iNumRestricted + 1
      
 ' Create list of appointments
  strAppt = strAppt & vbCrLf & itm.Subject & vbTab & " >> " & vbTab & Format(itm.Start, "m/d/yyyy h:mm AM/PM") & vbTab & " to: " & vbTab & Format(itm.End, "m/d/yyyy h:mm AM/PM")
End If
   Next
   


counter = 0


Set apptSnapshot = Application.CreateItem(olMailItem)
With apptSnapshot
.Body = strAppt & vbCrLf
.To = "null@null"
.Subject = "Availability for " & tStart & " to " & tEnd
.Display 'or .send
End With
Set itm = Nothing
Set apptSnapshot = Nothing
Set ResItems = Nothing
Set CalItems = Nothing
Set CalFolder = Nothing
End Sub