Macro to search emails between two time slots on public folders with excel export

[Kev]

Hey guys,

New to this forum, fantastic ressource for non-advanced Outlook user like myself! Learning a lot just reading through posts and creating some basic macros in VBA!

I have a specific problem in Outlook 2013 that I cannot solve via the Advanced Query Builder and that I believe a macro would solve.

My outlook account is configured as an Exchange server and I am trying to retrieve from public folders (which contains a lot of email in various sub-folders - probably a mis-use/bad habit to stock emails there!) for emails sent between 2 specific dates and 2 specific time slots + generate the list in an excel format.

I have found an old post with a fantastic little macro (huge thanks to its creator!) which almost does this - but is limited to the current folder selected and does not scan ALL folders. I have tried to adapt this macro by replacing some lines with the "olAllPublicFolders" but I am not sure I am replacing the correct line...about to give up!

Can this be done at all? Can any expert advise on this? thanks so much for your input!

I am pasting below the original macro - once again i am not the author of this little gem, long may he live ))

Const FILE_NAME = "X:\kevDTSearchallfolders.xlsx"
Const MACRO_NAME = "Date/Time Search"

Private datBeg As Date, datEnd As Date, timBeg As Date, timEnd As Date
Private excApp As Object, excWkb As Object, excWks As Object, lngRow

Public Sub BeginSearch()
Dim strRng As String, arrTmp As Variant, arrDat As Variant, arrTim As Variant
strRng = InputBox("Enter the date/time range to search in the form Date1 to Date2 from Time1 to Time2", MACRO_NAME, "1/1/2014 to 1/31/2014 from 10:00am to 11:00am")
If strRng = "" Then
MsgBox "Search cancelled.", vbInformation + vbOKOnly, MACRO_NAME
Else
arrTmp = Split(strRng, " from ")
arrDat = Split(arrTmp(0), " to ")
arrTim = Split(arrTmp(1), " to ")
datBeg = arrDat(0)
datEnd = arrDat(1)
timBeg = arrTim(0)
timEnd = arrTim(1)
If IsDate(datBeg) And IsDate(datEnd) And IsDate(timBeg) And IsDate(timEnd) Then
Set excApp = CreateObject("Excel.Application")
Set excWkb = excApp.Workbooks.Add
Set excWks = excWkb.Worksheets(1)
excWks.Cells(1, 1) = "Folder"
excWks.Cells(1, 2) = "Received"
excWks.Cells(1, 3) = "Sender"
excWks.Cells(1, 4) = "Subject"
lngRow = 2
SearchSub Application.ActiveExplorer.CurrentFolder
excWks.Columns("A").AutoFit
excWkb.SaveAs FILE_NAME
excWkb.Close False
Set excWks = Nothing
Set excWkb = Nothing
Set excApp = Nothing
MsgBox "Search complete.", vbInformation + vbOKOnly, MACRO_NAME
Else
MsgBox "The dates/times you entered are invalid or not in the right format. Please try again.", vbCritical + vbOKOnly, MACRO_NAME
End If
End If
End Sub

Private Sub SearchSub(olkFol As Outlook.MAPIFolder)
Dim olkHit As Outlook.Items, olkItm As Object, olkSub As Outlook.MAPIFolder, datTim As Date
'If the current folder contains messages, then search it
If olkFol.DefaultItemType = olMailItem Then
Set olkHit = olkFol.Items.Restrict("[senton] >= '" & Format(datBeg, "ddddd h:nn AMPM") & "' AND [Senton] <= '" & Format(datEnd, "ddddd h:nn AMPM") & "'")
For Each olkItm In olkHit
If olkItm.Class = olMail Then
datTim = Format(olkItm.SentOn, "h:n:s")
If datTim >= timBeg And datTim <= timEnd Then
excWks.Cells(lngRow, 1) = olkFol.FolderPath
excWks.Cells(lngRow, 2) = olkItm.SentOn
excWks.Cells(lngRow, 3) = olkItm.SenderName
excWks.Cells(lngRow, 4) = olkItm.Subject
lngRow = lngRow + 1
End If
End If
DoEvents
Next
Set olkHit = Nothing
Set olkItm = Nothing
End If
'Search the subfolders
For Each olkSub In olkFol.Folders
SearchSub olkSub
DoEvents
Next
Set olkSub = Nothing
End Sub

 

