Save all attachments from selected folder, continued

In Save all attachments from selected folder, I posted a method for scrubbing an Outlook mail folder of file attachments in order to reduce your network footprint (or make your PST file smaller).

A couple of commenters asked if there's a way to make sure the filename is unique. There are two ways (I know of) to accomplish this goal, and we'll explore both in this post.

1. Check the folder for an existing file with the same name. If the filename exists, start a Do Loop and add an incrementing number after the filename. Keep using the Dir function to check the newly created filename. Once Dir returns "", you have your filename. This is the hard way.
2. Parse the filename and insert MailItem.ReceivedTime before the file extension. This is the easier way.

Method 1 – Loop through folder

Here's the original code, with a loop added to check the hard drive folder for an existing file with the same name. The loop keeps changing the filename with an incrementing number, until the Dir function returns an empty String. I've also modified the second parameter to default to False.

Sub SaveAllAttachments(ByVal folderName As String, Optional ByVal StripAttachments As Boolean = False)
' save all attachments from all emails in a folder to a folder on the hard disk
' optionally delete the attachments as well
' by Jimmy Pena, http://www.jpsoftwaretech.com 8/12/2009

Dim olfldr As Outlook.MAPIFolder
Dim itms As Outlook.Items
Dim newItems As Outlook.Items
Dim Msg As Outlook.MailItem
Dim MsgAttach As Outlook.attachments
Dim attachmentNumber As Integer
Dim i As Long
Dim newFilename As String

On Error GoTo ErrorHandler

' check if folder exists, if not then create it
' if folder cannot be created, exit
If Not FolderExists(folderName) Then
  MkDir folderName
End If

' check that folderName ends with "\"
If Right$(folderName, 1) <> "\" Then
  folderName = folderName & "\"
End If

' get default Inbox items collection
Set olfldr = GetDefaultFolder(olFolderInbox)
Set itms = olfldr.Items

' sort items by whether they have an attachment
itms.Sort "[Attachment]", False

' create subset of items collection
Set newItems = itms.Restrict("[Attachment] > 0")

' loop through items subset, save all attachments to disk folder
For Each Msg In newItems
  Set MsgAttach = Msg.attachments
  For attachmentNumber = MsgAttach.Count To 1 Step -1

    newFilename = MsgAttach.item(attachmentNumber).fileName

    If Dir(folderName & newFilename, vbDirectory) <> "" Then
        ' file already exists
      i = 0
      Do
        i = i + 1
        newFilename = ExtractFileName(MsgAttach.item(attachmentNumber).fileName) & i & _
            GetFileType(MsgAttach.item(attachmentNumber).fileName)
      Loop Until Dir(folderName & newFilename, vbDirectory) = ""
    End If

    MsgAttach.item(attachmentNumber).SaveAsFile _
      folderName & newFilename

    ' delete attachment (optional)
    If StripAttachments Then
      MsgAttach.item(attachmentNumber).Delete
    End If
  Next attachmentNumber
Next Msg

ProgramExit:
  Exit Sub
ErrorHandler:
  MsgBox Err.Number & " - " & Err.Description
  Resume ProgramExit
End Sub

Private Function GetDefaultFolder(outlookFolder As OlDefaultFolders) As Outlook.MAPIFolder
' returns MAPIFolder object from default folder list to calling program

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

Function FolderExists(ByVal strPath As String) As Boolean
' from http://allenbrowne.com
    On Error Resume Next
    FolderExists = ((GetAttr(strPath) And vbDirectory) = vbDirectory)
End Function

Function ExtractFileName(fileName As String) As String
' extract filename portion of filename, no extension
Dim fileN As String

fileN = Right(fileName, Len(fileName) - InStrRev(fileName, "\"))
fileN = Replace(fileN, GetFileType(fileN), "")

ExtractFileName = fileN

End Function

Function GetFileType(fileName As String) As String
' get file extension

GetFileType = Mid$(fileName, InStrRev(fileName, "."), Len(fileName))

End Function

Method 2 – Append received time

This method relies on the fact that mail items are rarely received at the exact same time. If you need to be absolutely sure that you aren't overwriting a file, you're better off using the above technique. The chances are extremely small, but if the file exists you'll get an error (or worse, the file will be overwritten with no warning).

This code is identical to the one above, with the only difference being the removal of the Do loop, and the use of MailItem.ReceivedTime instead of the incrementing Long variable. Otherwise they're almost the same code.

Sub SaveAllAttachments(ByVal folderName As String, Optional ByVal StripAttachments As Boolean = False)
' save all attachments from all emails in a folder to a folder on the hard disk
' optionally delete the attachments as well
' by Jimmy Pena, http://www.jpsoftwaretech.com 4/28/2009

Dim olFldr As Outlook.MAPIFolder
Dim itms As Outlook.Items
Dim newItems As Outlook.Items
Dim Msg As Outlook.MailItem
Dim MsgAttach As Outlook.attachments
Dim attachmentNumber As Integer
Dim newFilename As String

On Error GoTo ErrorHandler

' check if folder exists, if not then create it
' if folder cannot be created, exit
If Not FolderExists(folderName) Then
  MkDir folderName
End If

' check that folderName ends with "\"
If Right$(folderName, 1) <> "\" Then
  folderName = folderName & "\"
End If

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

' sort items by whether they have an attachment
itms.Sort "[Attachment]", False

' create subset of items collection
Set newItems = itms.Restrict("[Attachment] > 0")

' loop through items subset, save all attachments to disk folder
For Each Msg In newItems
  Set MsgAttach = Msg.attachments
  For attachmentNumber = MsgAttach.Count To 1 Step -1

    newFilename = MsgAttach.item(attachmentNumber).fileName

    If Dir(folderName & newFilename, vbDirectory) <> "" Then
        ' file already exists
        newFilename = ExtractFileName(MsgAttach.item(attachmentNumber).fileName) & " " & Format(Msg.ReceivedTime, "MMDDYYYYHHMMSS") & _
            GetFileType(MsgAttach.item(attachmentNumber).fileName)
    End If

    MsgAttach.item(attachmentNumber).SaveAsFile _
      folderName & newFilename

    ' delete attachment (optional)
    If StripAttachments Then
      MsgAttach.item(attachmentNumber).Delete
    End If
  Next attachmentNumber
Next Msg

ProgramExit:
  Exit Sub
ErrorHandler:
  MsgBox Err.Number & " - " & Err.Description
  Resume ProgramExit
End Sub

Private Function GetDefaultFolder(outlookFolder As OlDefaultFolders) As Outlook.MAPIFolder
' returns MAPIFolder object from default folder list to calling program

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

Function FolderExists(ByVal strPath As String) As Boolean
' from http://allenbrowne.com
    On Error Resume Next
    FolderExists = ((GetAttr(strPath) And vbDirectory) = vbDirectory)
End Function

Function ExtractFileName(fileName As String) As String
' extract filename portion of filename, no extension
Dim fileN As String

fileN = Right(fileName, Len(fileName) - InStrRev(fileName, "\"))
fileN = Replace(fileN, GetFileType(fileN), "")

ExtractFileName = fileN

End Function

Function GetFileType(fileName As String) As String
' get file extension
' assumes there are no periods in filename
' (other than the one between the filename and extension)
GetFileType = Mid$(fileName, InStrRev(fileName, "."), Len(fileName))

End Function