CODEWITHSUNDEEP
stringexcelvbaemailoutlook
Crosenb
Crosenb

Reputation: 1

Search outlook emails within a folder that contain start numbers/specific received date

I am looking to have a macro that will search through all messages in a folder and extract a partially unique number in each email. Example, I have an email that contains a number, 987654321 and another email that contains 987542132 both of these numbers have the first 3 didgets in common, '987'. How can i write in so it will search trough and extract all of those numbers from the message, but not the entire message? If I could place in specific date ranges for when the messages where recieved, that would be nice too.

Here is the current code I have, which when I select a folder in outlook, it will extract all the messages within that folder and export to a spreadsheet w/ the subject, received time and body. I just want those specific numbers though!

Sub ExportMessagesToExcel()
    Dim olkMsg As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        intRow As Integer, _
        intVersion As Integer, _
       strFilename As String
        strFilename = InputBox("Enter a filename and path to save the messages to.", "Export Messages to Excel")
    If strFilename <> "" Then
        intVersion = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add()
        Set excWks = excWkb.ActiveSheet
        'Write Excel Column Headers
        With excWks
            .Cells(1, 1) = "Subject"
            .Cells(1, 2) = "Received"
            .Cells(1, 3) = "Body"
        End With
        intRow = 2
        'Write messages to spreadsheet
        For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
            'Only export messages, not receipts or appointment requests, etc.
            If olkMsg.Class = olMail Then
                'Add a row for each field in the message you want to export
                excWks.Cells(intRow, 1) = olkMsg.Subject
                excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
                excWks.Cells(intRow, 3) = FindNum(olkMsg.Body, "2014", 14)                    intRow = intRow + 1
            End If
        Next
        Set olkMsg = Nothing
        excWkb.SaveAs strFilename
        excWkb.Close
    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    MsgBox "Completed.  A total of " & intRow - 2 & " messages were exported.", vbInformation + vbOKOnly, "Export messages to Excel"
End Sub

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function

Function FindNum(bodyText As String, lead As String, numDigits As Integer) As String Dim counter As Long Dim test As String Dim digits As String For counter = 1 To numDigits - Len(4) digits = digits & "10" Next counter For counter = 1 To Len(bodyText) - numDigits test = Mid(bodyText, counter, numDigits) If test Like lead & digits Then FindNum = test Exit For End If Next counter End Function

Upvotes: 0

Views: 1001

Answers (1)

MattB
MattB

Reputation: 2241

This will find and return a string of numeric only characters of a length you specify with a lead you specify from a longer string. Think of it as an InStr that uses a wildcard to only return a numeric value. I had to do something like this for a project once.

Function FindNum(bodyText As String, lead As String, numDigits As Integer) As String
Dim counter As Long
Dim test As String
Dim digits As String
For counter = 1 To numDigits - Len(lead)
    digits = digits & "#"
Next counter
For counter = 1 To Len(bodyText) - numDigits
    test = Mid(bodyText, counter, numDigits)
    If test Like lead & digits Then
        FindNum = test
        Exit For
    End If
Next counter
End Function

Upvotes: 1

Related Questions