[Diane Poremsky]

You need to walk each folder and run the search - then move to the next and run it.

See OutlookCode.com :: Get Public Folder for one code example to get public folder names.

 

[Kev]

Thanks Diane for your reply!

The Macro returns a blank file when I run it form a public folder - it works on all "local" folders (Inbox, sent items etc) but doesnt work on any folder on the server - not sure why!

 

[Diane Poremsky]

Is it finding the folders? Add msgbox olkFol.name (or debug.print olkFol.name) to the searchsub macro - see if it's finding the folders. Depending on the version of exchange, you might need to use olpostitem instead of olMailItem

Are you caching PF? In older versions at least, that did cause issues with macros - they worked fine if online, but not in cached mode.

I don't have any public folders set up on my office 365 account to test it - if i get a chance, i'll add PF to another tenant and see what i get. (It might not mean much tho, if you have traditional PF.)

 

[Kev]

Diane,

Thanks a lot - adding the msgbox olkFol.name line and running the macro while selecting a PF folder, the macro does find the PF folder and subfolder but the excel files is blank appart from the header columns even though there should be some emails which correspond to the search retrieved.

The PF is a shared ressource between all staff - i dont think its cached. Weird that it doesnt retrieve anything and the macro doesnt seem to fail.

Thanks so much for your help!

 

[Diane Poremsky]

You could use debug.print olkFol.FolderPath, olkItm.SentOn, olkItm.SenderName, olkItm.Subject to see if it's finding anything. If these are blank, start with commenting out If olkItm.Class = olMail Then (and it's end if) and run it again.

If you step into it and watch the code, is it skipping lines?

What version of Exchange are you using?

 

[Kev]

Thanks Diane, i had to leave the office for an external meeting, I ll run your kind suggestions when back and report!
Best wishes

 

[Kev]

Diane,

I have tried various suggestions - stepping into the code and comparing what the macro is doing when its working properly on a "local" folder and when its not working on a "PF" folder.

As far as i can see, when executing on a PF, the Macro stumbles on If olkFol.DefaultItemType = olMailItem Then. On the local folder, the macro cycles through the next and retrieves the emails that match the criterion various times on each subfolder until the final End If.

On a PF folder, the Macro goes from If olkFol.DefaultItemType = olMailItem Then to the associated EndIF without retrieving the emails that match (i have checked there are some in there!).

Is there a different variable than olkFol.DefaultItemType to adress a PF type folder?

Runnin Exchange version 14.3.279.4002

Thanks a lot!

kev

 

[Diane Poremsky]

Dang. I didn't mean to delete that post - it looked like it posted twice so i deleted one and apparently that deleted both. If you get email notifications with the text of the post I deleted, please copy the text and repost it.

I looks like the problem was the folder type. Rather than check the folder type, just stick with the item type. If you don't have many non-mail items, it shouldn't slow it down much, if you do, use a Goto to jump to the next folder when it detects a non-mail item. if there are posts in the folders too, you'll need to check for and skip them.

 

[Kev]

Thanks a lot Diane, really helpful!

Reposting your first message

