Solved: Saving attachments for Inbox, etc.

[Paul_Hossler]

Doing my father-in-law a favor.

He has been saving 100's of emails in 'Inbox' and other folders because they have photos, etc. Now he'd like to transfer them to 'My Photos'

Some might be attachments and some might be in the message body; mixed bag

Is there an manual way to do the transfer en mass, instead of one at a time, OR can some one give a me a link or a macro to do them all at once, or at least on folder at a time?

It'd make me a hero and I'd gain a lot of brownie points :thumb

Thanks

Paul

[Paul_Hossler]

Thanks to Mr. Google and the things I've learned here, I was able to get something that seems to work. It's not a VBS script, but an OL macro

If anyone is interested .....



Option Explicit
Const cTITLE As String = "Save All Attachments"
Dim objFSO As Object

'extract attachments from Inbox and second level of folders, optional stripping
'from the message.
'extracted attachments are put in My Documents\Extracted Items\
'extracted file name is prefixes with folder name
'if the file already exists at least in name, a sequence number is added
'e.g. 2 Item in Inbox\Sales each have attachment Forecast.doc
' Sales_Forcast.doc and Sales_Forcast_01.doc
Sub SaveAllAttachments()

Const MY_DOCUMENTS As Long = &H5

Dim olFldr As Outlook.MAPIFolder, olFldr2 As Outlook.MAPIFolder
Dim objShell As Object, objMyDocs As Object, objMyDocsItem As Object
Dim sMyDocs As String, sExtractFolder As String

Dim bStrip As Boolean

'set FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")


'get My Documents folder
Set objShell = CreateObject("Shell.Application")
Set objMyDocs = objShell.NameSpace(MY_DOCUMENTS)
Set objMyDocsItem = objMyDocs.Self
sExtractFolder = objMyDocsItem.Path & "\Extracted Items"

'ask user if this isreally what they want to do
If MsgBox("This will save all Inbox and sub-folder attachments in " & _
sExtractFolder, vbQuestion + vbOKCancel + vbDefaultButton1, cTITLE) _
= vbCancel Then Exit Sub

bStrip = MsgBox("Do you want to strip the attachment from the message after extracting?", _
vbQuestion + vbYesNo + vbDefaultButton2, cTITLE) = vbYes



'check if folder exists, if not then create it, if folder cannot be created, exit
If Not objFSO.FolderExists(sExtractFolder) Then
On Error GoTo CannotCreateFolder
objFSO.createfolder (sExtractFolder)
On Error GoTo 0
End If

' get default Inbox items collection
Set olFldr = GetDefaultFolder(olFolderInbox)

'do the Inbox
Call DoAttachmentsInFolder(sExtractFolder, olFldr, bStrip)

'and each subfolder. Only go down 2 levels
For Each olFldr2 In olFldr.Folders
Call DoAttachmentsInFolder(sExtractFolder, olFldr2, bStrip)
Next olFldr2

'we're done
If bStrip Then
Call MsgBox("Finished extracting all Inbox and sub-folder attachments into " & sExtractFolder & _
" and then stripping the attachments from the messages", _
vbInformation + vbOKOnly, cTITLE)
Else
Call MsgBox("Finished extracting all Inbox and sub-folder attachments into " & sExtractFolder, _
vbInformation + vbOKOnly, cTITLE)
End If

Exit Sub
CannotCreateFolder:
Call MsgBox("Cannot create " & sExtractFolder, vbCritical + vbOKOnly, cTITLE)
Exit Sub

End Sub
Sub DoAttachmentsInFolder(SaveFolder As String, olFolder As Outlook.MAPIFolder, Optional StripAttachments As Boolean = False)

'create subset of items collection
Dim olItems As Outlook.Items, olNewItems As Outlook.Items

Dim olMessage As Outlook.MailItem
Dim olMessageAttachments As Outlook.Attachments
Dim i As Long, iSeq As Long

Dim sSaveName As String


Set olNewItems = olFolder.Items.Restrict("[Attachment] > 0")

' loop through items subset, save all attachments to disk folder
For Each olMessage In olNewItems
Set olMessageAttachments = olMessage.Attachments
For i = olMessageAttachments.Count To 1 Step -1

sSaveName = olFolder.Name & "_" & olMessageAttachments.Item(i).FileName

iSeq = 0
While objFSO.fileexists(SaveFolder & "\" & sSaveName)
iSeq = iSeq + 1

sSaveName = olFolder.Name & "_" & _
objFSO.getbasename(olMessageAttachments.Item(i).FileName) & "_" & _
Format(iSeq, "00") & _
"." & objFSO.getextensionname(olMessageAttachments.Item(i).FileName)
Wend

olMessageAttachments.Item(i).SaveAsFile SaveFolder & "\" & sSaveName

' delete attachment (optional)
If StripAttachments Then olMessageAttachments.Item(i).Delete

Next i

Next olMessage
End Sub

' returns MAPIFolder object from default folder list to calling program
Private Function GetDefaultFolder(outlookFolder As OlDefaultFolders) As Outlook.MAPIFolder
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")

Set GetDefaultFolder = olNS.GetDefaultFolder(outlookFolder)
End Function



Paul