Outlook VBA code to save email attachments to a drive location with a unique file name.

[ohmedic88]

Outlook VBA Code

My problem is that I have individuals that are sending me files with the exact same name and I need to make sure they do not write over each other.

So I'm using the below code to auto add attachments to file location. However, I need to modify it so that each file has a unique file name.


I'm still a VBA novice so I need someone to walk me through the edit.

Thanks in advance.

Eric

Option Explicit

Sub Extract_Attachemnts_From_Selection()
Dim OlMail As MailItem
Dim OlAtchs As Attachments
Dim OlSelection As Selection
Dim icount As Long, i As Long
Dim sfolderpath As String, sFilepath As String, sdeletedFiles As String
Dim objWSCript As Object '// Shell Scripting


On Error Resume Next
'// initial shell script instance
Set objWSCript = CreateObject("WSCript.Shell")


'// get my document folder Path
sfolderpath = objWSCript.specialfolders("Documents")


'// get the selection
Set OlSelection = ActiveExplorer.Selection


'// Set Where the Attachments will be saved
sfolderpath = sfolderpath & "C:\Users\(1)\COAs\"


'---------------------------------------------------
'              Extract Attachments
'---------------------------------------------------
'// Looping all the mail itmes from selection
For Each OlMail In OlSelection


    Set OlAtchs = OlMail.Attachments
    icount = OlAtchs.Count '//Attachment count based on mail item
    sdeletedFiles = ""
    
    '//if there are attachments
    If icount > 0 Then
            For i = icount To 1 Step -1
                sFilepath = sfolderpath & OlAtchs.Item(i).FileName
                
                OlAtchs.Item(i).SaveAsFile sFilepath
                
                '// optional: To delete the attachments
                'olatchs.Item(i).Delete
                
                '// Modify mail body message with note indicating where the attachments are saved
                If OlMail.BodyFormat <> olFormatHTML Then
                    sdeletedFiles = sdeletedFiles & vbNewLine & "<file://" & sFilepath & ">"
                Else
                    sdeletedFiles = sdeletedFiles & "<br>" & "<a href='file://" & _
                                    sFilepath & "'>" & sFilepath & "</a>"
                End If
            
            Next i
                    
            If OlMail.BodyFormat <> olFormatHTML Then
               OlMail.Body = vbNewLine & "The file(s) were save to " & sdeletedFiles & vbNewLine
            Else
                OlMail.HTMLBody = "<p>" & "the file(s) were saved to " & sdeletedFiles & "</p>" & OlMail.HTMLBody
            End If
            
            OlMail.Save
    
        End If
          
    Next OlMail
 
Door:
Set objWSCript = Nothing
Set OlAtchs = Nothing
Set OlSelection = Nothing
End Sub

 

[Worf]

Hi Eric

' Outlook module
Sub Extract_Attachemnts_From_Selection()
Dim OlMail As MailItem, OlAtchs As Attachments, OlSelection As Selection, icount As Long, i%
Dim fpath, filep$, dfiles$, objWSCript As Object, atname(0 To 1), dotpos%, atfulln$, fso As Object, atnametemp$
Set objWSCript = CreateObject("WSCript.Shell") '// initial shell script instance
fpath = objWSCript.specialfolders("Documents") '// get my document folder Path
Set fso = CreateObject("Scripting.FileSystemObject")
Set OlSelection = ActiveExplorer.Selection
For Each OlMail In OlSelection
    Set OlAtchs = OlMail.Attachments
    icount = OlAtchs.Count '//Attachment count based on mail item
    dfiles = ""
    If icount > 0 Then
        For i = icount To 1 Step -1
            atfulln = OlAtchs.Item(i).FileName
            dotpos = InStrRev(atfulln, ".")
            atname(0) = Left$(atfulln, dotpos - 1): atname(1) = Right$(atfulln, Len(atfulln) - dotpos)
            filep = fpath & atname(0) & "." & atname(1)
            Do While fso.fileexists(filep)
                atnametemp = atname(0) & Format(Now, "_mmddhhmmss") & Format(Timer * 1000 Mod 1000, "000")
                filep = fpath & atnametemp & "." & atname(1)
                If Len(filep) > 260 Then
                    MsgBox "Path is too long."
                    Exit Sub
                End If
            Loop
            OlAtchs.Item(i).SaveAsFile filep
            If OlMail.BodyFormat <> olFormatHTML Then
                dfiles = dfiles & vbNewLine & "<file://" & filep & ">"
            Else
                dfiles = dfiles & "<br>" & "<a href='file://" & filep & "'>" & filep & "</a>"
            End If
        Next
        If OlMail.BodyFormat <> olFormatHTML Then
            OlMail.Body = vbNewLine & "The file(s) were save to " & dfiles & vbNewLine
        Else
            OlMail.HTMLBody = "<p>" & "the file(s) were saved to " & dfiles & "</p>" & OlMail.HTMLBody
        End If
        OlMail.Save
    End If
Next
Set objWSCript = Nothing: Set OlAtchs = Nothing: Set OlSelection = Nothing
End Sub

 

[ohmedic88]

I'm, confused. Do I add this to my code or does it run by itself? I've played with putting it in but haven't got a good result on the saving. I think I just need some more information.

Eric

 

[Worf]

The routine runs by itself and saves to the Documents folder. Just select a message with attachments and execute the code.