ok - so just as i thought - it's the folder type. if it's only running on PF, I'd remove that IF/End If and only check for the item type (which you are already doing). Only drawback is that it has the potential to slow it down if you have a lot of non-mail items... if there are a lot of non-mail items, maybe exit the loop and move to the next folder when it hits an item that isn't mail. (As long as you aren't mixing posts and mail in a folder, this should still get all mail.)

If olkItm.Class = olMail Then
' do whatever
Else
Goto NextFolder
End If
-- snipped--

NextFolder:
For Each olkSub In olkFol.Folders

 

[Kev]

Diane,

I was trying out your suggestion - if i understand well the code on the Sub should be like this?
Or should i remove completely the
If olkFol.DefaultItemType = olMailItem Then

Sorry for my total imcompetence!

Private Sub SearchSub(olkFol As Outlook.MAPIFolder)
Dim olkHit As Outlook.Items, olkItm As Object, olkSub As Outlook.MAPIFolder, datTim As Date
'If the current folder contains messages, then search it
If olkFol.DefaultItemType = olMailItem Then
Set olkHit = olkFol.Items.Restrict("[senton] >= '" & Format(datBeg, "ddddd h:nn AMPM") & "' AND [Senton] <= '" & Format(datEnd, "ddddd h:nn AMPM") & "'")
For Each olkItm In olkHit
If olkItm.Class = olMail Then
datTim = Format(olkItm.SentOn, "h:n:s")
Else: GoTo NextFolder
End If
If datTim >= timBeg And datTim <= timEnd Then
excWks.Cells(lngRow, 1) = olkFol.FolderPath
excWks.Cells(lngRow, 2) = olkItm.SentOn
excWks.Cells(lngRow, 3) = olkItm.SenderName
excWks.Cells(lngRow, 4) = olkItm.Subject
lngRow = lngRow + 1
End If
DoEvents
Next
Set olkHit = Nothing
Set olkItm = Nothing
End If
'Search the subfolders
For Each olkSub In olkFol.Folders
SearchSub olkSub
DoEvents
Next
Set olkSub = Nothing
End Sub

 

[Diane Poremsky]

Or should i remove completely the
If olkFol.DefaultItemType = olMailItem Then

completely remove this line (in it's End if)

This might work -

Private Sub SearchSub(olkFol As Outlook.MAPIFolder)
Dim olkHit As Outlook.Items, olkItm As Object, olkSub As Outlook.MAPIFolder, datTim As Date
'If the current folder contains messages, then search it

Set olkHit = olkFol.Items.Restrict("[senton] >= '" & Format(datBeg, "ddddd h:nn AMPM") & "' AND [Senton] <= '" & Format(datEnd, "ddddd h:nn AMPM") & "'")
For Each olkItm In olkHit
If olkItm.Class = olMail Then
datTim = Format(olkItm.SentOn, "h:n:s")
Else: GoTo NextFolder
End If
If datTim >= timBeg And datTim <= timEnd Then
excWks.Cells(lngRow, 1) = olkFol.FolderPath
excWks.Cells(lngRow, 2) = olkItm.SentOn
excWks.Cells(lngRow, 3) = olkItm.SenderName
excWks.Cells(lngRow, 4) = olkItm.Subject
lngRow = lngRow + 1
End If
DoEvents
Next

Set olkHit = Nothing
Set olkItm = Nothing

NextFolder:
'Search the subfolders
For Each olkSub In olkFol.Folders
SearchSub olkSub
DoEvents
Next
Set olkSub = Nothing
End Sub

 

[Kev]

Diane, thanks so much this was indeed the solution!! Absolutely brilliant! The Macro works perfectly well on both local folders and PF folders, this makes retrieving emails in a huge inbox a breeze!

i am pasting here the full macro for other users - Many thanks to the original creator and to Diane for their expert input and knowledge of VBA!

Const FILE_NAME = "X:\CaroleTuring3.xlsx"
Const MACRO_NAME = "Date/Time Search"
Private datBeg As Date, datEnd As Date, timBeg As Date, timEnd As Date
Private excApp As Object, excWkb As Object, excWks As Object, lngRow
Public Sub BeginSearch()
    Dim strRng As String, arrTmp As Variant, arrDat As Variant, arrTim As Variant
    strRng = InputBox("Enter the date/time range to search in the form Date1 to Date2 from Time1 to Time2", MACRO_NAME, "1/1/2014 to 1/31/2014 from 10:00am to 11:00am")
    If strRng = "" Then
        MsgBox "Search cancelled.", vbInformation + vbOKOnly, MACRO_NAME
    Else
        arrTmp = Split(strRng, " from ")
        arrDat = Split(arrTmp(0), " to ")
        arrTim = Split(arrTmp(1), " to ")
        datBeg = arrDat(0)
        datEnd = arrDat(1)
        timBeg = arrTim(0)
        timEnd = arrTim(1)
        If IsDate(datBeg) And IsDate(datEnd) And IsDate(timBeg) And IsDate(timEnd) Then
            Set excApp = CreateObject("Excel.Application")
            Set excWkb = excApp.Workbooks.Add
            Set excWks = excWkb.Worksheets(1)
            excWks.Cells(1, 1) = "Folder"
            excWks.Cells(1, 2) = "Received"
            excWks.Cells(1, 3) = "Sender"
            excWks.Cells(1, 4) = "Subject"
            lngRow = 2
            SearchSub Application.ActiveExplorer.CurrentFolder
            excWks.Columns("A:D").AutoFit
            excWkb.SaveAs FILE_NAME
            excWkb.Close False
            Set excWks = Nothing
            Set excWkb = Nothing
            Set excApp = Nothing
            MsgBox "Search complete.", vbInformation + vbOKOnly, MACRO_NAME
        Else
            MsgBox "The dates/times you entered are invalid or not in the right format.  Please try again.", vbCritical + vbOKOnly, MACRO_NAME
        End If
    End If
End Sub
Private Sub SearchSub(olkFol As Outlook.MAPIFolder)
Dim olkHit As Outlook.Items, olkItm As Object, olkSub As Outlook.MAPIFolder, datTim As Date
'If the current folder contains messages, then search it

Set olkHit = olkFol.Items.Restrict("[Senton] >= '" & Format(datBeg, "ddddd h:nn AMPM") & "' AND [Senton] <= '" & Format(datEnd, "ddddd h:nn AMPM") & "'")
For Each olkItm In olkHit
If olkItm.Class = olMail Then
datTim = Format(olkItm.SentOn, "h:n:s")
Else: GoTo NextFolder
End If
If datTim >= timBeg And datTim <= timEnd Then
excWks.Cells(lngRow, 1) = olkFol.FolderPath
excWks.Cells(lngRow, 2) = olkItm.SentOn
excWks.Cells(lngRow, 3) = olkItm.SenderName
excWks.Cells(lngRow, 4) = olkItm.Subject
lngRow = lngRow + 1
End If
DoEvents
Next

Set olkHit = Nothing
Set olkItm = Nothing

NextFolder:
'Search the subfolders
For Each olkSub In olkFol.Folders
SearchSub olkSub
DoEvents
Next
Set olkSub = Nothing
End Sub

Private Sub SearchSub2(olkFol As Outlook.MAPIFolder)
Dim olkHit As Outlook.Items, olkItm As Object, olkSub As Outlook.MAPIFolder, datTim As Date
'If the current folder contains messages, then search it
If olkFol.DefaultItemType = olMailItem Then
Set olkHit = olkFol.Items.Restrict("[Senton] >= '" & Format(datBeg, "ddddd h:nn AMPM") & "' AND [Senton] <= '" & Format(datEnd, "ddddd h:nn AMPM") & "'")
For Each olkItm In olkHit
If olkItm.Class = olMail Then
datTim = Format(olkItm.SentOn, "h:n:s")
If datTim >= timBeg And datTim <= timEnd Then
excWks.Cells(lngRow, 1) = olkFol.FolderPath
excWks.Cells(lngRow, 2) = olkItm.SentOn
excWks.Cells(lngRow, 3) = olkItm.SenderName
excWks.Cells(lngRow, 4) = olkItm.Subject
lngRow = lngRow + 1
End If
End If
DoEvents
Next
Set olkHit = Nothing
Set olkItm = Nothing
End If
'Search the subfolders
For Each olkSub In olkFol.Folders
SearchSub olkSub
DoEvents
Next
Set olkSub = Nothing
End Sub