I have posted the bulk of the following here previously, but to address your additional requirement, you would have to save the attached message and then extract the attachments from it. Use the parts of it that you require.
Option Explicit
Sub ProcessSelectedMessage()
'An Outlook macro by Graham Mayor
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
SaveAttachments olMsg
lbl_Exit:
Exit Sub
End Sub
Private Sub SaveAttachments(olItem As MailItem)
'Graham Mayor - http://www.gmayor.com - Last updated - 26 Jun 2017
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim i As Long, j As Long
Dim olMsg As MailItem
Const strSaveFldr As String = "D:\Path\Attachments\" - the folder to save the attachments
On Error GoTo lbl_Exit
If olItem.Attachments.Count > 0 Then
For j = 1 To olItem.Attachments.Count
Set olAttach = olItem.Attachments(j)
If Not olAttach.fileName Like "image*.*"
strFname = olAttach.fileName
strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
Select Case LCase(strExt)
Case "msg" 'The attachment is a message so save it
olAttach.SaveAsFile Environ("TEMP") & Chr(92) & strFname
'then open it
Set olMsg = Session.OpenSharedItem(Environ("TEMP") & Chr(92) & strFname)
'and if it has attachments save them
If olMsg.Attachments.Count > 0 Then
For i = 1 To olMsg.Attachments.Count
If Not olMsg.Attachments(i).fileName Like "image*.*" Then
strFname = olMsg.Attachments(i).fileName
strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
strFname = FileNameUnique(strSaveFldr, strFname, strExt)
olMsg.Attachments(i).SaveAsFile strSaveFldr & strFname
End If
Next i
End If
Case Else
strFname = FileNameUnique(strSaveFldr, strFname, strExt)
olAttach.SaveAsFile strSaveFldr & strFname
End Select
End If
Next j
End If
lbl_Exit:
Set olAttach = Nothing
Set olItem = Nothing
Set olMsg = Nothing
Exit Sub
End Sub
Private Function FileNameUnique(strPath As String, _
strFileName As String, _
strExtension As String) As String
'An Outlook macro by Graham Mayor
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName) - (Len(strExtension) + 1)
strFileName = Left(strFileName, lngName)
Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
Exit Function
End Function
Private Function FileExists(filespec) As Boolean
'An Outlook macro by Graham Mayor
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function