Blatantly stolen:


[vba]
Option Explicit
Private Const MAX_PATH = 255

Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

'_____________________

Public Function SaveAttachments(Optional PathName As String) As Boolean

Dim oOutlook As Outlook.Application
Dim oNs As Outlook.NameSpace
Dim oFldr As Outlook.MAPIFolder
Dim oMessage As Object
Dim sPathName As String
Dim oAttachment As Outlook.Attachment
Dim iCtr As Integer
Dim iAttachCnt As Integer

On Error GoTo ErrHandler

If PathName = "" Then
sPathName = GetTempDir
Else
sPathName = PathName
End If

If Right(sPathName, 1) <> "\" Then sPathName = sPathName & "\"
If Dir(sPathName, vbDirectory) = "" Then Exit Function

Set oOutlook = New Outlook.Application
Set oNs = oOutlook.GetNamespace("MAPI")
Set oFldr = oNs.GetDefaultFolder(olFolderInbox)
For Each oMessage In oFldr.Items
With oMessage.Attachments
iAttachCnt = .Count
If iAttachCnt > 0 Then
For iCtr = 1 To iAttachCnt
.Item(iCtr).SaveAsFile sPathName _
& .Item(iCtr).FileName
Next iCtr
End If
End With
DoEvents

Next oMessage
SaveAttachments = True

ErrHandler:
Set oMessage = Nothing
Set oFldr = Nothing
Set oNs = Nothing
Set oOutlook = Nothing
End Function
'______________

Public Function GetTempDir() As String
Dim sRet As String, lngLen As Long
'create buffer
sRet = String(MAX_PATH, 0)
lngLen = GetTempPath(MAX_PATH, sRet)
If lngLen = 0 Then Err.Raise Err.LastDllError
GetTempDir = Left$(sRet, lngLen)
End Function
[/vba]

I hope YOU know what to do with it.