Overview of the process that we do.

Customer applies for a product online, the details/data comes to the Manager as mails. he then saves those mails as .txt to a common drive, from which we take those cases and proceeds with our work… there would be above 1500cases a day. and its very tough to keep saving each mail that comes in outlook, it takes very long time. while saving a mail we mention the number as well, the file name would be for example:- 1.pepsi,2.pepsi,3.coke….. like wise for each file we add the seriel number to identify the number of cases that comes a day…

Kindly help me in creating a macro from the outlook to solve this issue, it would be a great help if i could get this done…

THANKS IN ADVANCE..

I can’t download the script, is there any posibility to get it?.

thanks.

Cheers again

Mike

* * * *
‘Loop thru each selected item in the Inbox
For cnt = 1 To Sel.Count
‘If the email message has attachments …
If Sel.Item(cnt).Attachments.Count > 0 Then
MsgTotal = MsgTotal + 1
‘For each attachment on the message …
For AttachmentCnt = 1 To Sel.Item(cnt).Attachments.Count
‘Get the attachment
Dim att As Attachment
Set att = Sel.Item(cnt).Attachments.Item(AttachmentCnt)
If MsgTotal < 10 Then
outputFile = Left(att.filename, 4) + "00" + CStr(MsgTotal) + ".pdf"
ElseIf MsgTotal < 100 Then
outputFile = Left(att.filename, 4) + "0" + CStr(MsgTotal) + ".pdf"
Else
outputFile = Left(att.filename, 4) + CStr(MsgTotal) + ".pdf"
End If
att.SaveAsFile (outputDir + outputFile)
AttTotal = AttTotal + 1
Next
End If
Next
* * * *

Again, it works for me in that it extracts all the attachments and appends a number to the filename but for some reason (with this code and with the original code) it crashes after 100 messages/attachments. Still haven't figured that part out yet, tho'.

Cheers,
Jeremy

I have attached the code below but am not sure how to format it correctly (so apologies for formatting of code).

Option Explicit

' Using code from:
' http://arcanecode.com/2007/01/03/enhancing-the-save-attachments-outlook-macro/
'       http://arcanecode.files.wordpress.com/2007/01/saveattachments2.txt
' http://www.rondebruin.nl/mail/folder2/saveatt.htm
' http://www.vbaexpress.com/kb/getarticle.php?kb_id=767


Public Sub SaveAttachments()

    ' Note, this assumes you are in the a folder with e-mail messages when you run it.
    ' It does not have to be the inbox, simply any folder with e-mail messages
    Dim attachmentCount As Integer
    Dim messageCount As Integer


    Dim outlookApp As New Outlook.Application
    Dim folder As Outlook.Explorer
    Set folder = outlookApp.ActiveExplorer


    Dim outputDir As String
    outputDir = GetOutputDirectory()
    If outputDir = "" Then
        MsgBox "You must pick a directory to save your files to. Exiting SaveAttachments.", vbCritical, "SaveAttachments"
        Exit Sub
    End If


    ' Loop thru each selected item in the inbox (100 at a time)
    Const stepSize = 100
    Dim currentIndex As Integer
    currentIndex = 1
    Do While currentIndex < folder.Selection.Count
        Call ProcessChunk(folder.Selection, currentIndex, currentIndex + stepSize - 1, outputDir, attachmentCount, messageCount)
        currentIndex = currentIndex + stepSize
    Loop

    ' Clean up
    Set folder = Nothing
    Set outlookApp = Nothing

    ' Let user know we are done
    Dim doneMsg As String
    doneMsg = "Completed saving " + Format$(attachmentCount, "#,0") + " attachments in " + Format$(messageCount, "#,0") + " Messages."
    MsgBox doneMsg, vbOKOnly, "Save Attachments"

    Exit Sub

ErrorHandler:

    Dim errMsg As String
    errMsg = "An error has occurred. Error " + Err.Number + " " + Err.Description
    Dim errResult As VbMsgBoxResult
    errResult = MsgBox(errMsg, vbAbortRetryIgnore, "Error in Save Attachments")
    Select Case errResult
        Case vbAbort
            Exit Sub
        Case vbRetry
            Resume
        Case vbIgnore
            Resume Next
    End Select

End Sub


' Process a "chunk" of the selected messages starting at startIndex and finishing at endIndex.
' The attachments are saved in outputDir and the 'statistics' parameters are modified (attachmentCount and messageCount)
Private Sub ProcessChunk(selection As Outlook.selection, _
            startIndex As Integer, endIndex As Integer, outputDir As String, _
            ByRef attachmentCount As Integer, ByRef messageCount As Integer)
    Dim outputFile As String
    Dim msgAttachement As Attachment

    Dim index As Integer
    For index = startIndex To endIndex
        If index <= selection.Count Then
            messageCount = messageCount + 1

            For Each msgAttachement In selection.Item(index).Attachments

                If msgAttachement.Type  olOLE Then
                    outputFile = msgAttachement.filename
                    Dim uniqueFilename As String
                    uniqueFilename = GetUniqueFilename(outputDir, outputFile)
                    msgAttachement.SaveAsFile (outputDir + uniqueFilename)
                    attachmentCount = attachmentCount + 1
                End If
            Next msgAttachement
        End If
    Next index
