AWE_Email - Create and Read Emails

Published on 9 May 2023 at 18:02

AWE_Email handles the complexity of creating and reading MS Outlook Emails. This includes creating emails with Excel Charts, PivotTables, Ranges, and attachments. Easily create complex search criteria that finds and reads email. Interface with MS Exchange and Outlook to lookup contacts. All source code is included and it's FREE.

Implementation

Add the below AWE_Email class to your workbook (see How to Create a Class for more information). Function definitions, parameters and examples are documented in the comments before each function (see below).

'******************************************************************************************************************
'******************************************************************************************************************
'* AWE_Email:  AWE_Email allows for easy automation of Microsoft Outlook emails. Read and respond to emails      **
'*             based on criteria and information stored in your spreadsheet. Send formatted PivotTables,         **
'*             Charts/Graphs, reports, ranges or data, workbooks, with data extracted from excel.                **                                                              **
'* Author:     Mike Libby                                                                                        **
'* Website:    AutomationWithExcel.com                                                              **
'******************************************************************************************************************
'******************************************************************************************************************
Option Explicit

'==================================================================================================================
'== PRIVATE VARIABLES =============================================================================================
'==================================================================================================================
Enum OutlookFolders: olFolderInbox = 6: olFolderSentMail = 5: Default = 0: End Enum
Enum OutlookItemType: olMailItem = 0: End Enum
Enum OutlookBodyFormat: olFormatHTML = 2: End Enum
Enum OlMailRecipientType: oloriginator = 0: olTo = 1: olCC = 2: olBCC = 3: All = 4: End Enum
Enum SchemaTyp: ActualFrom: FromEmail: FromName: DisplayTo: DisplayCC: LastModDt: DateReceived: DateSent: _
     HasAttach: Subject: body: End Enum
Enum OperatorTyp: EQ: LT: LTE: GT: GTE:  BEGINSWITH: CONTAINS: USERDEFINED: End Enum

'==================================================================================================================
'== Find\Read EMAILS ==============================================================================================
'==================================================================================================================
'------------------------------------------------------------------------------------------------------------------
' FindEmails - Find emails in MS Outlook or Exchange using a combination of search values like subject contains,
'              date is greater than or less than, sender is equal to... Emails are sorted newest messages first.
' Params:  FolderType As OutlookFolders - olFolderInbox = search Inbox, olFolderSentMail = Search the Sent
'          SubFolders As String - Semicolon delimited list of folders to search for emails in. Note, an
'                                 empty string ("" or ";SearchFolders) will search the root folder. Folders are
'                                 search in the order that they are listed.
'          EmailDict As Variant - a Scripting.Dictionary list of found emails. Can be "Nothing" if not making
'                                 subsequent calls to FindEmails.
'          LastConvOnly As Boolean - If true, then the last email received in the first folder found with a
'                                    specific conversation id will be returned. Rules for mail servers generating
'                                    a new Conversation ID: a new email even with identical subjects, or the
'                                    subject changes.
'          ParamArray SearchParams As Variant - a list of search conditions built using one or more
'                                               AWE_Email.CreateSearchParam(SearchType, SearchOperator, SearchVal)
'                                               See Function CreateSearchParam for more information.
' Returns: Array of found Outlook Mailitems
' Example: Dim Emails As New AWE_Email, Email as Variant
'          For Each Email In AWEEmail.FindEmails(olFolderInbox, ";SubFolder", Nothing, True, _
'                               AWEEmail.CreateSearchParam(Subject, CONTAINS, "Test"), _
'                               AWEEmail.CreateSearchParam(Subject, _
'                               AWEEmail.CreateSearchParam(LastModDt, GTE, Format(Now - 365, "General Date")), _
'                               AWEEmail.CreateSearchParam(LastModDt, LTE, Format(Now, "General Date")))
'              Debug.Print Email.Body
'          Next Email
'-------------------------------------------------------------------------------------------------------------------
Public Function FindEmails(FolderType As OutlookFolders, SubFolders As String, ByRef EmailDict As Variant, _
    LastConvOnly As Boolean, ParamArray SearchParams() As Variant) As Variant
    If FolderType = Default Then FolderType = OutlookFolders.olFolderInbox
    If SubFolders = "" Then SubFolders = " "
    Dim olApp As Object: Set olApp = CreateObject("Outlook.Application")
    Dim olNs As Object: Set olNs = olApp.GetNamespace("MAPI")
    Dim subFldr As Variant, Fldr As Object: Set Fldr = olNs.GetDefaultFolder(FolderType)
    Dim OlItems As Object, OlMail As Object
    Dim SearchParam As Variant, sSrchBldr As String
    Dim RcvdDt As Date, SentDt As Date
    
    If TypeName(EmailDict) <> "Dictionary" Then
        Set EmailDict = CreateObject("Scripting.Dictionary")
    End If
   
    For Each SearchParam In SearchParams
        If sSrchBldr = "" Then sSrchBldr = "@SQL=" Else sSrchBldr = sSrchBldr & " and "
        sSrchBldr = sSrchBldr & SearchParam
    Next SearchParam
   
    For Each subFldr In Split(SubFolders, ";")
        subFldr = Trim(CStr(subFldr))
       
        If subFldr = "" Then Set Fldr = olNs.GetDefaultFolder(FolderType) _
        Else: Set Fldr = olNs.GetDefaultFolder(FolderType).Folders(CStr(subFldr))
       
        Set OlItems = Fldr.items
        If FolderType = olFolderInbox Then OlItems.Sort "ReceivedTime", True _
        Else OlItems.Sort "SentOn", True
   
        Set OlMail = OlItems.Find(sSrchBldr)
        While Not OlMail Is Nothing
            If TypeName(OlMail) = "MailItem" Then
                If LastConvOnly = False Then
                    Set EmailDict(EmailDict.Count) = OlMail
                Else
                    If EmailDict.Exists(OlMail.ConversationID) Then
                        If EmailDate(EmailDict(OlMail.ConversationID)) < EmailDate(OlMail) Then
                            Set EmailDict(OlMail.ConversationID) = OlMail
                        End If
                    Else
                        Set EmailDict(OlMail.ConversationID) = OlMail
                    End If
                End If
                Set OlMail = OlItems.FindNext
            End If
        Wend
    Next subFldr
    FindEmails = EmailDict.items
End Function


