Save outlook attachment using the filename from a cell value

Question

Im actually trying to save the outlook attachment from a particular sub folder to a local path. Im able to save the file as it is to the local path. However, the requirement is to save the xl attachment using the filename as given in an excel file ie cell value. I want the code to use the filename given in the cell value of ThisWorkbook.

Let me know if there is a way. Appreciate any support on this.

Sub ManualPunchAttachmentsExtract()
    Dim OlFolder As Outlook.MAPIFolder
    Dim OlMail As Object
    Dim OlApp As Outlook.Application
    Dim OlItems As Outlook.Items
    Dim Get_namespace As Outlook.Namespace
    Dim strFolder As String
    Dim i As Integer
    
    ThisWorkbook.Activate
    Sheets("MP File Save").Activate
    Range("H3").Activate
    
    Set OlApp = GetObject(, "Outlook.Application")
    
    If err.Number = 429 Then
        Set OlApp = CreateObject("Outlook.Application")
    End If
    
    strFolder = InputBox("Please Enter the Folder Path alongwith ' \ ' at the end", Path)
    
    'Set Get_namespace = OlApp.GetNamespace("MAPI")
    Set OlFolder = OlApp.GetNamespace("MAPI").Folders("shaikajaz.k@flex.com").Folders("Archive").Folders("Juarez").Folders("Manual Punch")
    Set OlItems = OlFolder.Items
    '.Restrict("[Unread]=true")
    
    For Each OlMail In OlItems
    
         If OlMail.UnRead = False Then
             
         Else
            ThisWorkbook.Activate
            Sheets("MP File Save").Activate
            ActiveCell.Value = OlMail.Subject
            ActiveCell.Offset(0, 1).Value = OlMail.ReceivedTime
            
            If OlMail.attachments.Count > 0 Then
                For i = 1 To OlMail.attachments.Count
                    OlMail.attachments.Item(i).SaveAsFile strFolder & "\" & OlMail.attachments.Item(i).FileName
                    OlMail.UnRead = False
                    ThisWorkbook.Activate
                    ActiveCell.Offset(1, 0).Select
                Next i
            
            Else
            
            End If
         
         End If
                
    Next
MsgBox ("Done")
End Sub

Answer 1

First of all, iterating over all items in an Outlook folder is not realy a good idea. Use the Find / FindNext or Restrict methods of the Items class instead. So, instead of the following code:

For Each OlMail In OlItems

     If OlMail.UnRead = False Then

Use this:

Private Sub FindAllUnreadEmails(folder As Outlook.MAPIFolder)

    Dim searchCriteria As String = "[UnRead] = true"
    Dim counter As Integer = 0
    Dim mail As Outlook._MailItem = Nothing
    Dim folderItems As Outlook.Items = Nothing
    Dim resultItem As Object = Nothing
   
        If (folder.UnReadItemCount > 0) Then
            
            folderItems = folder.Items
            resultItem = folderItems.Find(searchCriteria)
            While Not IsNothing(resultItem)
                If (TypeOf (resultItem) Is Outlook._MailItem) Then
                    counter += 1
                    mail = resultItem
                    Debug.Print("#" + counter.ToString() + _
                                          " - Subject: " + mail.Subject)
                End If
                resultItem = folderItems.FindNext()
            End While
            
        Else
            Debug.Print("There is no match in the " + _
                                   folder.Name + " folder.")
        End If
End Sub

Note, attached files can have the same file name. So, to uniquelly identify files I'd suggest introducing any IDs in the file name when attachments are saved to the disk.

Finally, to save the attached file with a workbook's content name you need to pass a cell value to the SaveAsFile method:

OlMail.attachments.Item(i).SaveAsFile strFolder & "\" & yourWorksheet.Range("B2").Value