Pulling outlok calendar into excel - code refinement

[Karmink]

Hi All,

I have cobbled together some VBA code (pased below) to pull calendar information from the user's outlook into and excel s/sheet so we can quickly and easily do team time reporting. So far so good but I have hit a brick wall on three tweaks to the code:
1. I don't want to pull through entries marked as Private (happy if the solution pulls them into excel and then deletes them, as long as they don't show once the code has stopped running)
2. I don't want to show things where the time is classed as "free" (under "show time as" in Outlook)
3. I want to pull information from (today - 1 month) and (today + 1 month) only (i.e. one month retropective and 1 month forecast). At the moment it pulls everything and then filters on this month.

My issue with the first two is that I can't seem to work out which object group these classifications sit under so can't identify them. My isue with the third is that I am tired and getting stupid with it!

Anyone got any tips (or a cheeky sub routine I can call onto do the magic?!)?

Sub ListAllItemsInInbox()

Sheets("Time Report").Select
    Cells.Select
    Selection.ClearContents
    Range("A1").Select
Dim OLF As Outlook.MAPIFolder, CurrUser As String
Dim MeetingItemCount As Integer, i As Integer, MeetingCount As Integer
    Application.ScreenUpdating = False
  
    ' add headings
    Cells(1, 1).Formula = "Subject"
    Cells(1, 2).Formula = "Start time"
    Cells(1, 3).Formula = "Finish time"
    Cells(1, 4).Formula = "Duration (mins)"
    Cells(1, 5).Formula = "Project"
    With Range("A1:z1").Font
        .Bold = True
        .Size = 14
    End With
    Application.Calculation = xlCalculationManual
    Set OLF = GetObject("", _
        "Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
   EmailItemCount = OLF.Items.Count
    i = 0: MeetingCount = 0
    ' read e-mail information
    While i < EmailItemCount
        i = i + 1
        If i Mod 50 = 0 Then Application.StatusBar = "Reading e-mail messages " & _
            Format(i / EmailItemCount, "0%") & "..."
        With OLF.Items(i)
            EmailCount = EmailCount + 1
            Cells(EmailCount + 1, 1).Formula = .Subject
            Cells(EmailCount + 1, 2).Formula = .Start
            Cells(EmailCount + 1, 3).Formula = .End
            Cells(EmailCount + 1, 4).Formula = .Duration
           Cells(EmailCount + 1, 5).Formula = .Categories
           
        End With
    Wend
    Application.Calculation = xlCalculationAutomatic
    Set OLF = Nothing
    Columns("A:D").AutoFit
    Range("A2").Select
    ActiveWindow.FreezePanes = True
    ActiveWorkbook.Saved = True
    Application.StatusBar = False
    
    Call Sortbydate
    
End Sub

Sub Sortbydate()
'sorts meetings by date
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    ActiveWorkbook.Worksheets("Time Report").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Time Report").Sort.SortFields.Add Key:=Range( _
        "B2:B77"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Time Report").Sort
        .SetRange Range("A1:E77")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A1").Select
    Call Select_date_range
End Sub

Sub Select_date_range()
'Filters to only show this month
    Rows("1:1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$Z$76").AutoFilter Field:=2, Criteria1:= _
        xlFilterThisMonth, Operator:=xlFilterDynamic
        
        Call Workbook_username
    
    End Sub
    
Sub Workbook_username()
'Stamps current user name on front sheet
Sheets("Start Page").Select
    Range("A9").Value = "Previously Saved By: "
    Range("B9").Value = Application.username 'Stamp the current user name
     
    Columns("A:B").EntireColumn.AutoFit
    Range("A1").Select
    
    Call Send_to_email

End Sub

Sub Savename()
'CURRENTLY NOT WORKING SO HAVE REMOVED - IF WORKING THIS WOULD SAVE IN THE ARCHIVE FOLDER WITH THE USER'S NAME AND DATE.  NOT VITAL TO SUCCESS.

Sheets("Start Page").Select
     'Saves filename as value of username cell plus the current date
     
    Dim newFile As String, fName As String
     
    fName = Range("b9").Value
     
    newFile = fName & " " & Format$(Date, "mm-dd-yyyy")
     ' Change directory to suit your PC, including USER NAME
   ChDir _
   "R:\some path"
  'added as interim measure to stop crashing while i work out what the issue with the file name is
   
   If fileSaveName = False Then
        Call Send_to_email    End If
  
    ActiveWorkbook.SaveAs Filename:=newFile
     
     Call Send_to_email

End Sub

Sub Send_to_email()
'Launches email with s/sheet as an attachment
Application.Dialogs(xlDialogSendMail).Show
End Sub

Many thanks,

Karmink