End Sub


' If the filename already exists, add a counter to the filename (before the extension)
Public Function GetUniqueFilename(directory As String, filename As String) As String
    Dim uniqueFilename As String
    Dim index As Integer

    uniqueFilename = filename
    index = 1
    Do While Not Dir(directory + uniqueFilename) = vbNullString
        uniqueFilename = FileNameNoExtension(filename) + "_" + Format(index, "000") + "." + FileNameExtensionOnly(filename)
        index = index + 1
    Loop
    GetUniqueFilename = uniqueFilename
End Function


' returns the filename without the extension from the file's full path
Function FileNameNoExtension(strPath As String) As String
    Dim strTemp As String
    strTemp = Mid$(strPath, InStrRev(strPath, "\") + 1)
    FileNameNoExtension = Left$(strTemp, InStrRev(strTemp, ".") - 1)
End Function

' returns the filename with the extension from the file's full path
Function FileNameWithExtension(strPath As String) As String
    FileNameWithExtension = Mid$(strPath, InStrRev(strPath, "\") + 1)
End Function

' returns the filename without the extension from the file's full path
Function FileNameExtensionOnly(strPath As String) As String
    Dim strTemp As String
    strTemp = Mid$(strPath, InStrRev(strPath, "\") + 1)
    FileNameExtensionOnly = Mid$(strTemp, InStrRev(strTemp, ".") + 1)
End Function

' returns the path only (i.e. the folder) from the file's full path
Function FilePath(strPath As String) As String
    FilePath = Left$(strPath, InStrRev(strPath, "\"))
End Function


' Display a file dialog to select the target directory
' Found this code in a google groups thread here:
' http://groups.google.com/group/microsoft.public.scripting.vbscript/browse_thread/thread/7187886c3c83a570/c278a2753e9e7ceb%23c278a2753e9e7ceb
' or http://shrinkster.com/l0v
Public Function GetOutputDirectory() As String

    Dim retval As String 'Return Value

    Dim sMsg As String
    Dim cBits As Integer
    Dim xRoot As Integer

    Dim oShell As Object
    Set oShell = CreateObject("shell.application")

    sMsg = "Select a Folder To Output The Attachments To"
    cBits = 1
    xRoot = 17

    On Error Resume Next
        Dim oBFF
        Set oBFF = oShell.BrowseForFolder(0, sMsg, cBits, xRoot)
        If Err Then
            Err.Clear
            GetOutputDirectory = ""
            Exit Function
        End If
    On Error GoTo 0

    If Not IsObject(oBFF) Then
        retval = ""
    Else If Not (LCase(Left(Trim(TypeName(oBFF)), 6)) = "folder") Then
        retval = ""
    Else
        retval = oBFF.self.path

        ' Make sure there's a trailing "\"
        If Right(retval, 1)  "\" Then
            retval = retval + "\"
        End If
    End If

    GetOutputDirectory = retval

End Function

‘ If the filename already exists, add a counter to the filename (before the extension)
Public Function GetUniqueFilename(directory As String, filename As String) As String
Dim uniqueFilename As String
Dim index As Integer

uniqueFilename = filename
index = 1
Do While Not Dir(directory + uniqueFilename) = vbNullString
uniqueFilename = FileNameNoExtension(filename) + “_” + Format(index, “000″) + “.” + FileNameExtensionOnly(filename)
index = index + 1
Loop
GetUniqueFilename = uniqueFilename
End Function

Would you mind posting up the code that you altered to append a 1, 2, 3, etc… to the end of the filenames? I am also trying to find a way to append sequential numbers to the end of the filenames, as I may have thousands of attachments to save…!

But indeed, a great macro all up.

Cheers

Tested the original macro with 100+ messages and it stopped/crashed after the 100th message/attachment. Any idea what it could be?

Thanks again!

My prob is that when I scan a ton of documents at once, they all have the same name (i.e. “scan.pdf”) and having to rename each of them manually is time-consuming even with the input box. I tried to play around with the macro to automatically number each document based on the message number and it worked (i.e. “scan1.pdf”, “scan2.pdf”, etc) but it keeps crashing at 100. Ugh. I tried to troubleshoot as best as I could but haven’t nailed it yet.

REQUEST: any chance of a version of this that would do exactly that – i.e. rather than manually renaming, check for a document with the same filename and then just append the next in a sequential list of numbers to the document filename?

Regardless, great macro! Thanks!