Save Outlook attachment using a cell value as the file name - excel

Question

I'm trying to save the Outlook attachment from a particular sub folder to a local path.
I'm able to save the file as is to the local path.
The requirement is to save the xl attachment using a cell value of ThisWorkbook as the file name.
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