'-------------------------------------------------------------------------------------------------------------------
' CreateSearchParam - Create search paramaters (SearchParams) for FindEmails
' Params: SeearchType - Possible search type (intelliSense display) values are:
'            * ============= From Emails ========================================
'            * ActualFrom   -  Sender email address (ignore alias)
'            * FromEmail    - Sender email address (alias overrides actual sender)
'            * FromName     - Sender email name
'            * ============= TO/CC Emails =======================================
'            * DisplayTo    - To email address
'            * DisplayCC    - CC email address
'            * ============= Dates ==============================================
'            * LastModDt    - Date the email was last modified
'            * DateReceived - Date that the email was received
'            * DateSent     - Date that the email was sent by you
'            ' ============= Attachment, Subject & Body =========================
'            * HasAttach    - True if email has attachment otherwise false
'            * Subject      - Email subject
'            * body         - Email body
'         OperatorType - Possible search oerator (intelliSense display) values are:
'            * EQ:          = SearchVal
'            * LT:          < SearchVal
'            * LTE:         <= SearchVal
'            * GT:          > SearchVal
'            * GTE:         >= SearchVal
'            * BEGINSWITH:  Like SearchVal%
'            * CONTAINS:    Like %SearchVal%
'            * USERDEFINED: User defined search and operator values
'         SrchForStr - The string to search for
'            * '|' combine multiple search parameters by "or"
' Returns: String of fully formatted search parameter for FindEmails
' Example: Debug.Print AWEEmail.CreateSearchParam(Subject, CONTAINS, "Test")
'          Debug.Print AWEEmail.CreateSearchParam(LastModDt, GTE, Format(Now - 365, "General Date"))
'          Debug.Print AWEEmail.CreateSearchParam(LastModDt, LTE, Format(Now, "General Date"))
'          Debug.Print AWEEmail.CreateSearchParam(FromName, CONTAINS, "Mike|Michael")
'-------------------------------------------------------------------------------------------------------------------
Public Function CreateSearchParam(SearchType As SchemaTyp, SearchOperator As OperatorTyp, SrchForStr As Variant) As String
    Dim sBldr As String, var As Variant
    
    For Each var In Split(SrchForStr, "|")
        If sBldr <> "" Then
            If Left(sBldr, 1) <> "(" Then sBldr = "(" & sBldr
            sBldr = sBldr & " or "
        End If
        
        Select Case SearchType
            '========= From Emails ==========================
            Case SchemaTyp.ActualFrom:   sBldr = sBldr & "urn:schemas:httpmail:sender"
            Case SchemaTyp.FromEmail:    sBldr = sBldr & "urn:schemas:httpmail:fromemail"
            Case SchemaTyp.FromName:     sBldr = sBldr & "urn:schemas:httpmail:fromname"
            '========= To/CC Emails =========================
            Case SchemaTyp.DisplayTo:    sBldr = sBldr & "urn:schemas:httpmail:displayto"
            Case SchemaTyp.DisplayCC:    sBldr = sBldr & "urn:schemas:httpmail:displaycc"
            '========= Dates =================================
            Case SchemaTyp.LastModDt:    sBldr = sBldr & "DAV:getlastmodified"
            Case SchemaTyp.DateReceived: sBldr = sBldr & "urn:schemas:httpmail:datereceived"
            Case SchemaTyp.DateSent:       sBldr = sBldr & "urn:schemas:httpmail:date"
            '========= Attachment, Subject & Body ============
            Case SchemaTyp.HasAttach:    sBldr = sBldr & "urn:schemas:httpmail:hasattachment"
            Case SchemaTyp.Subject:      sBldr = sBldr & "urn:schemas:httpmail:subject"
            Case SchemaTyp.body:         sBldr = sBldr & "urn:schemas:httpmail:textdescription"
        End Select
        
        Select Case SearchOperator
            Case OperatorTyp.EQ:         sBldr = sBldr & " = '" & var & "'"
            Case OperatorTyp.LT:         sBldr = sBldr & " < '" & var & "'"
            Case OperatorTyp.LTE:        sBldr = sBldr & " <= '" & var & "'"
            Case OperatorTyp.GT:         sBldr = sBldr & " > '" & var & "'"
            Case OperatorTyp.GTE:        sBldr = sBldr & " >= '" & var & "'"
            Case OperatorTyp.BEGINSWITH: sBldr = sBldr & " Like '" & var & "%'"
            Case OperatorTyp.CONTAINS:   sBldr = sBldr & " Like '%" & var & "%'"
        End Select
    Next var
    If Left(sBldr, 1) = "(" Then sBldr = sBldr & ")"
    
    CreateSearchParam = sBldr
End Function

'-------------------------------------------------------------------------------------------------------------------
' IsEmailSent - Returns true if the email was sent otherwise false
' Params: Email as Variant and an Outlook.MailItem
'-------------------------------------------------------------------------------------------------------------------
Public Function IsEmailSent(Email As Variant) As Boolean
    On Error Resume Next
    IsEmailSent = False: If Email.SentOn > 0 Then IsEmailSent = True
    If Email.ReceivedTime > Email.SentOn Then IsEmailSent = False
End Function

'-------------------------------------------------------------------------------------------------------------------
' EmailDate - Returns the last date the email was either sent or received
' Params: Email as Variant and an Outlook.MailItem
'-------------------------------------------------------------------------------------------------------------------
Public Function EmailDate(Email As Variant) As Date
    If IsEmailSent(Email) Then EmailDate = Email.SentOn Else EmailDate = Email.ReceivedTime
End Function

'-------------------------------------------------------------------------------------------------------------------
' Recips - Returns an array of email recipients.
' Params:  Outlook Email Object (retuned from FindEmails)
'          RecipType as OlMailRecipientType - Type of recipients to return. Default = All.
' Returns: Array of two dimensional outlook items (ListNb)(0=Name, 1=EmailAddr, 3=RecipientObject)
' Example: Dim Emails As New AWE_Email, Email as Variant, Recip as Variant
'          For Each Email inEmails.FindEmails("String to Find in Subject")
'              For Each Recip In AWEEmail.ToRecips(oEmail)
'                   Debug.Print "Recipient: " & Recip(0) & ", EmailAddr: "; Recip(1)
'              Next Recip
'          Next Email
'-------------------------------------------------------------------------------------------------------------------
Public Function Recips(oEmail As Variant, _
                Optional RecipType As OlMailRecipientType = OlMailRecipientType.All) As Variant
    Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    Dim oRecip As Variant, dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    For Each oRecip In oEmail.Recipients
        If oRecip.Type = RecipType Or RecipType = OlMailRecipientType.All Then _
            dict(oRecip.name) = Array(oRecip.name, oRecip.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS), oRecip)
    Next oRecip
    Recips = dict.items
