Flagged Emails

[howard]

I have VBA Code to extract Flagged Emails. The processing speed is very slow and need it amended so that it is much faster

It would be appreciated if someone could amend this for me

 Sub ImportFlaggedEmails()
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.Namespace
    Dim ws As Worksheet
    Dim flaggedEmailsArr() As Variant
    Dim flaggedCount As Long

    ' Create an Outlook Application object
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    On Error GoTo 0

    If olApp Is Nothing Then Set olApp = CreateObject("Outlook.Application")
    Set olNamespace = olApp.GetNamespace("MAPI")

    ' Reference the "Flagged Emails" worksheet
    Set ws = ThisWorkbook.Sheets("Flagged Emails")

    ' Disable screen updating and calculation
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    ' Clear the sheet and write headers
    ws.Cells.ClearContents
    ws.Range("A1:D1").Value = Array("From", "Subject", "Date Received", "Folder")

    ' Initialize the array
    flaggedCount = 0

    ' Use a dynamic array
    ReDim flaggedEmailsArr(1 To 4, 1 To 1)

    ' Call recursive function to search all folders
    SearchFolders olNamespace.Folders, ws, flaggedEmailsArr, flaggedCount

    ' Output the data to the sheet
    If flaggedCount > 0 Then
        ReDim Preserve flaggedEmailsArr(1 To 4, 1 To flaggedCount)
        ws.Range("A2").Resize(flaggedCount, 4).Value = Application.Transpose(flaggedEmailsArr)
    End If

    ' Enable screen updating and calculation
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    MsgBox "Flagged emails extracted successfully!", vbInformation
End Sub

Sub SearchFolders(ByVal parentFolders As Outlook.Folders, ws As Worksheet, ByRef flaggedEmailsArr As Variant, ByRef flaggedCount As Long)
    Dim olFolder As Outlook.Folder
    Dim olItems As Outlook.Items
    Dim olMail As Outlook.MailItem
    Dim i As Long
    Dim folderName As String

    For Each olFolder In parentFolders
        ' Extract the relevant part of the folder name
        folderName = olFolder.FolderPath
        folderName = Replace(folderName, "\\Personal Folders\", "") ' Remove "Personal Folders"
        If InStr(folderName, "Inbox\") > 0 Then
            ' If the folder is a subfolder of Inbox
            folderName = Replace(folderName, "Inbox\", "")
        ElseIf folderName = "Inbox" Then
            ' Keep "Inbox" as is if it's the main folder
            folderName = "Inbox"
        End If

        ' Get items in the folder
        Set olItems = olFolder.Items

        For i = 1 To olItems.Count
            On Error Resume Next
            If TypeOf olItems(i) Is Outlook.MailItem Then
                Set olMail = olItems(i)
                ' Check if the mail is flagged
                If olMail.FlagStatus = olFlagMarked Then
                    ' Avoid duplicates by checking if the email is already in the array
                    If Not IsEmailInArray(olMail.entryID, flaggedEmailsArr, flaggedCount) Then
                        flaggedCount = flaggedCount + 1
                        ReDim Preserve flaggedEmailsArr(1 To 4, 1 To flaggedCount)
                        flaggedEmailsArr(1, flaggedCount) = olMail.SenderName
                        flaggedEmailsArr(2, flaggedCount) = olMail.Subject
                        flaggedEmailsArr(3, flaggedCount) = Format(olMail.ReceivedTime, "dd/mm/yyyy")
                        flaggedEmailsArr(4, flaggedCount) = folderName
                    End If
                End If
            End If
            On Error GoTo 0
        Next i

        ' Recursively search subfolders
        If olFolder.Folders.Count > 0 Then
            SearchFolders olFolder.Folders, ws, flaggedEmailsArr, flaggedCount
        End If
    Next olFolder
End Sub

Function IsEmailInArray(ByVal entryID As String, ByRef emailArray As Variant, ByVal emailCount As Long) As Boolean
    Dim i As Long
    For i = 1 To emailCount
        If emailArray(1, i) = entryID Then
            IsEmailInArray = True
            Exit Function
        End If
    Next i
    IsEmailInArray = False
End Function [code]

 

[saboh12617]

Hello,

On the coding side, your code is already pretty good. The main issue is that you recursively look all the folders in a directory, which i suppose is very large. Maybe it could be smart to add some conditions to this recursion, about folder's dates for example (do you need to check very old emails?), or even better: clean the folder manually/automatically.

Another option could be that, if you frequently run this macro on the same directory, and you know that some folders will not change and have already be checked: store their results in the workbook and read them instead of iterating on the files.

However, all those improvements are more related to the "process" than the coding. In my opinion your macro could not be significantly faster by refactoring it.

Maybe it is also possible to use other tools than VBA for this task? I don't know.

 

[howard]

Thanks for your input. Will amend code to only extract flagged items up to 3 months old from today's date