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

Status
Not open for further replies.

Kev

New Member
Outlook version
Outlook 2013 32 bit
Email Account
Exchange Server
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: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
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
 
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!
 
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.)
 
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!
 
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?
 
Thanks Diane, i had to leave the office for an external meeting, I ll run your kind suggestions when back and report!
Best wishes
 
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
 
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.
 
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
 
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
 
Or should i remove completely the
If olkFol.DefaultItemType = olMailItem Then
completely remove this line (in it's End if)

This might work -

Code:
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
 
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!

Code:
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
 
Status
Not open for further replies.
Similar threads
Thread starter Title Forum Replies Date
Witzker Outlook 2019 Macro GoTo user defined search folder Outlook VBA and Custom Forms 6
M Outlook macro to automate search and forward process Outlook VBA and Custom Forms 6
A Outlook macro to create search folder with mail categories as criteria Outlook VBA and Custom Forms 3
C Search with Google Macro? Outlook VBA and Custom Forms 4
M VBA macro for Inbox's attachments search Outlook VBA and Custom Forms 0
B Search by date macro Outlook VBA and Custom Forms 0
L Outlook 2007 - Macro Re Search Using Outlook 16
L Outlook 2007 Macro Search Contacts Using Outlook 9
J How to write a macro to search inbox for certain numbers Outlook VBA and Custom Forms 2
X Custom icon (not from Office 365) for a macro in Outlook Outlook VBA and Custom Forms 1
X Run macro automatically when a mail appears in the sent folder Using Outlook 5
mrrobski68 Issue with Find messages in a conversation macro Outlook VBA and Custom Forms 1
G Creating Macro to scrape emails from calendar invite body Outlook VBA and Custom Forms 6
M Use Macro to change account settings Outlook VBA and Custom Forms 0
J Macro to Reply to Emails w/ Template Outlook VBA and Custom Forms 3
C Outlook - Macro to block senders domain - Macro Fix Outlook VBA and Custom Forms 1
Witzker Outlook 2019 Macro to seach in all contact Folders for marked Email Adress Outlook VBA and Custom Forms 1
S macro error 4605 Outlook VBA and Custom Forms 0
A Macro Mail Alert Using Outlook 4
J Outlook 365 Outlook Macro to Sort emails by column "Received" to view the latest email received Outlook VBA and Custom Forms 0
J Macro to send email as alias Outlook VBA and Custom Forms 0
M Outlook Macro to save as Email with a file name format : Date_Timestamp_Sender initial_Email subject Outlook VBA and Custom Forms 0
D Outlook 2016 Creating an outlook Macro to select and approve Outlook VBA and Custom Forms 0
Witzker Outlook 2019 Macro to send an Email Template from User Defined Contact Form Outlook VBA and Custom Forms 0
Witzker Outlook 2019 Macro to check Cursor & Focus position Outlook VBA and Custom Forms 8
V Macro to mark email with a Category Outlook VBA and Custom Forms 4
M Outlook 2019 Macro not working Outlook VBA and Custom Forms 0
S Outlook 365 Help me create a Macro to make some received emails into tasks? Outlook VBA and Custom Forms 1
Geldner Send / Receive a particular group via macro or single keypress Using Outlook 1
D Auto Remove [EXTERNAL] from subject - Issue with Macro Using Outlook 21
V Macro to count flagged messages? Using Outlook 2
sophievldn Looking for a macro that moves completed items from subfolders to other subfolder Outlook VBA and Custom Forms 7
S Outlook Macro for [Date][Subject] Using Outlook 1
E Outlook - Macro - send list of Tasks which are not finished Outlook VBA and Custom Forms 3
E Macro to block senders domain Outlook VBA and Custom Forms 1
D VBA Macro to Print and Save email to network location Outlook VBA and Custom Forms 1
N VBA Macro To Save Emails Outlook VBA and Custom Forms 1
N Line to move origEmail to subfolder within a reply macro Outlook VBA and Custom Forms 0
Witzker Outlook 2019 Macro to answer a mail with attachments Outlook VBA and Custom Forms 2
A Outlook 2016 Macro to Reply, ReplyAll, or Forward(but with composing new email) Outlook VBA and Custom Forms 0
J Macro to Insert a Calendar Outlook VBA and Custom Forms 8
W Macro to Filter Based on Latest Email Outlook VBA and Custom Forms 6
T Macro to move reply and original message to folder Outlook VBA and Custom Forms 6
D Autosort macro for items in a view Outlook VBA and Custom Forms 2
S HTML to Plain Text Macro - Help Outlook VBA and Custom Forms 1
A Macro to file emails into subfolder based on subject line Outlook VBA and Custom Forms 1
N Help creating a VBA macro with conditional formatting to change the font color of all external emails to red Outlook VBA and Custom Forms 5
S Visual indicator of a certain property or to show a macro toggle Outlook VBA and Custom Forms 2
L Modifying VBA script to delay running macro Outlook VBA and Custom Forms 3
S Macro to extract and modify links from emails Outlook VBA and Custom Forms 3

Similar threads

Back
Top