Sub GetPassAndSave()
Dim myOlExp As Outlook.Explorer
Dim myOlSel As Outlook.Selection
Dim objItem As Object
Dim ns As NameSpace
Dim InboxItems As MAPIFolder
Dim Item As MailItem
Dim Atmt As Attachment
Dim x As Integer
On Error Resume Next
Set xlApp = CreateObject("Excel.application")
xlApp.Visible = False
Set strSaveAsFilename = xlApp.FileDialog(msoFileDialogFolderPicker)
With strSaveAsFilename
       .Show
       k = .SelectedItems(1)
End With
If IsEmpty(k) Then Exit Sub
k = IIf(Right(k, 1) = "\", k, k & "\")
xlApp.Quit
Set xlApp = Nothing
Set ns = GetNamespace("MAPI")
Set myOlExp = Application.ActiveExplorer
Set myOlSel = myOlExp.Selection
    For x = 1 To myOlSel.Count
        For Each Atmt In myOlSel.Item(x).Attachments
            Atmt.SaveAsFile k & Atmt.FileName
        Next Atmt
    Next x
End Sub

Sub GetPassAndSave1(Item As Outlook.MailItem)
k = "D:\Mails"
dateOfMailItem = Format(Item.CreationTime, "yyyymmddhhmmss;@")
oBody = Item.Body
ChDir k
sExpFileName = dateOfMailItem & ".txt"
f = FreeFile
Open sExpFileName For Output Access Write As #f
Print #f, oBody
Close #f
End Sub