Exporting Outlook Message Counts to Excel


I’m writing this post in response to a comment Shaima Alsaif left on my “Exporting Outlook Messages to Excel” entry from this last October. In the comment Shaima asked if it’s possible to alter the export to do the following:

  • Get message counts instead of messages
  • Add to the spreadsheet instead of overwriting it
  • Have the process run automatically each week

The answer to all three is “yes”. Doing this requires taking a different approach from the one I used in the original solution. The biggest change is that this solution uses VBScript instead of VBA. Here’s why. Outlook does not have a built-in means of scheduling code to run. It’s possible to get around that (e.g. using a repeating task coupled with an event handler that traps the ReminderFire event), but it’s better to use a true scheduler like the one built into Windows (i.e. Task Scheduler). To the best of my knowledge Windows Task Scheduler cannot call a VBA routine, hence the need to use VBScript instead.

Here is how the new script will meet Shaima’s requirements. Getting the message count is easy. Each Outlook folder stores its content in a collection called Items. This collection includes a Count property that denotes the number of items in the folder. As a side note, if we wanted the unread item count, then we’d look to the folder itself instead of its Items collection. Since the solution shouldn’t overwrite the Excel workbook each time we need to alter the original code to open an existing workbook instead of creating a new one each time. We also have to add code to find the last used row in the spreadsheet the message count will be written to. Once we have this we’ll add 1 to it so the new value is written to the next available line. Scheduling the script is easy. All that requires is creating a new Windows Task that calls the script and setting it to run at whatever the desired interval is.

Requirements.

  • Outlook 2007 – 2010.
  • Any version of Windows.
  • The spreadsheet(s) must already exist.
  • The computer must be on for the task scheduler to function.

Instructions.

  1. Open Notepad.
  2. Copy the code below and paste it into Notepad.
  3. Edit the code as needed. I’ve included comments where changes can/should be made.
  4. Save the file with a .vbs extension. You can name it anything you want.
  5. Create a scheduled task that runs periodically. You can set the frequency to whatever you want.
  6. Set the task to run this script.
'Declare some variables
Dim olkApp, olkSes

'Connect to Outlook
Set olkApp = CreateObject("Outlook.Application")
Set olkSes = olkApp.GetNamespace("MAPI")
olkSes.Logon olkApp.DefaultProfileName

'Call the export process once for each folder count to be exported
'Format is ExportMessageCountToExcel <Path to Outlook Folder>, <Path and filename of the Excel file to export to>, <Number of the sheet the count goes on>
'The following lines are examples.  Edit them as needed.  Add additional lines as desired.
ExportMessageCountToExcel "Mailbox - Doe, John\Inbox", "C:\Message_Counts.xlsx", 1
ExportMessageCountToExcel "Personal Folders\Projects", "C:\Message_Counts.xlsx", 2

'Disconnect from Outlook
olkSes.Logoff
Set olkSes = Nothing
Set olkApp = Nothing
WScript.Quit

Sub ExportMessageCountToExcel(strFolder, strWorkbook, intSheet)
    Const EXCEL_COL = 1
    Dim olkFld, excApp, excWkb, excWks, lngRow
    Set olkFld = OpenOutlookFolder(strFolder)
    Set excApp = CreateObject("Excel.Application")
    Set excWkb = excApp.Workbooks.Open(strWorkbook)
    Set excWks = excWkb.Worksheets(intSheet)
    lngRow = excWks.UsedRange.Rows.Count
    If lngRow = 1 Then 
        If excWks.Cells(lngRow,1) <> "" Then
            lngRow = lngRow + 1
        End If
    Else
        lngRow = lngRow + 1
    End If
    excWks.Cells(lngRow, EXCEL_COL) = olkFld.Items.Count
    Set excWks = Nothing
    excWkb.Close True
    Set excWkb = Nothing
    excApp.Quit
    Set excApp = Nothing
    Set olkFld = Nothing
End Sub

Function OpenOutlookFolder(strFolderPath)
    Dim arrFolders, varFolder, bolBeyondRoot
    On Error Resume Next
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        Do While Left(strFolderPath, 1) = "\"
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        Loop
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            Select Case bolBeyondRoot
                Case False
                    Set OpenOutlookFolder = olkApp.Session.Folders(varFolder)
                    bolBeyondRoot = True
                Case True
                    Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
            End Select
            If Err.Number <> 0 Then
                Set OpenOutlookFolder = Nothing
                Exit For
            End If
        Next
    End If
    On Error GoTo 0
End Function

Notes.

Here are a few thoughts on how the code could be extended to create additional functionality.

  • Create the spreadsheet if it does not exist.
  • Get both the item and unread item counts. Right now it only reports the item count.
  • Get the counts for a folder and all its subfolders.
  • Record the date the count was recorded on.