End Function

'===================================================================================================================
'== CREATE EMAILS ==================================================================================================
'===================================================================================================================
'-------------------------------------------------------------------------------------------------------------------
' CreateEmail - Create an outlook HTML Email
' Params:  ToStr As String - To Email Addresses
'          CcStr As String - CCs Email Addresses
'          Subject As String - Email Subject
'          HTML As String - HTML formatted body of the email
'          Optional HiddenFileAttachments As string - Semicolon list of hidden attachment files.
'          Optional FileAttachments As String - Semicolon list of attachment files.
'          Optional KillAttachements as Boolean - True=delete attachements; otherwise, False (default).
'          Optional SendImmediately as Boolean - True=send without display; otherwise false (default).
' Example: AWEEmail.CreateEmail("to@domain.com", "CCs@...", "Subject", "FullFileAttach", "HTML Body")
'-------------------------------------------------------------------------------------------------------------------
Public Function CreateEmail(ToStr As String, CcStr As String, Subject As String, HTML As String, _
       Optional HiddenFileAttachments As String = "", Optional FileAttachments As String, _
       Optional KillAttachements As Boolean = False, Optional SendImmediately As Boolean = False)
    Dim olApp As Object: Set olApp = CreateObject("Outlook.Application")
    Dim olEmail As Object: Set olEmail = olApp.CreateItem(OutlookItemType.olMailItem)
    Dim FileNm As Variant
    
    With olEmail
        .to = ToStr
        .CCs = CcStr
        .Subject = Subject
        
        If HiddenFileAttachments <> "" Then
            For Each FileNm In Split(HiddenFileAttachments, ";")
                .attachments.Add FileNm, 1, 0
            Next FileNm
        End If
        
        If FileAttachments <> "" Then
            For Each FileNm In Split(FileAttachments, ";")
                .attachments.Add FileNm
            Next FileNm
        End If
        .BodyFormat = OutlookBodyFormat.olFormatHTML
        .Display    ' display here so that the signature can be shown if it exists
        .htmlBody = HTML & .htmlBody
        If SendImmediately Then .Send Else .Display
    End With
    
    If KillAttachements = True Then
        For Each FileNm In Split(HiddenFileAttachments, ";")
            Kill FileNm
        Next FileNm
        For Each FileNm In Split(FileAttachments, ";")
            Kill FileNm
        Next FileNm
    End If
End Function

'===================================================================================================================
'== CREATE GRAPHICS ================================================================================================
'===================================================================================================================
'-------------------------------------------------------------------------------------------------------------------
' CopyRangeToJPG - Create a JPG image from a range return the JPG's temp folder FullFileName.
' Params:  NameWorksheet As String - Name of the Worksheet
'          RangeAddress As String - Range of the worksheet to copy to a picture
' Returns: FullFileName to the picture stored in the temp folder
' Example: Dim FileNm as String: FileNm = AWEEmail.CopyRangeToJPG ("SheetNm" "RangeAddr")
'-------------------------------------------------------------------------------------------------------------------
Function CopyRangeToJPG(NameWorksheet As String, RangeAddress As String) As String
    Dim PictureRange As Range

    With ActiveWorkbook
        On Error Resume Next
        .Worksheets(NameWorksheet).Activate
        Set PictureRange = .Worksheets(NameWorksheet).Range(RangeAddress)
        
        If PictureRange Is Nothing Then
            MsgBox "Sorry this is not a correct range"
            Exit Function
        End If
        
        PictureRange.CopyPicture
        With .Worksheets(NameWorksheet).ChartObjects.Add(PictureRange.Left, PictureRange.Top, _
                PictureRange.Width, PictureRange.Height)
            .Activate
            .Chart.Paste
            .Chart.Export Environ$("temp") & Application.PathSeparator & "Picture.jpg", "JPG"
        End With
        .Worksheets(NameWorksheet).ChartObjects(.Worksheets(NameWorksheet).ChartObjects.Count).Delete
    End With
    
    CopyRangeToJPG = Environ$("temp") & Application.PathSeparator & "Picture.jpg"
    Set PictureRange = Nothing
End Function

'-------------------------------------------------------------------------------------------------------------------
' CopyChartToJPG - Create a JPG image from a chart and return the JPG's temp folder FullFileName.
' Params:  ws As Worksheet
'          ChartNm As String
' Returns: FullFileName to the picture stored in the temp folder
' Example: Dim FileNm As String: FileNm = AWEEmail.CopyChartToJPG ("SheetNm", "ChartNm")
'-------------------------------------------------------------------------------------------------------------------
Public Function CopyChartToJPG(ws As Worksheet, ChartNm As String) As String
    Dim chrtObj As ChartObject: Set chrtObj = ws.ChartObjects(ChartNm)
    Dim ChrtNm As String: ChrtNm = Environ$("temp") & Application.PathSeparator & ChartNm & ".jpg"
    chrtObj.Activate
    ActiveChart.Export ChrtNm, "JPG"
    CopyChartToJPG = ChrtNm
End Function

