'////////////////////////////////////////////////////////////////////////////'
'/ ExtractAttachments.bas                                                   /'
'/ by Rafael Vuijk (aka Dark Fader)                                         /'
'////////////////////////////////////////////////////////////////////////////'
' This macro saves email attachments to a specific folder
' and removes them from the email.
' Use macro editor in Outlook (VBA scripting)
' Tip: you can create a macro button
'
' History:
'   v1.00
'       initial version. checks duplicate filename and then size.
'   v1.01
'       processes subfolders

'////////////////////////////////////////////////////////////////////////////'
'/ Options                                                                  /'
'////////////////////////////////////////////////////////////////////////////'
Option Explicit

'////////////////////////////////////////////////////////////////////////////'
'/ Constants                                                                /'
'////////////////////////////////////////////////////////////////////////////'
Const destDirectoryPrefix = "/images"
Const inboxSubFolder = "images"
Const tempFile = "/attachment.tmp"

'////////////////////////////////////////////////////////////////////////////'
'/ DoExtractAttachmentsFolder                                               /'
'////////////////////////////////////////////////////////////////////////////'
Public Sub DoExtractAttachmentsFolder(f As mapiFolder)
    'check directory
    Dim destDirectory As String
    destDirectory = destDirectoryPrefix + "/" + f.Name
    If (Dir(destDirectory, vbDirectory) = "") Then MkDir destDirectory
    
    'process all mail items
    Dim i As MailItem
    For Each i In f.Items
        'save all attachments
        Dim a As Attachment
        For Each a In i.Attachments
            'already exist?
            If (Dir(destDirectory + "/" + a.filename) <> "") Then
                'compare filesize
                a.SaveAsFile tempFile
                If (FileLen(tempFile) <> FileLen(destDirectory + "/" + a.filename)) Then
                    'save with other name
                    Dim newFilename As String
                    Do
                        newFilename = Format(Int(1000 * Rnd())) + "." + a.filename
                    Loop While (Dir(destDirectory + "/" + newFilename) <> "")
                    a.SaveAsFile (destDirectory + "/" + newFilename)
                End If
                Kill tempFile
            Else
                a.SaveAsFile (destDirectory + "/" + a.filename)
            End If
        Next
        
        'delete all attachments
        While (i.Attachments.Count > 0)
            i.Attachments.Remove 1
        Wend
        
        'save mail item without attachments
        i.Save
    Next

    'process subfolder
    Dim sf As mapiFolder
    For Each sf In f.Folders
        DoExtractAttachmentsFolder sf
    Next
End Sub


'////////////////////////////////////////////////////////////////////////////'
'/ DoExtractAttachments                                                     /'
'////////////////////////////////////////////////////////////////////////////'
Public Sub DoExtractAttachments()
    Randomize Timer

    'destination directory
    If (Dir(destDirectoryPrefix, vbDirectory) = "") Then MkDir destDirectoryPrefix

    'open MAPI folder
    Dim inbox, f As mapiFolder
    Set inbox = Outlook.Session.GetDefaultFolder(olFolderInbox)
    Set f = inbox.Folders(inboxSubFolder)
    DoExtractAttachmentsFolder f
End Sub