Save / Extract Outlook Attachments from emails and save them to a Folder

I have been meaning to post this for a while.
Some VBA code to extract attachments from a folder in Outlook and save them.

You can choose the Outlook folder but it is hard coded to save the attachments to C:\Email Attachments\

Sub AttachDetach()

' *******************************************************************************

' Name - AttachDetach

' Description - Removes Attachements from an Outlook Folder and saves them to C:\Email Attachments\

' Date Changed - 10/03/2011 <-- Please keep this up to date

' Changed by - Dan Thomas  <-- Please keep this up to date

' *******************************************************************************

Dim ns As NameSpace

Dim Inbox As MAPIFolder

Dim item As Object

Dim Atmt As attachment

Dim filename As String

Dim i As Integer

Set ns = GetNamespace("MAPI")

Set Inbox = ns.PickFolder

i = 0

If Inbox.Items.Count = 0 Then

    MsgBox "There are no messages in the Inbox.", vbInformation, _

           "Nothing Found"

    Exit Sub

End If

  For Each item In Inbox.Items

          For Each Atmt In item.Attachments

       filename = "C:\Email Attachments\" & i & Atmt.filename

       Atmt.SaveAsFile filename

       i = i + 1

    Next Atmt

Next item

If i > 0 Then

    MsgBox "I found " & i & " attached files." _

       & vbCrLf & "I have saved them into the C:\Email Attachments folder." _

       & vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"

Else

    MsgBox "I didn't find any attached files in your mail.", vbInformation, _

    "Finished!"

End If

GetAttachments_exit:

   Set Atmt = Nothing

   Set item = Nothing

   Set ns = Nothing

End Sub