About these ads

104 comments on “Exporting Outlook Message Counts to Excel

  1. BTW: this is my code:

    Sub ExportMessageCountToExcel(strFolder, strWorkbook, intSheet)
        Const FOLDER_NAME = 1
        Const UNREAD_COUNT_COL = 2
     '   Const OLDEST_UNREAD_COL = 3
        Const TOTAL_COUNT_COL = 4
    	Const EXCEL_COL = 5
        Dim olkFld, olkFlt, olkItm, excApp, excWkb, excWks, lngRow, lngCnt, datAge, olkMsg, intAns
        Set olkFld = OpenOutlookFolder(strFolder)
        Set olkFlt = olkFld.Items.Restrict("[Unread] = True")
    	For Each olkItm In olkFlt
            If FormatDateTime(olkItm.ReceivedTime,vbShortTime) &lt;= &quot;14:30&quot; Then
                    lngCnt = lngCnt + 1
            End If
        Next
    	Set excApp = CreateObject(&quot;Excel.Application&quot;)
        Set excWkb = excApp.Workbooks.Open(strWorkbook)
        Set excWks = excWkb.Worksheets(intSheet)
    	
        lngRow = excWks.UsedRange.rows.Count
        If lngRow = 1 Then
            If excWks.Cells(lngRow, 1)  "" Then
                lngRow = lngRow + 1
            End If
        Else
            lngRow = lngRow + 1
        End If
       ' datAge = #1/1/2100 12:01:00 AM#
       ' For Each olkMsg In olkFld.Items
       '     If olkMsg.Class = olMail Then
       '         If olkMsg.UnRead = True Then
       '             If olkMsg.ReceivedTime &lt; datAge Then
       '                 datAge = olkMsg.ReceivedTime
       '             End If
       '         End If
       '     End If
       ' Next
       ' If datAge = #1/1/2100 12:01:00 AM# Then
       '     datAge = &quot;&quot;
       ' End If
        excWks.Cells(lngRow, FOLDER_NAME) = olkFld.FolderPath
        excWks.Cells(lngRow, UNREAD_COUNT_COL) = olkFld.UnReadItemCount
     '   excWks.Cells(lngRow, OLDEST_UNREAD_COL) = FormatDateTime(datAge, vbShortTime)
        excWks.Cells(lngRow, TOTAL_COUNT_COL) = olkFld.Items.Count
    	excWks.Cells(lngRow, EXCEL_COL) = lngCnt
        intAns = MsgBox(&quot;Sheet in location ‘C:\Message_Counts.xlsx’ is Updated with the Mail Box Details.  Do you want to open the sheet?&quot;, vbInformation + vbYesNo)
        If intAns = vbYes Then
            excApp.Visible = True
        Else
            Set excWks = Nothing
            excWkb.Close True
            Set excWkb = Nothing
            excApp.Quit
            Set excApp = Nothing
        End If
        Set olkFld = Nothing
    End Sub
    
  2. Dear David,

    I am writing you regarding this topic, i made some modifications to the vbs script i need the script to count the e-mails only from yesterday, and it will run every single day as sheduled task.
    But there are 2 issues
    The sheet-s name is sheet2 always (although the filename is correctly set up), and for 2 folders it is counting some more see resutls in the xlsx file below.
    Scrip:http://www.mediafire.com/view/38z811zoxz94nki/NonCallBasedReport2.vbs
    Xlsx: http://www.mediafire.com/view/moa19w7lq7b9k1z/Book2.xlsx

    Could you please advise why it is not correctly showing up for the 2 folders, but all others are fine for each day.

    PS: The folder names are intentionally deleted from both the script and the xlsx

    • Hi, megoldom.

      I’m going to be unavailable for about 10 days. I’ll be back in touch with you on the 27th or 28th.

      David

    • Hi, megoldom.

      I apologize for being slow to get back to you on this.

      I’m not clear on what you mean by “… for 2 folders it is counting some more …”. Do you mean that it is counting some messages that it should not? If so, what is it that’s different about those messages?

    • Hi David,
      Ok solved :-) My bad. However, I’ve got another question. Can you tell me how I can have the following.
      I want to shedule a task every day at 7PM.
      So every day a new excell file should be created with all unread mails (in the specified folders) before 2:30PM

    • Hi, Pieter.

      The best way to run this on a schedule is to convert the code from VBA (code that runs from inside Outlook) to VBscript (code that runs outside of Outlook). That approach allows you to create a scheduled task in Windows Task Scheduler that would run each day at 7PM. The alternative is to add some additional code that will allow you to use an Outlook task to schedule this. For this approach to work, Outlook will have to be open and running at 7PM. Which approach do you prefer?

    • Hi David,

      I would like to use the approach with the sheduled task in windows. So maybe I can re-use some code you’ve already written.
      Can you tell me which code I have to use/adapt to have this vbs script properly working for me.
      I would be very thankfull

    • Hi, Pieter.

      I misread the post you’re comment is to. I thought you were asking about exporting messages to Excel when in fact you were asking about exporting message counts to Excel. That changes my earlier answer. The code for this pose is already written in VBScript, no modifications required. All you nee to do is download the code, edit it as needed, save to a .vbs file, then create a scheduled task that runs it on whatever schedule you want.

    • Hi David,

      But that code needs to be adapted to count the “unread” mails received before 14:30.
      The code from you main topic is not counting the unread ones. It is counting them all.
      Can you adapt the code?

      Thanks!!

    • Pieter,

      This should do it. Replace the ExportMessageCountToExcel subroutine with the one below. Leave the rest of the code as is.

      Sub ExportMessageCountToExcel(strFolder, strWorkbook, intSheet)
          Const EXCEL_COL = 1
          Dim olkFld, olkFlt, olkItm, excApp, excWkb, excWks, lngRow, lngCnt
          Set olkFld = OpenOutlookFolder(strFolder)
          Set olkFlt = olkFld.Items.Restrict("[Unread] = True")
          For Each olkItm In olkFlt
              If FormatDateTime(olkItm.ReceivedTime,vbShortTime) <= "14:30" Then
                      lngCnt = lngCnt + 1
              End If
          Next
          Set excApp = CreateObject("Excel.Application")
          Set excWkb = excApp.Workbooks.Open(strWorkbook)
          Set excWks = excWkb.Worksheets(intSheet)
          lngRow = excWks.UsedRange.Rows.Count
          If lngRow = 1 Then
              If excWks.Cells(lngRow,1) <> "" Then
                  lngRow = lngRow + 1
              End If
          Else
              lngRow = lngRow + 1
          End If
          excWks.Cells(lngRow, EXCEL_COL) = lngCnt
          Set excWks = Nothing
          excWkb.Close True
          Set excWkb = Nothing
          excApp.Quit
          Set excApp = Nothing
          Set olkFld = Nothing
      End Sub
      
    • Hi David,

      Some little remarks. I think I did not explain myself very well.
      So there are three little “issues”:
      1. If the code has to count three folders (or more), there are three excell files that open. But is it possible to save those info in the same excell file?
      2. If 1 = yes, Is it also possible to add the date that the task has run to those lines?
      For example: (layout of excel file)
      column a: date(task has run); column b: name of the folder; column c: nr of unread mails; column d: nr of ALL unread mails before 14:30 of the day that the task has run?
      3. The code I have now counts the unread mails before 14:30 of each day but that is not what I want. For Example: if the task runs today, I want the number of unread mail of before 14:30 today and all unreads from before (so all of them of yesterday,… It does not matter for those if they are from before 14:30 or after.

      Hope this is a bit clear?

      Grtz,

      Pieter

    • Further one nice to have would be that each day when the task runs, the file is appended every time?
      Further, this is the code I currently have:

      BTW: this is my code:

       Sub ExportMessageCountToExcel(strFolder, strWorkbook, intSheet)
       Const FOLDER_NAME = 1
       Const UNREAD_COUNT_COL = 2
      ‘ Const OLDEST_UNREAD_COL = 3
       Const TOTAL_COUNT_COL = 4
       Const EXCEL_COL = 5
       Dim olkFld, olkFlt, olkItm, excApp, excWkb, excWks, lngRow, lngCnt, datAge, olkMsg, intAns
       Set olkFld = OpenOutlookFolder(strFolder)
       Set olkFlt = olkFld.Items.Restrict(“[Unread] = True”)
      For Each olkItm In olkFlt
       If FormatDateTime(olkItm.ReceivedTime,vbShortTime) &lt;= &quot;14:30&quot; Then
       lngCnt = lngCnt + 1
       End If
       Next
       Set excApp = CreateObject(&quot;Excel.Application&quot;)
       Set excWkb = excApp.Workbooks.Open(strWorkbook)
       Set excWks = excWkb.Worksheets(intSheet)
      
      lngRow = excWks.UsedRange.rows.Count
       If lngRow = 1 Then
       If excWks.Cells(lngRow, 1) “” Then
       lngRow = lngRow + 1
       End If
       Else
       lngRow = lngRow + 1
       End If
      ‘ datAge = #1/1/2100 12:01:00 AM#
      ‘ For Each olkMsg In olkFld.Items
      ‘ If olkMsg.Class = olMail Then
      ‘ If olkMsg.UnRead = True Then
      ‘ If olkMsg.ReceivedTime &lt; datAge Then
       ' datAge = olkMsg.ReceivedTime
       ' End If
       ' End If
       ' End If
       ' Next
       ' If datAge = #1/1/2100 12:01:00 AM# Then
       ' datAge = &quot;&quot;
       ' End If
       excWks.Cells(lngRow, FOLDER_NAME) = olkFld.FolderPath
       excWks.Cells(lngRow, UNREAD_COUNT_COL) = olkFld.UnReadItemCount
       ' excWks.Cells(lngRow, OLDEST_UNREAD_COL) = FormatDateTime(datAge, vbShortTime)
       excWks.Cells(lngRow, TOTAL_COUNT_COL) = olkFld.Items.Count
       excWks.Cells(lngRow, EXCEL_COL) = lngCnt
       intAns = MsgBox(&quot;Sheet in location ‘C:\Message_Counts.xlsx’ is Updated with the Mail Box Details. Do you want to open the sheet?&quot;, vbInformation + vbYesNo)
       If intAns = vbYes Then
       excApp.Visible = True
       Else
       Set excWks = Nothing
       excWkb.Close True
       Set excWkb = Nothing
       excApp.Quit
       Set excApp = Nothing
       End If
       Set olkFld = Nothing
       End Sub
      
    • Hi David,

      Maybe I did not explain very well, but the code you’ve posted here does not completely meet the requirement.
      This code shows the unread mails of all days before 14:30.
      What I want it to do is the following:
      If the task runs today at 22:00, it should count ALL unread mail from before 14:30 today. Which means also the unread mails from yesterday before 14:30. That is the code currently not doing.
      And the second thing I would like to have is that the excel file is appended with the date/time the task has run. So the same workbook is always appended with all the folders it has to count.
      FE: (task has run on 03/08 & 04/08
      03/08 Foldername totalmails unreadmails unreadmail<14:30
      03/08 Foldername2 totalmails unreadmails unreadmails<14:30
      04/08 Foldername totalmails unreadmails unreadmails<14:30
      04/08 Foldername2 totalmails unreadmails unreadmails<14:30
      and so on every day the tasks run, the workbook/sheet should be appended with the new info.

      Is this possible David and what should the code be?

      Kind regards,

      Pieter

    • Pieter,

      I think I’ve got it. Please try this version and let me know if that’s what you wanted.

      Sub RunExport()
          ExportMessageCountToExcel "mailbox\Inbox", "c:\pieter.xlsx", 1
          ExportMessageCountToExcel "Projects\Project X", "c:\pieter.xlsx", 1
      End Sub
      
      Sub ExportMessageCountToExcel(strFolder As String, strWorkbook As String, intSheet As Integer)
          'Declare some constants
          Const RUN_DATE = 1
          Const FOLDER_NAME = 2
          Const UNREAD_TOTAL = 3
          Const UNREAD_BEFORE_1430PM = 4
          
          'Declare some variables
          Dim olkFld As Object, _
              olkFlt As Object, _
              olkItm As Object, _
              excApp As Object, _
              excWkb As Object, _
              excWks As Object, _
              lngRow As Long, _
              lngCnt As Long, _
              datRun As Date, _
              datChk As Date
          
          'Initialize some variables
          datRun = Now
          datChk = Date & " 2:30 pm"
          
          'Connect to Outlook
          Set olkFld = OpenOutlookFolder(strFolder)
          Set olkFlt = olkFld.Items.Restrict("[Unread] = True")
          For Each olkItm In olkFlt
              If olkItm.ReceivedTime <= datChk Then
                  lngCnt = lngCnt + 1
              End If
          Next
          
          'Connect to Excel
          Set excApp = CreateObject("Excel.Application")
          Set excWkb = excApp.Workbooks.Open(strWorkbook)
          Set excWks = excWkb.Worksheets(intSheet)
          lngRow = excWks.UsedRange.rows.Count + 1
      
          'Write the results to Excel
          With excWks
              .Cells(lngRow, RUN_DATE) = datRun
              .Cells(lngRow, FOLDER_NAME) = olkFld.FolderPath
              .Cells(lngRow, UNREAD_TOTAL) = olkFld.UnReadItemCount
              .Cells(lngRow, UNREAD_BEFORE_1430PM) = lngCnt
          End With
          
          'Ask the user if they want to view the results now
          intAns = MsgBox("Sheet in location ‘" & excWkb.FullName & "’ is Updated with the Mail Box Details.  Do you want to open the sheet?", vbInformation + vbYesNo)
          If intAns = vbYes Then
              excApp.Visible = True
          Else
              excWkb.Close True
              excApp.Quit
          End If
      
          'Clean-up
          Set excWks = Nothing
          Set excWkb = Nothing
          Set excApp = Nothing
          Set olkItm = Nothing
          Set olkFlt = Nothing
          Set olkFld = Nothing
      End Sub
      
      Public Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
          ' Purpose: Opens an Outlook folder from a folder path.
          ' Written: 4/24/2009
          ' Author:  David Lee
          ' Outlook: All versions
          Dim arrFolders As Variant, _
              varFolder As Variant, _
              bolBeyondRoot As Boolean
          On Error Resume Next
          If strFolderPath = "" Then
              Set OpenOutlookFolder = Nothing
          Else
              Do While Left(strFolderPath, 1) = "\"
                  strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
              Loop
              arrFolders = Split(strFolderPath, "\")
              For Each varFolder In arrFolders
                  Select Case bolBeyondRoot
                      Case False
                          Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
                          bolBeyondRoot = True
                      Case True
                          Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
                  End Select
                  If Err.Number <> 0 Then
                      Set OpenOutlookFolder = Nothing
                      Exit For
                  End If
              Next
          End If
          On Error GoTo 0
      End Function
      
    • Hi Davind,

      Thanks for your reply but…
      can you please check my code. I copied the code you have posted but I suppose that is VB instead of VBS. I had tot delete the keywords like “AS String”,..
      Now, when I run the it as a vbs script, it does not do anything. Can you check please?

      Thanks!

      Here is the code:

      Sub RunExport() 
      '    ExportMessageCountToExcel "mailbox\Inbox", "c:\pieter.xlsx", 1 
           ExportMessageCountToExcel "PIETER\Inbox", "H:\TEMP\Message_Counts.xlsx", 1
           ExportMessageCountToExcel "PIETER\Inbox\Cockpit FCI", "H:\TEMP\Message_Counts.xlsx", 1
           ExportMessageCountToExcel "PIETER\Inbox\CB Requests", "H:\TEMP\Message_Counts.xlsx", 1
           ExportMessageCountToExcel "PIETER1: RBK", "H:\TEMP\Message_Counts.xlsx", 1
           ExportMessageCountToExcel "PIETER3. MAIL\Incidentfiches", "H:\TEMP\Message_Counts.xlsx", 1
      '    ExportMessageCountToExcel "Projects\Project X", "c:\pieter.xlsx", 1 
      End Sub 
      
      
      Sub ExportMessageCountToExcel(strFolder, strWorkbook, intSheet) 
          'Declare some constants 
          Const RUN_DATE = 1 
          Const FOLDER_NAME = 2 
          Const UNREAD_TOTAL = 3 
          Const UNREAD_BEFORE_1430PM = 4 
            
          'Declare some variables 
          Dim olkFld, olkFlt, olkItm, excApp, excWkb, excWks, lngRow, lngCnt, datRun, datChk 
            
          'Initialize some variables 
          datRun = Now 
          datChk = Date &amp; " 2:30 pm" 
            
          'Connect to Outlook 
          Set olkFld = OpenOutlookFolder(strFolder) 
          Set olkFlt = olkFld.Items.Restrict("[Unread] = True") 
          For Each olkItm In olkFlt 
              If olkItm.ReceivedTime &lt;= datChk Then 
                  lngCnt = lngCnt + 1 
              End If 
          Next 
            
          'Connect to Excel 
          Set excApp = CreateObject(&quot;Excel.Application&quot;) 
          Set excWkb = excApp.Workbooks.Open(strWorkbook) 
          Set excWks = excWkb.Worksheets(intSheet) 
          lngRow = excWks.UsedRange.rows.Count + 1 
        
          'Write the results to Excel 
          With excWks 
              .Cells(lngRow, RUN_DATE) = datRun 
              .Cells(lngRow, FOLDER_NAME) = olkFld.FolderPath 
              .Cells(lngRow, UNREAD_TOTAL) = olkFld.UnReadItemCount 
              .Cells(lngRow, UNREAD_BEFORE_1430PM) = lngCnt 
          End With 
            
          'Ask the user if they want to view the results now 
          intAns = MsgBox(&quot;Sheet in location ‘&quot; &amp; excWkb.FullName &amp; &quot;’ is Updated with the Mail Box Details.  Do you want to open the sheet?&quot;, vbInformation + 
      
      vbYesNo) 
          If intAns = vbYes Then 
              excApp.Visible = True 
          Else 
              excWkb.Close True 
              excApp.Quit 
          End If 
        
          'Clean-up 
          Set excWks = Nothing 
          Set excWkb = Nothing 
          Set excApp = Nothing 
          Set olkItm = Nothing 
          Set olkFlt = Nothing 
          Set olkFld = Nothing 
      End Sub 
        
      Public Function OpenOutlookFolder(strFolderPath) 
          ' Purpose: Opens an Outlook folder from a folder path. 
          ' Written: 4/24/2009 
          ' Author:  David Lee 
          ' Outlook: All versions 
          Dim arrFolders, varFolder, bolBeyondRoot 
          On Error Resume Next 
          If strFolderPath = &quot;&quot; Then 
              Set OpenOutlookFolder = Nothing 
          Else 
              Do While Left(strFolderPath, 1) = &quot;\&quot; 
                  strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1) 
              Loop 
              arrFolders = Split(strFolderPath, &quot;\&quot;) 
              For Each varFolder In arrFolders 
                  Select Case bolBeyondRoot 
                      Case False 
                          Set OpenOutlookFolder = Outlook.Session.Folders(varFolder) 
                          bolBeyondRoot = True 
                      Case True 
                          Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder) 
                  End Select 
                  If Err.Number  0 Then 
                      Set OpenOutlookFolder = Nothing 
                      Exit For 
                  End If 
              Next 
          End If 
          On Error GoTo 0 
      End Function
      
    • Hi, Pieter.

      Sorry about that. Somehow I forgot that you wanted the solution in VBscript and not VBA. Here’s the VBscript version.

      Dim olkApp, olkSes
      Set olkApp = CreateObject("Outlook.Application")
      Set olkSes = olkApp.GetNamespace("MAPI")
      olkSes.Logon olkApp.DefaultProfileName
      'ExportMessageCountToExcel "mailbox\Inbox", "c:\pieter.xlsx", 1
      ExportMessageCountToExcel "PIETER\Inbox", "H:\TEMP\Message_Counts.xlsx", 1
      ExportMessageCountToExcel "PIETER\Inbox\Cockpit FCI", "H:\TEMP\Message_Counts.xlsx", 1
      ExportMessageCountToExcel "PIETER\Inbox\CB Requests", "H:\TEMP\Message_Counts.xlsx", 1
      ExportMessageCountToExcel "PIETER1: RBK", "H:\TEMP\Message_Counts.xlsx", 1
      ExportMessageCountToExcel "PIETER3. MAIL\Incidentfiches", "H:\TEMP\Message_Counts.xlsx", 1
      'ExportMessageCountToExcel "Projects\Project X", "c:\pieter.xlsx", 1
      olkSes.Logoff
      Set olkSes = Nothing
      Set olkApp = Nothing
      WScript.Quit
       
      Sub ExportMessageCountToExcel(strFolder, strWorkbook, intSheet)
          'Declare some constants
          Const RUN_DATE = 1
          Const FOLDER_NAME = 2
          Const UNREAD_TOTAL = 3
          Const UNREAD_BEFORE_1430PM = 4
             
          'Declare some variables
          Dim olkFld, olkFlt, olkItm, excApp, excWkb, excWks, lngRow, lngCnt, datRun, datChk
             
          'Initialize some variables
          datRun = Now
          datChk = Date & " 2:30 pm"
             
          'Connect to Outlook
          Set olkFld = OpenOutlookFolder(strFolder)
          Set olkFlt = olkFld.Items.Restrict("[Unread] = True")
          For Each olkItm In olkFlt
              If olkItm.ReceivedTime <= datChk Then
                  lngCnt = lngCnt + 1
              End If
          Next
             
          'Connect to Excel
          Set excApp = CreateObject("Excel.Application")
          Set excWkb = excApp.Workbooks.Open(strWorkbook)
          Set excWks = excWkb.Worksheets(intSheet)
          lngRow = excWks.UsedRange.rows.Count + 1
         
          'Write the results to Excel
          With excWks
              .Cells(lngRow, RUN_DATE) = datRun
              .Cells(lngRow, FOLDER_NAME) = olkFld.FolderPath
              .Cells(lngRow, UNREAD_TOTAL) = olkFld.UnReadItemCount
              .Cells(lngRow, UNREAD_BEFORE_1430PM) = lngCnt
          End With
             
          'Ask the user if they want to view the results now
          intAns = MsgBox("Sheet in location ‘" & excWkb.FullName & "’ is Updated with the Mail Box Details.  Do you want to open the sheet?", vbInformation + vbYesNo)
          If intAns = vbYes Then
              excApp.Visible = True
          Else
              excWkb.Close True
              excApp.Quit
          End If
         
          'Clean-up
          Set excWks = Nothing
          Set excWkb = Nothing
          Set excApp = Nothing
          Set olkItm = Nothing
          Set olkFlt = Nothing
          Set olkFld = Nothing
      End Sub
         
      Function OpenOutlookFolder(strFolderPath)
          ' Purpose: Opens an Outlook folder from a folder path.
          ' Written: 4/24/2009
          ' Author:  David Lee
          ' Outlook: All versions
          Dim arrFolders, varFolder, bolBeyondRoot
          On Error Resume Next
          If strFolderPath = "" Then
              Set OpenOutlookFolder = Nothing
          Else
              Do While Left(strFolderPath, 1) = "\"
                  strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
              Loop
              arrFolders = Split(strFolderPath, "\")
              For Each varFolder In arrFolders
                  Select Case bolBeyondRoot
                      Case False
                          Set OpenOutlookFolder = olkSes.Folders(varFolder)
                          bolBeyondRoot = True
                      Case True
                          Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
                  End Select
                  If Err.Number <> 0 Then
                      Set OpenOutlookFolder = Nothing
                      Exit For
                  End If
              Next
          End If
          On Error GoTo 0
      End Function
      
    • Hi David,
      The code of your last post does the trick but it opens every time a new excel file so the layout is not like underneath. The file is not appended…
      Can you adapt the code? (PS do not forget it has to be vbs :-) )
      I feel we are almost there. Thanks a lot for you help!!

      (see earlier in my post)
      And the second thing I would like to have is that the excel file is appended with the date/time the task has run. So the same workbook is always appended with all the folders it has to count.
      FE: (task has run on 03/08 & 04/08
      03/08 Foldername totalmails unreadmails unreadmail<14:30
      03/08 Foldername2 totalmails unreadmails unreadmails<14:30
      04/08 Foldername totalmails unreadmails unreadmails<14:30
      04/08 Foldername2 totalmails unreadmails unreadmails<14:30
      and so on every day the tasks run, the workbook/sheet should be appended with the new info.

    • Hi, Pieter.

      “… it opens every time a new excel file …”

      I don’t know how that’s possible. The script specifically tells Excel to open an existing workbook. Here’s the relevant line in the script

      Set excWkb = excApp.Workbooks.Open(strWorkbook)
      

      The Open command tells Excel to open an existing file. If instead we wanted Excel to create a new file, then we’d use an Add command.

      Set excWkb = excApp.Workbooks.Add
      

      I don’t know how the script can be creating a new file each time when the script is telling it to open an existing file. Plus, when I run the script here it opens the existing file each time. I don’t get a new file. In fact, if the specified workbook doesn’t exist, then the code generates an error. If the script were adding workbooks instead of opening an existing workbook, then it wouldn’t error out at that point.

    • David,

      It opens every time the same excel book but the sheet does not show all folders. I gett the message every time for each folder it has to process asking me if i would like to op see the result. When i click yes the sheet only shows one line with the result of the folder he has processed.. I would like to see the five folders in the sheet underneath eachother?

    • Good morning, Pieter.

      “I would like to see the five folders in the sheet underneath each other?”

      That’s exactly what I do see when I run the code. How about waiting until the last folder has processed before clicking “Yes” to view the results? I’m thinking that you may be clicking “Yes” after the first folder has processed which would only show you that folder and would likely block the other folders from processing correctly.

    • You are right David.
      I’ve commented out the part where the code asks me to see the result and now it shows the result on one page.
      However, 1 more issue: It still shows ALL unread messages instead of the ones of before 14:30.

      Underneath is the code:

      Dim olkApp, olkSes
      Set olkApp = CreateObject(“Outlook.Application”)
      Set olkSes = olkApp.GetNamespace(“MAPI”)
      olkSes.Logon olkApp.DefaultProfileName
      ‘ExportMessageCountToExcel “mailbox\Inbox”, “c:\pieter.xlsx”, 1
      ExportMessageCountToExcel “PIETER TELENET\Postvak IN”, “C:\Users\Pieter\Documents\Message_Counts.xlsx”, 1
      ExportMessageCountToExcel “PIETER TELENET\Postvak IN\Facebook”, “C:\Users\Pieter\Documents\Message_Counts.xlsx”, 1
      ExportMessageCountToExcel “PIETER TELENET\Postvak IN\LinkedIn”, “C:\Users\Pieter\Documents\Message_Counts.xlsx”, 1
      ExportMessageCountToExcel “PIETER TELENET\Postvak IN\Stepstone”, “C:\Users\Pieter\Documents\Message_Counts.xlsx”, 1
      ‘C:\Users\Pieter\Documents
      ‘ExportMessageCountToExcel “PIETER\Inbox”, “H:\TEMP\Message_Counts.xlsx”, 1
      ‘ExportMessageCountToExcel “PIETER\Inbox\Cockpit FCI”, “H:\TEMP\Message_Counts.xlsx”, 1
      ‘ExportMessageCountToExcel “PIETER\Inbox\CB Requests”, “H:\TEMP\Message_Counts.xlsx”, 1
      ‘ExportMessageCountToExcel “PIETER1: RBK”, “H:\TEMP\Message_Counts.xlsx”, 1
      ‘ExportMessageCountToExcel “PIETER3. MAIL\Incidentfiches”, “H:\TEMP\Message_Counts.xlsx”, 1
      ‘ExportMessageCountToExcel “Projects\Project X”, “c:\pieter.xlsx”, 1
      olkSes.Logoff
      Set olkSes = Nothing
      Set olkApp = Nothing
      WScript.Quit

      Sub ExportMessageCountToExcel(strFolder, strWorkbook, intSheet)
      ‘Declare some constants
      Const RUN_DATE = 1
      Const FOLDER_NAME = 2
      Const UNREAD_TOTAL = 3
      Const UNREAD_BEFORE_1430PM = 4

      ‘Declare some variables
      Dim olkFld, olkFlt, olkItm, excApp, excWkb, excWks, lngRow, lngCnt, datRun, datChk

      ‘Initialize some variables
      datRun = Now
      datChk = Date & ” 2:30 pm”
      intAns = MsgBox(datChk, vbInformation + vbYesNo)

      ‘Connect to Outlook
      Set olkFld = OpenOutlookFolder(strFolder)
      Set olkFlt = olkFld.Items.Restrict(“[Unread] = True”)
      For Each olkItm In olkFlt
      If olkItm.ReceivedTime <= datChk Then
      lngCnt = lngCnt + 1
      End If
      Next

      'Connect to Excel
      Set excApp = CreateObject("Excel.Application")
      Set excWkb = excApp.Workbooks.Open(strWorkbook)
      Set excWks = excWkb.Worksheets(intSheet)
      lngRow = excWks.UsedRange.rows.Count + 1

      'Write the results to Excel
      With excWks
      .Cells(lngRow, RUN_DATE) = datRun
      .Cells(lngRow, FOLDER_NAME) = olkFld.FolderPath
      .Cells(lngRow, UNREAD_TOTAL) = olkFld.UnReadItemCount
      .Cells(lngRow, UNREAD_BEFORE_1430PM) = lngCnt
      End With

      'Ask the user if they want to view the results now
      'intAns = MsgBox("Sheet in location ‘" & excWkb.FullName & "’ is Updated with the Mail Box Details. Do you want to open the sheet?", vbInformation + vbYesNo)
      'If intAns = vbYes Then
      ' excApp.Visible = True
      'Else
      ' excWkb.Close True
      ' excApp.Quit
      'End If

      excWkb.Close True
      excApp.Quit

      'Clean-up
      Set excWks = Nothing
      Set excWkb = Nothing
      Set excApp = Nothing
      Set olkItm = Nothing
      Set olkFlt = Nothing
      Set olkFld = Nothing
      End Sub

      Function OpenOutlookFolder(strFolderPath)
      ' Purpose: Opens an Outlook folder from a folder path.
      ' Written: 4/24/2009
      ' Author: David Lee
      ' Outlook: All versions
      Dim arrFolders, varFolder, bolBeyondRoot
      On Error Resume Next
      If strFolderPath = "" Then
      Set OpenOutlookFolder = Nothing
      Else
      Do While Left(strFolderPath, 1) = "\"
      strFolderPath = Right(strFolderPath, Len(strFolderPath) – 1)
      Loop
      arrFolders = Split(strFolderPath, "\")
      For Each varFolder In arrFolders
      Select Case bolBeyondRoot
      Case False
      Set OpenOutlookFolder = olkSes.Folders(varFolder)
      bolBeyondRoot = True
      Case True
      Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
      End Select
      If Err.Number 0 Then
      Set OpenOutlookFolder = Nothing
      Exit For
      End If
      Next
      End If
      On Error GoTo 0
      End Function

    • Hi David,

      Found the issue.

      Had to adapt the following line:
      datChk = Date & ” 2:30 pm”
      To:
      datChk = CDate(Date & ” 14:30:00″)

      Thanks a lot for your help!!!
      It is now doing what it should :-)

      Sorry I’ve bothered you a lot!

    • Hi, Pieter.

      That’s great. Thanks for letting me know.

      No worries. I’m happy I could help.

      Cheers!

    • David,

      One more thing. Can you tell me how I have to set the filter in vbscript to get the unread messages without category. I already tried several things but every time I get an error.

      Set olkFlt = olkFld.Items.Restrict(“@SQL=” & Chr(34) & _
      “urn:schemas-microsoft-com:office:office#Keywords” & _
      Chr(34) & ” is null And [Unread] = true”)

      I already tried with set olkFlt = olkFld.Items.Restrict(“[Categories] is null and [Unread] = True”)
      This does not work neither… :-(

    • Pieter,

      You cannot use Restrict or Find with certain Outlook properties. Categories is one of those properties. See this page for details. The alternative is to filter on unread messages then read each hit and check it to see if Categories equals “”.

    • Pieter,

      The code would be something like this

      'Filter on unread items
      Set olkFlt = olkFld.Items.Restrict("[UnRead] = True")
      'Read each unread item
      For Each olkMsg In olkFlt
          'Check to see if the item's Categories property is empty
          If olkMsg.Categories = "" Then
              'Code for whatever you want to do with the items goes here
          End If
      Next
      

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s