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
 

Kev

New Member
Outlook version
Outlook 2013 32 bit
Email Account
Exchange Server
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

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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

New Member
Outlook version
Outlook 2013 32 bit
Email Account
Exchange Server
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

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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

New Member
Outlook version
Outlook 2013 32 bit
Email Account
Exchange Server
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

New Member
Outlook version
Outlook 2013 32 bit
Email Account
Exchange Server
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

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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

New Member
Outlook version
Outlook 2013 32 bit
Email Account
Exchange Server
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

New Member
Outlook version
Outlook 2013 32 bit
Email Account
Exchange Server
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

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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
 

Kev

New Member
Outlook version
Outlook 2013 32 bit
Email Account
Exchange Server
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
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
S Macro to extract email addresses of recipients in current drafted email and put into clipboard Outlook VBA and Custom Forms 1
witzker HowTo start a macro with an Button in OL contact form Outlook VBA and Custom Forms 12
witzker Macro to move @domain.xx of a Spammail to Blacklist in Outlook 2019 Outlook VBA and Custom Forms 7
S Macro for other actions - Outlook 2007 Outlook VBA and Custom Forms 23
C Macro to extract sender name & subject line of incoming emails to single txt file Outlook VBA and Custom Forms 3
L Macro/VBA to Reply All, with the original attachments Outlook VBA and Custom Forms 2
S Macro to move “Re:” & “FWD:” email recieved the shared inbox to a subfolder in outlook Outlook VBA and Custom Forms 0
S Outlook Macro to send auto acknowledge mail only to new mails received to a specific shared inbox Outlook VBA and Custom Forms 0
S Outlook Macro to move reply mail based on the key word in the subjectline Outlook VBA and Custom Forms 0
Eike Move mails via macro triggered by the click of a button? Outlook VBA and Custom Forms 0
S Macro or plug-in to see if specific person was included in this email Outlook VBA and Custom Forms 4
U Macro for reminders,tasks,calendar Outlook VBA and Custom Forms 4
V macro runs slower on startup than after Outlook VBA and Custom Forms 3
N Macro to move all recipients to CC while replying Outlook VBA and Custom Forms 0
A VBA macro for 15 second loop in send and received just for 1 specific mailbox Outlook VBA and Custom Forms 1
G VBA Macro Calendar Printing Assistant 4
R Help Revising VBA macro to delete email over different time span Outlook VBA and Custom Forms 0
R Macro Schedule every day in Outlook Using Outlook 0
L Moving emails with similar subject and find the timings between the emails using outlook VBA macro Outlook VBA and Custom Forms 1
Healy Consultants Macro to remove inside organization distribution list email address when reply to all recepients Outlook VBA and Custom Forms 0
geofferyh Cannot get Macro to SAVE more than one message attachment??? Outlook VBA and Custom Forms 5
N How can I increase/faster outlook VBA Macro Speed ? Using Outlook 2
4 Macro to set the category of Deleted Item? Outlook VBA and Custom Forms 2
D.Moore Folder view settings by VBA macro Outlook VBA and Custom Forms 57
Dave A Run macro on existing appointment when it changes Outlook VBA and Custom Forms 1
V Outlook Macro to show Flagged messages Outlook VBA and Custom Forms 2
O Run macro automatically at sending an email Using Outlook 11
R Retain Original Message When Forwarding With Macro Outlook VBA and Custom Forms 3
C Macro to add multiple recipients to message Outlook VBA and Custom Forms 3
B Reply and replyall macro is not working Outlook VBA and Custom Forms 1
O Macro - paste as plain text Outlook VBA and Custom Forms 2
J Help Please!!! Outlook 2016 - VBA Macro for replying with attachment in meeting invite Outlook VBA and Custom Forms 9
witzker Macro to set contact reminder to next day 9:00 Outlook VBA and Custom Forms 45
M Adding Macro to populate "to" "subject" "body" not deleting email string below. Outlook VBA and Custom Forms 5
E Copying data from e-mail attachement to EXCEL file via macro Outlook VBA and Custom Forms 38
M Macro to add date/time stamp to subject Outlook VBA and Custom Forms 4
R VBA macro - new message Outlook VBA and Custom Forms 3
S Example VBA Macro - To Conditionally Change the From Account and Add a BCC Address on Emails Outlook VBA and Custom Forms 11
S Macro using .SendUsingAccount only works the first time, after starting Outlook Outlook VBA and Custom Forms 4
S VBA Macro - Run-time error '424': object required - Help Please Outlook VBA and Custom Forms 3
B VBA Macro for assigning multiple Categories to an email in my Inbox Outlook VBA and Custom Forms 1
N Macro for attachment saved and combine Outlook VBA and Custom Forms 1

Similar threads

Top