'-------------------------------------------------------------------------------------------------------------------
' ChartToHtml - Create HTML to display attached image
' Params:  ws As Worksheet - Chart worksheet
'          ChartNm as String - Chart name
'          optonal Height as Long - Height of chart in pixels. Default = Original Height
' Returns: String - HTML to display attached image
' Example: Dim HTML as String: HTML = AWEEmail.ChartToHtml(ws, "ChartNm", 50)
'-------------------------------------------------------------------------------------------------------------------
Public Function ChartToHtml(ws As Worksheet, ChrtNm As String, Optional Height As Long = 0) As String
    Dim chrtObj As ChartObject: Set chrtObj = ws.ChartObjects(ChrtNm)
    Dim Width As Long, ChrtPct As Double
    If Height <> 0 Then
        ChrtPct = (Height - chrtObj.Height) / Height
        Width = chrtObj.Width: If ChrtPct <> 0 Then Width = Width * ChrtPct
    End If
    ChartToHtml = "<img src=""cid:" & ChrtNm & ".jpg" & """ width=" & Width & " height=" & Height & ">"
End Function

'===================================================================================================================
'== RANGE TO HTML ==================================================================================================
'===================================================================================================================
'-------------------------------------------------------------------------------------------------------------------
' RangetoHTML - Convert a worksheet range to HTML
' Params:  Rng as Range - Range to convert
' Returns: Range formatted as HTML
' Example: Dim HTML as string: HTML = AWEEmail.RangeToHTML(rng, False)
'-------------------------------------------------------------------------------------------------------------------
Public Function RangetoHTML(Rng As Range) As String
    Dim fso As Object, ts As Object, TempFile As String, TempWB As Workbook, TempWS As Worksheet
    Dim iFmStartCol As Long, iFmEndCol As Long, iFmStartRow As Long, iFmEndRow As Long
    Dim iToStartCol As Long, CopyFormatRng As Range, CopyDataRng As Range, PasteRng As Range, SrcRng As Range
    Dim ws As Worksheet: Set ws = Rng.Parent
    Dim ColNms As Variant, ColNm As Variant, irow As Long, iCol As Long
    Dim LnkRng As Range

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    '--- Copy range ---
    Rng.Copy
    Set TempWB = Workbooks.Add(1)
    Set TempWS = TempWB.Sheets(1)
    With TempWS
        .Cells(1).PasteSpecial xlPasteColumnWidths, , False, False
        .Cells(1).PasteSpecial xlPasteAll, , False, False
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select

        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    
    '--- copy the range to html ---
    Application.ReferenceStyle = xlA1
    
    '--- get the final range ---
    With TempWS
        Set SrcRng = TempWS.UsedRange
    End With
    
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).name, _
         Source:=SrcRng.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    '--- clean up ---
    TempWB.Close savechanges:=False
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

'===================================================================================================================
'== CONVERT RANGE TO ATTACHMENT ====================================================================================
'===================================================================================================================
'-------------------------------------------------------------------------------------------------------------------
' RangetoNewWorkbook - Convert a worksheet range to an email attachment
' Params:  Rng as Range - Range to convert
'          AttachFullFileNm as String - FileNm. Default="WB_" Format(Now, "yymmdd-hhmmss") & ".xlsx"
' Note:    AttachFullFileNm can be deleted after the email is sent.
' Example: Dim FileNm as String: FileNm = AWEEmail.RangeToHTML(rng, False)
'-------------------------------------------------------------------------------------------------------------------
Public Function RangetoNewWorkbook(Rng As Range, Optional AttachFullFileNm As String = "") As String
    Dim fso As Object, ts As Object, TempFile As String, TempWB As Workbook, TempWS As Worksheet
    Dim iFmStartCol As Long, iFmEndCol As Long, iFmStartRow As Long, iFmEndRow As Long
    Dim iToStartCol As Long, CopyFormatRng As Range, CopyDataRng As Range, PasteRng As Range, SrcRng As Range
    Dim ws As Worksheet: Set ws = Rng.Parent
    Dim ColNms As Variant, ColNm As Variant, irow As Long, iCol As Long
    Dim LnkRng As Range

    If AttachFullFileNm = "" Then
        AttachFullFileNm = Environ$("temp") & "\" & "WB_" & Format(Now, "yymmdd-hhmmss") & ".xlsx"
    End If
    RangetoNewWorkbook = AttachFullFileNm
    
    '--- Copy range ---
    Rng.Copy
    Set TempWB = Workbooks.Add(1)
    Set TempWS = TempWB.Sheets(1)
    With TempWS
        .Cells(1).PasteSpecial xlPasteColumnWidths, , False, False
        .Cells(1).PasteSpecial xlPasteAll, , False, False
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select

        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
    End With
    TempWB.SaveAs AttachFullFileNm
    TempWB.Close
    Set TempWB = Nothing
End Function

'-------------------------------------------------------------------------------------------------------------------
' KillTempFile - Removes temporary files that were created for attachements.
' Params:  Full path to the tempoary file
' Example: AWEEmail.KillTempFile("FullFileName")
'-------------------------------------------------------------------------------------------------------------------
Public Function KillTempFile(FullFileNm As String)
    Kill FullFileNm
End Function

'===================================================================================================================
'== Contact Info ===================================================================================================
'===================================================================================================================
'-------------------------------------------------------------------------------------------------------------------
' GetRecipient - Get the Recipient Object from Outlook
' Params:  Name as String - Outlook name to lookup
' Returns: Recipient object
' Example: Dim recip as Object: set recip = AWEEmail.GetRecipient("Full Name")
'-------------------------------------------------------------------------------------------------------------------
Public Function GetRecipient(name As String) As Variant
    Dim outlApp As Object: Set outlApp = CreateObject("Outlook.Application")
    Dim outlNameSpace As Object: Set outlNameSpace = outlApp.GetNamespace("MAPI")
    Dim outlGAL As Object: Set outlGAL = outlNameSpace.GetGlobalAddressList()
    Dim outlEntry As Object: Set outlEntry = outlGAL.AddressEntries
    Dim outlRecipient As Object, outlMember As Object, var As Variant

    If name = "" Then Exit Function
    On Error Resume Next

    Set outlRecipient = outlNameSpace.CreateRecipient(name)
    outlRecipient.Resolve

    If outlRecipient.Resolved Then Set GetRecipient = outlRecipient
End Function

'-------------------------------------------------------------------------------------------------------------------
' GetOutlookContact - Get the Contact Object for a name from Outlook.
' Params:  Name as String - Outlook name to lookup
' Returns: oRecipient.AddressEntry.GetContact object
' Example: Dim recip as Object: set recip = AWEEmail.GetRecipient("Full Name")
' Note1:   See https://learn.microsoft.com/en-us/office/vba/api/outlook.contactitem
' Note2:   If the outlook profile isn't already open, the user will be prompted to select one.
'-------------------------------------------------------------------------------------------------------------------
Public Function GetOutlookContact(name As String) As Variant
    Dim oRecipient As Object
    Set oRecipient = GetRecipient(name)
    Set GetOutlookContact = Nothing
    If Not oRecipient Is Nothing Then
        If Not oRecipient.AddressEntry Is Nothing Then
            Set GetOutlookContact = oRecipient.AddressEntry.GetContact
        End If
    End If
End Function

'-------------------------------------------------------------------------------------------------------------------
' GetExchangeUser - Get an ExchangeUser Object for a name from Exchange's GAL (Global Access Libary).
' Params:  Name as String - Outlook name to lookup
' Returns: outlRecipient.AddressEntry.GetExchangeUser
' Example: Dim oExchgUser as Object: set oExchgUser = AWEEmail.GetRecipient("Full Name")
' Note:    See https://learn.microsoft.com/en-us/office/vba/api/outlook.exchangeuser#properties
'-------------------------------------------------------------------------------------------------------------------
Public Function GetExchangeUser(name As String) As Variant
    Dim outlApp As Object: Set outlApp = CreateObject("Outlook.Application")
    Dim outlNameSpace As Object: Set outlNameSpace = outlApp.GetNamespace("MAPI")
    Dim outlRecipient As Object

    Set GetExchangeUser = Nothing
    If name = "" Then Exit Function
    On Error Resume Next
   
    Set outlRecipient = outlNameSpace.CreateRecipient(name)
    outlRecipient.Resolve
    If outlRecipient.Resolved Then Set GetExchangeUser = outlRecipient.AddressEntry.GetExchangeUser
End Function

'===================================================================================================================
'== Save Email/Attachments =========================================================================================
'===================================================================================================================
'-------------------------------------------------------------------------------------------------------------------
' SaveEmail - Save the email.
' Params:  Email as Object - Outlook email object.
'          Optional FilePath as String - Path to the filename (default=Environ$("temp")).
'          Optional FileNm as String - Name of the file (default=RecvdTm_Sender_Subject).
'          Optional PromptUser as Boolean - True if prompt user to save; otherwise, false (default).
' Returns: List of saved email filenames.
' Example: Dim Arr as Variant: set Arr = AWEEmail.SaveEmail(oEmail)
'-------------------------------------------------------------------------------------------------------------------
Public Function SaveEmail(Email As Object, Optional FilePath As String = "", _
                Optional FileNm As String = "", Optional PromptUser As Boolean = False) As String
    Dim sFullFileNm As String
    
    If Email Is Nothing Then Exit Function
    If FilePath = "" Then FilePath = Environ$("temp") & Application.PathSeparator
    If FileNm = "" Then FileNm = Format(CDate(Email.ReceivedTime), "yyyymmdd_hhmmAM/PM") & "_" & _
        CleanString(Email.Sender, "") & "_" & CleanSubject(Email.Subject) & ".msg"
    sFullFileNm = FilePath & FileNm
    
    If PromptUser Then
        If MsgBox("Save email..." & vbCrLf & FileNm, vbYesNo + vbQuestion) = vbNo Then Exit Function
    End If
    Email.SaveAs sFullFileNm
    SaveEmail = sFullFileNm
End Function

'-------------------------------------------------------------------------------------------------------------------
' SaveAttachments - Save the email attachments.
' Params:  Email as Object - Outlook email object.
'          Optional FilePath as String - Path to the filename (default=Environ$("temp")).
'          Optional FileNm as String - Name of the file (default=RecvdTm_Sender_Subject).
' Returns: List of saved attachments as an array of strings
' Example: Dim Arr as Variant: set ARR = AWEEmail.SaveAttachments(oEmail)
'-------------------------------------------------------------------------------------------------------------------
Public Function SaveAttachments(Email As Object, Optional FilePath As String = "", _
                                Optional FileNames As String = "") As Variant
    
    Dim var As Variant, FileNm As Variant, oAttach As Object
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    
    If Email Is Nothing Then Exit Function
    If Email.attachments.Count = 0 Then Exit Function
    
    If FilePath = "" Then FilePath = Environ$("temp") & Application.PathSeparator
    If FileNames = "" Then
        For Each var In Email.attachments
            If FileNames <> "" Then FileNames = FileNames & ";"
            FileNames = FileNames & var.Filename
        Next var
    End If
    
    For Each FileNm In Split(FileNames, ";")
        Set oAttach = Email.attachments(CStr(FileNm))
        If Not oAttach Is Nothing Then
            oAttach.SaveAsFile FilePath & FileNm
            dict(FileNm) = FilePath & FileNm
        End If
    Next FileNm
    SaveAttachments = dict.items
End Function

'===================================================================================================================
'== Hyperlinks =====================================================================================================
'===================================================================================================================
Public Function GetHyperlink(Email As Variant, Optional RegExSrchPtrn As String, _
        Optional isGlobal As Boolean = False) As Variant
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim oHyperlink As Object, oMailDoc As Object
    On Error Resume Next
    Set oMailDoc = Email.GetInspector.WordEditor
    For Each oHyperlink In oMailDoc.Hyperlinks
        If RegExSrchPtrn = "" Or FindPattern(oHyperlink.Address, RegExSrchPtrn) <> "" Then
            If isGlobal Then
                dict(oHyperlink.Address) = oHyperlink.Address
            Else
                GetHyperlink = oHyperlink.Address: Exit Function
            End If
        End If
    Next oHyperlink
    If isGlobal = True Then GetHyperlink = dict.items
End Function



'===================================================================================================================
'== RegEx/Strings ==================================================================================================
'===================================================================================================================
'-------------------------------------------------------------------------------------------------------------------
' FindPattern - Search for a RegEx pattern.
' Params:  FindInStr as String - String being searched.
'          SrchPtrn as String - RegEx Pattern to search for.
'          IsGobal as Boolean - If False (default) returns a string; otherwise, an array of strings.
' Srch     PhoneNumber="\(?\b[2-9][0-9]{2}\)?[-. ]?[2-9][0-9]{2}[-. ]?[0-9]{4}\b"
' Ptrns:   Zip Codes="\b[0-9]{5}(?:-[0-9]{4})?\b"
'          HTTPS, FTP, or File="\b(https?|ftp|file)://[-A-Z0-9+&@#/%?=~_|$!:,.;]*[A-Z0-9+&@#/%=~_|$]"
'          Web Site="\b(?:(?:https?|ftp|file)://|www\.|ftp\.)[-A-Z0-9+&@#/%=~_|$?!:,.]*[A-Z0-9+&@#/%=~_|$]"
'          Email Address="\(?\b[2-9][0-9]{2}\)?[-. ]?[2-9][0-9]{2}[-. ]?[0-9]{4}\b"
'          Specific Pattern="E-\d{5}\.\d{2}" = Starts with "E-", 5 digits, a "." and 2 digits.
'          From and to string="Find From String(.*?)Find To String"
'          Multiple matches="(From1|From2|From3)(.*?)(To1|To2|To3)"
'
' Example: Print AWEEmail.FindPattern ("Find in String E-12345.12", "E-\d(5)\.\d(2)")
' Note:    "^"=Beginning of a string or line. "$"=End of a string. "([^\r]+)"=VBCRLF. "\."=period
'          "\n"=New Line
'-------------------------------------------------------------------------------------------------------------------
Public Function FindPattern(FindInStr As String, RegExSrchPtrn As String, _
                            Optional isGlobal As Boolean = False, Optional ReturnString As Boolean = True) As Variant
    Dim regExMatch As Object, vPtrn As Variant, sPtrnBldr As String
    Dim idx As Long, dict As Object: Set dict = CreateObject("Scripting.Dictionary")

    With CreateObject("VBScript.RegExp")
        .ignorecase = True
        .Global = isGlobal
        .pattern = RegExSrchPtrn
        If .test(FindInStr) Then
            If isGlobal = False Then
                Set regExMatch = .Execute(FindInStr)
                If ReturnString = True Then FindPattern = regExMatch(0).Value Else FindPattern = regExMatch(0)
            Else
                For Each regExMatch In .Execute(FindInStr)
                    If ReturnString = True Then dict("Idx" & idx) = regExMatch.Value _
                    Else dict("Idx" & idx) = regExMatch
                    idx = idx + 1
                Next regExMatch
                FindPattern = dict.items
            End If
        End If
    End With
    If isGlobal = True And IsArray(FindPattern) = False Then FindPattern = dict.items
End Function

'-------------------------------------------------------------------------------------------------------------------
' CleanPhoneNbr - Returns phone number digits only (special characters are removed)
' Params:  PhNum as String - Phone number
'-------------------------------------------------------------------------------------------------------------------
Public Function CleanPhoneNbr(PhNum As String) As String
  Dim X As Long
  For X = 1 To Len(PhNum)
    If Mid(PhNum, X, 1) Like "[!0-9]" Then Mid(PhNum, X) = " "
  Next
  CleanPhoneNbr = Replace(PhNum, " ", "")
End Function

'-------------------------------------------------------------------------------------------------------------------
' CleanSubject - Removes [EXTERNAL|INTERNAL] trailing spaces from the subject
' Params:  Subject as string
'-------------------------------------------------------------------------------------------------------------------
Public Function CleanSubject(str As String) As String
    Dim var As String, loc As Long: loc = InStr(str, ":")
    If loc > 0 Then var = Trim(Right(str, Len(str) - loc)) Else var = str
    var = Trim(Replace(var, "[EXTERNAL]", ""))
    var = Trim(Replace(var, "[INTERNAL]", ""))
    With CreateObject("vbscript.regexp")
        .Global = True: .MultiLine = True: .ignorecase = False: .pattern = "[^a-zA-Z0-9\- ]"
        CleanSubject = Trim(.Replace(var, " "))
        CleanSubject = Replace(Replace(CleanSubject, vbCr, ""), vbLf, "")
    End With
End Function

'-------------------------------------------------------------------------------------------------------------------
' CleanString - Removes specified characters from the string.
' Params: StringToClean as String - string to search through.
'         ParamArray RemoveStrings - list of strings to remove from the StringToClean
' Example: Dim str as String: str = CleanString(StringToClean, "RemoveString", vbCR, vbLF,
'          This example removes the string "RemoveString" and special characters carriage returns and line feeds.
'-------------------------------------------------------------------------------------------------------------------
Public Function CleanString(StringToClean As String, ParamArray RemoveStrings() As Variant) As String
    Dim var As Variant
    For Each var In RemoveStrings
        StringToClean = Replace(StringToClean, var, "")
    Next var
    CleanString = Trim(StringToClean)
End Function

AWE_Email Examples

The below examples show how to use the above AWE_Email class to create and send emails, find and read emails, and get Outlook and Exchange Server contacts. Use AWE_Class as it is or extend its capabilities even further to meet your specific needs.

Create and Send Emails

Send a Simple HTML Email - Create a simple "Hello World" email.

Public Function HelloWorld()
    Dim AWEEmail As New AWE_Email
    Call AWEEmail.CreateEmail("World@domain.com", "", "Hello World", "Hi World,<BR><BR>First email with AWE_Email!")
End Function

Send a Pivot Chart - Create an email that contains an Excel Chart embedded in the HTML.

Public Function PivotChartEmail()
    Dim AWEEmail As New AWE_Email
    Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Dashboard")
    Dim EmpNm As String: EmpNm = GetSelectedSlicerItems("Slicer_Employee_Name"): If EmpNm = "" Then EmpNm = "All"
    Dim sChrtPath As String: sChrtPath = AWEEmail.CopyChartToJPG(ws, "ChartEmpRev")
    Dim sAttachments As String: sAttachments = sChrtPath
    Dim HTML As String
    HTML = "Hi " & EmpNm & ",<BR><BR>Below is a graph showing revenue by month for the year...<BR><BR>" & _
            AWEEmail.ChartToHtml(ws, "ChartEmpRev", 125)
    Call AWEEmail.CreateEmail("Emp@Domain.com", "", "PivotChartEmail - " & EmpNm, HTML, sAttachments)
End Function

'--- The below code retrieves Excel Slicer Selections which is used above. It does not apply to AWE_Email ---
Public Function GetSelectedSlicerItems(SlicerName As String) As String
    Dim sI As SlicerItem, Names As String
    
    For Each sI In ActiveWorkbook.SlicerCaches(SlicerName).SlicerItems
        If sI.Selected = True Then
            If Names <> "" Then Names = Names & ", "
             Names = Names & (sI.Value)
        End If
    Next
    If UBound(Split(Names)) > 1 Then
        Names = StrReverse(Replace(StrReverse(Names), StrReverse(","), StrReverse(", and"), , 1))
    End If
    GetSelectedSlicerItems = Names
End Function

Send a PivotTable - Create an email that contains an Excel PivotTable embedded in the HTML.

Public Function PivotTableEmail()
    Dim AWEEmail As New AWE_Email
    Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Dashboard")
    Dim EmpNm As String: EmpNm = GetSelectedSlicerItems("Slicer_Employee_Name"): If EmpNm = "" Then EmpNm = "All"
    Dim HTML As String: HTML = "Hi " & EmpNm & ",<BR><BR>Below is a PivotTable showing revenue for the year...<BR>"
    HTML = HTML & AWEEmail.RangetoHTML(ws.PivotTables(1).TableRange1)
    HTML = HTML & "<BR>Your hard work is appreciated."
    
    Call AWEEmail.CreateEmail("Emp@Domain.com", "", "PivotTableEmail - " & EmpNm, HTML)
End Function

Attach a Range as a Worksheet - Send an email with an Excel Range as an attachment

Public Function AttachRangeToEmail()
    Dim AWEEmail As New AWE_Email
    Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Timecard")
    Dim AttachFileNm As String, HTML As String
    
    AttachFileNm = AWEEmail.RangetoNewWorkbook(ws.Range("A1", ws.Cells(ws.UsedRange.Rows.Count, 9)))
    
    HTML = "Hi<BR><BR>Attached are timesheets for the year"
    AWEEmail.CreateEmail ToStr:="Emp@Domain.com", CcStr:="", Subject:="Timesheets for the year", HTML:=HTML, _
                         FileAttachments:=AttachFileNm
    AWEEmail.KillTempFile (AttachFileNm)
End Function

Putting it altogether - Create an an email with a Pivot Chart, Pivot Table and an attachment.

Public Function PuttingItTogether()
    Dim AWEEmail As New AWE_Email
    Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Dashboard")
    Dim EmpNm As String: EmpNm = GetSelectedSlicerItems("Slicer_Employee_Name"): If EmpNm = "" Then EmpNm = "All"
    Dim sChrtPath As String, sHiddenAttach As String, sShowAttach As String, HTML As String
    
    HTML = "Hi " & EmpNm & ",<BR><BR>Below is a graph showing your revenue by month for the year...<BR><BR>"
    
    sChrtPath = AWEEmail.CopyChartToJPG(ws, "ChartEmpRev")
    sHiddenAttach = sChrtPath
    HTML = HTML & AWEEmail.ChartToHtml(ws, "ChartEmpRev", 125)
    
    HTML = HTML & "<BR><BR>Below is a PivotTable showing your revenue by month for the year...<BR>"

    HTML = HTML & AWEEmail.RangetoHTML(ws.PivotTables(1).TableRange1)
    HTML = HTML & "<p>Your hard work is appreciated.</p>"
    
    sShowAttach = AWEEmail.RangetoNewWorkbook(ws.Range("A1", ws.Cells(ws.UsedRange.Rows.Count, 9)))
    
    HTML = HTML & "<p>Though your revenue would never be emailed to you, I've attached everyone's revenue.</p>"
    
    HTML = HTML & "<p>By the way all data is ficticiouPs&#x1F600;</p>"
    
    Call AWEEmail.CreateEmail("Emp@Domain.com", "", "AllTogether - " & EmpNm, HTML, sHiddenAttach, sShowAttach)
End Function

Find and Read Emails

Find emails - use complex search criteria to find emails

Public Function FindEmails()
    Dim AWEEmail As New AWE_Email, Email As Variant
    
    '=========================================================================================================
    ' Find all emails located in the InBox and in Inbox\TestFolder, where the
    ' Subject contains "Test" and where the date is within the last year.
    '=========================================================================================================
    For Each Email In AWEEmail.FindEmails(olFolderInbox, ";TestFolder", Nothing, True, _
        AWEEmail.CreateSearchParam(Subject, CONTAINS, "Test"), _
        AWEEmail.CreateSearchParam(LastModDt, GTE, Format(Now - 365, "General Date")), _
        AWEEmail.CreateSearchParam(LastModDt, LTE, Format(Now, "General Date")))
        
        Debug.Print Email.Subject & "; IsEmailSent:" & AWEEmail.IsEmailSent(Email) & "; EmailDate:" & AWEEmail.EmailDate(Email)

        '--- Business Logic Here ---
    Next Email
End Function

Use fuction AWE_Email::CreateSearchParam (SearchType, OperatorType, SrchForStr As String) to create the parameters for FindEmails SearchParams.

SearchType - Possible search type (intelliSense display) values are:

DisplayTo - Display sent to
CCs - CCs on the email
BCCs - Blind CCs's (sent emails only)
LastModDt - Date the email was last modified
ActualFrom - Actual message sender
DisplayFrom - Email sender (could by alias)
HasAttach - True if attachment else false
AttachFlNm - the name of attachment
Priority - Urgent=-1; Normal=0; Non-Urgent=1
SenderEmail - Sender email address, "rl@ex.com"
SenderName - Sender email name, "Ralph Lie"
Subject - Email subject
Body - Email body

OperatorType - Possible search oerator (intelliSense display) values are:

EQ: = SearchVal
LT: < SearchVal
LTE: <= SearchVal
GT: > SearchVal
GTE: >= SearchVal
BEGINSWITH: Like SearchVal%
CONTAINS: Like %SearchVal%

SrchForStr - The string to search for

Search your inbox and sent folders for the last conversation that has not been responded to. Note, you will need to create a EmailDict object that is passed between FindEmails call (see below)...

Public Function RcvdEmailsNeedingReply()
    Dim AWEEmail As New AWE_Email, Email As Variant, EmailDict As Object
    Dim LastConvOnly As Boolean: LastConvOnly = True
    
    '=========================================================================================================
    ' Find the last email conversation from emails located in the InBox, Inbox\TestFolder, or SentMail,
    ' where the Body contains Mike or Michael that were sent or received in the last month.
    '=========================================================================================================
    Call AWEEmail.FindEmails(olFolderInbox, ";TestFolder", EmailDict, LastConvOnly, _
        AWEEmail.CreateSearchParam(body, CONTAINS, "Mike|Michael"), _
        AWEEmail.CreateSearchParam(DateReceived, GTE, Format(Now - 30, "General Date")))
        
    For Each Email In AWEEmail.FindEmails(olFolderSentMail, "", EmailDict, LastConvOnly, _
        AWEEmail.CreateSearchParam(body, CONTAINS, "Mike|Michael"), _
        AWEEmail.CreateSearchParam(DateSent, GTE, Format(Now - 30, "General Date")))
        
        '--- open emails I've received but have not responded to ---
        If AWEEmail.IsEmailSent(Email) = False Then
            Email.Display
        End If
    Next Email
End Function

Public Function SentEmailsWaitingForReply()
    Dim AWEEmail As New AWE_Email, Email As Variant, EmailDict As Object
    Dim LastConvOnly As Boolean: LastConvOnly = True
    
    '=========================================================================================================
    ' Find the last email conversation from emails located in the InBox, Inbox\TestFolder, or SentMail,
    ' that were sent or received in the last month.
    '=========================================================================================================
    Call AWEEmail.FindEmails(olFolderInbox, ";TestFolder", EmailDict, LastConvOnly, _
        AWEEmail.CreateSearchParam(DateReceived, GTE, Format(Now - 30, "General Date")))
        
    For Each Email In AWEEmail.FindEmails(olFolderSentMail, "", EmailDict, LastConvOnly, _
        AWEEmail.CreateSearchParam(DateSent, GTE, Format(Now - 30, "General Date")))
        
        '--- Open emails that I've sent but have not received a response ---
        If AWEEmail.IsEmailSent(Email) = True Then
            '--- Do not open emails containing the words "Thank you for completing" ---
            If AWEEmail.FindPattern(Email.body, "Thank you for completing") = "" Then
                Email.Display
            End If
        End If
    Next Email
End Function

Read and Find Strings in Emails - use search patterns to locate content within emails

Public Function ReadEmails()
    Dim AWEEmail As New AWE_Email, vEmail As Variant, vRecip As Variant, var As Variant
    Dim sFoundStr As String, vProp As Variant
    
    '--- Find all emails with "Find String" anywhere in the Subject and sent in the last year ---
    For Each vEmail In AWEEmail.FindEmails(olFolderInbox, " ;TestFolder", Nothing, True, _
        AWEEmail.CreateSearchParam(Subject, CONTAINS, "Test"), _
        AWEEmail.CreateSearchParam(LastModDt, GTE, Format(Now - 365, "General Date")))
        
        '--- Subject ---
        Debug.Print "Subject: " & vEmail.Subject
        
        '--- Sender ---
        Debug.Print "Sender: " & vEmail.Sender
        
        '--- Received Time ---
        Debug.Print "Received Time: " & vEmail.ReceivedTime
        
        '--- Sent to ---
        For Each vRecip In AWEEmail.Recips(vEmail, olTo)
            Debug.Print "Sent To: " & vRecip(0) & ", EmailAddr: "; vRecip(1)
        Next
        
        '--- CC'd ---
        For Each vRecip In AWEEmail.Recips(vEmail, olCC)
            Debug.Print "CC'd: " & vRecip(0) & ", EmailAddr: "; vRecip(1)
        Next
        
        '--- Attachments ---
        Debug.Print "Attach Count: " & vEmail.attachments.Count
        For Each var In vEmail.attachments
            Debug.Print "Attach Name: " & var.Filename
        Next var
        
        '--- Saluation ---
        Debug.Print "Salutation: " & AWEEmail.FindPattern(vEmail.body, "(Hi|Hello|Dear)(.*?),")
        
        '--- Phone Number ---
        Debug.Print "Phone: " & AWEEmail.FindPattern(vEmail.body, _
            "\(?\b[2-9][0-9]{2}\)?[-. ]?[2-9][0-9]{2}[-. ]?[0-9]{4}\b")

        '--- Zip Code ---
        Debug.Print "Zip: " & AWEEmail.FindPattern(vEmail.body, "\b[0-9]{5}(?:-[0-9]{4})?\b")
        
        '--- Web https|ftp|file ---
        Debug.Print "Web https|ftp|file: " & AWEEmail.FindPattern(vEmail.body, _
            "\b(https?|ftp|file)://[-A-Z0-9+&@#/%?=~_|$!:,.;]*[A-Z0-9+&@#/%=~_|$]")
        
        '--- Web Site ---
        Debug.Print "Web Site: " & AWEEmail.FindPattern(vEmail.body, _
            "\b(?:(?:https?|ftp|file)://|www\.|ftp\.)[-A-Z0-9+&@#/%=~_|$?!:,.]*[A-Z0-9+&@#/%=~_|$]")
        
        '--- Email ---
        Debug.Print "Email: " & AWEEmail.FindPattern(vEmail.body, _
            "\(?\b[2-9][0-9]{2}\)?[-. ]?[2-9][0-9]{2}[-. ]?[0-9]{4}\b")
        
        '--- Specific Pattern ---
        Debug.Print "Pattern ""E-#####.##"":" & AWEEmail.FindPattern(vEmail.body, "E-\d{5}\.\d{2}")
        
        Debug.Print "=== END OF EMAIL ==="
    Next vEmail
End Function

Get Contacts

Find Outlook Contacts - Use MS Outlook to find and retrieve Outlook Contacts

Public Function GetOutlookContact()
    Dim AWEEmail As New AWE_Email
    Dim oContact As Object
    '----------------------------------------------------------------
    '--- Pass a unique identifier (not name) to GetOutlookContact ---
    '--- i.e. Phone number, email address, employee id...         ---
    '----------------------------------------------------------------
    Set oContact = AWEEmail.GetOutlookContact("UniqueContactName")
    If Not oContact Is Nothing Then
        Debug.Print oContact.FullName & " - " & oContact.Email1Address
    End If
End Function

Find Exchange Contacts - Use MS Exchange to find and retrieve contacts from the GAL (Global Address List)

Public Function GetExchangeContact()
    Dim AWEEmail As New AWE_Email
    Dim oContact As Object
    '---------------------------------------------------------------
    '--- Pass a unique identifier (not name) to GetChangeUser ------
    '--- i.e. Phone number, email address, employee id...     ------
    '---------------------------------------------------------------
    Set oContact = AWEEmail.GetExchangeUser("EmpId")
    If Not oContact Is Nothing Then
        Debug.Print oContact.name & " - " & oContact.PrimarySmtpAddress
    End If
End Function

Download Example Workbook

See the following modules in the download for examples:

CreateEmails - Creating a simple email, pivot chart and table, and attach a Worksheet/Workbook.
GetContacts - Get contacts from MS Outlook or Exchange
ReadEmails - Search for and iterate through emails. Search for strings within found emails.
SaveEmailAttach - Save an email or an email attachment to the local drive.