Save attachments from emails saved on network location

[rachel06]

Hello,

I'm trying to edit a macro that was done by a colleague who is no longer with my company. Currently, this macro reads emails in a folder in Outlook (when a user runs the macro, they are prompted via a popup to select the folder in Outlook they want to read from), it saves the attachment from the email into a location specified in worksheet itself and reads and records information from the subject line into another location in Excel.

Anyway, there's a lot to this macro, but I believe the bit I need to alter is in the first part.

I would like to edit this to read emails that have been saved on a network location (instead right from Outlook) but essentially do the same thing. All I really need it to do is save the attachments from the email saved on the network drive into a specified location, so if there's an easier way to just do that, I can deal with not having the rest of it. Unfortunately, retention rules kill these emails fairly quickly so most of the emails are no longer available in Outlook.

Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim EMFolder As MAPIFolder
Dim OutlookMail, RTime As Variant
Dim AttFolder, AttName, EMSubject, EMBody As String
Dim CANum, AcctName As String
Dim i, CAStart As Integer

Sub ReadEMail()
'
' Prompts user for Outlook folder name
' Reads data on each email within a date range
' Saves attachments to designated folder and creates hyperlinks
'
 
    BegDat = Range("Begin_Date").Value
    EndDat = Range("End_Date").Value + 1
    AttFolder = Range("DestFolder")
    If Right(AttFolder, 1) <> "\" Then AttFolder = AttFolder & "\"
    
    Sheets("Output").Select
' Clear text and checkboxes from the previous run
    Range("A2:M2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    ActiveSheet.CheckBoxes.Delete
' Reset previously red-colored cells to automatic
    Cells.Select
    With Selection.Font
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
    End With
    Range("A1").Select

    Set OutlookApp = New Outlook.Application
    Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")

' Get user choice for target folder, exit if Cancel
    Set EMFolder = OutlookNamespace.PickFolder
    If EMFolder Is Nothing Then Exit Sub

    i = 1
On Error Resume Next
    For Each OutlookMail In EMFolder.Items
        RTime = OutlookMail.ReceivedTime
        If RTime >= BegDat And RTime <= EndDat Then
            EMSubject = OutlookMail.Subject
            Range("EMDate").Offset(i, 0).Value = OutlookMail.ReceivedTime
        
' 019* carrier-account number
            If EMSubject Like "*019*" Then
                CAStart = InStr(1, EMSubject, "019", 1)
                Call WriteInfo
' 024* carrier account number
            ElseIf EMSubject Like "*024*" Then
                CAStart = InStr(1, EMSubject, "024", 1)
                Call WriteInfo
' Other carrier account or other email - print warning in red
            Else
                Range("CarrAcct").Offset(i, 0).Font.Color = vbRed
                Range("CarrAcct").Offset(i, 0).Value = "Number Not Found"
                Range("ClientName").Offset(i, 0).Font.Color = vbRed
                Range("ClientName").Offset(i, 0).Value = EMSubject
            End If
        
            i = i + 1
        
        End If
    Next OutlookMail

    Set EMFolder = Nothing
    Set OutlookNamespace = Nothing
    Set OutlookApp = Nothing

End Sub

Sub WriteInfo()
' Write info to Output tab

    On Error Resume Next
    AttName = OutlookMail.Attachments.Item(1).FileName
    AttFile = AttFolder & AttName
    CANum = Mid(EMSubject, CAStart, 9)
    AcctName = Left(EMSubject, CAStart - 1)
    EMBody = OutlookMail.Body
    
    Range("CarrAcct").Offset(i, 0).Value = PayeeID(CANum)
    Range("C_A").Offset(i, 0).Value = CANum
    Range("ClientName").Offset(i, 0).Value = AcctName
    
    If EMBody Like "*(Renewal Client)*" Then
        Range("ClientType").Offset(i, 0).Value = "Renewal"
    ElseIf EMBody Like "*(New Client)*" Then
        Range("ClientType").Offset(i, 0).Value = "New"
    Else
        Range("ClientType").Offset(i, 0).Value = "?"
    End If
    
    Range("EffDate").Offset(i, 0).Value = EffectDt(EMSubject)
    
' Write file path and make it a hyperlink
    Range("EMAttach").Offset(i, 0).Value = AttFile
    Range("EMAttach").Offset(i, 0).Hyperlinks.Add Anchor:=Range("EMAttach").Offset(i, 0), _
        Address:=Range("EMAttach").Offset(i, 0), TextToDisplay:=AttFile
' Save the attachment
    OutlookMail.Attachments.Item(1).SaveAsFile AttFile

End Sub

Function PayeeID(CarrAcct)
' Create REB* Payee ID from C-A number

    CarrNum = Left(CarrAcct, 4)
    AcctNum = Right(CarrAcct, 4)
    PayeeID = "REB" & CarrNum & AcctNum

End Function
Function EffectDt(EMSubject)

    If EMSubject Like "*-1-20*" Then
        DtStart = InStr(1, EMSubject, "-1-20")
        EffectDt = CDate(Mid(EMSubject, DtStart - 2, 9))
    Else
        EffectDt = "XX/X/XXXX"
    End If
End Function

Any help is much appreciated!