Consulting

Results 1 to 2 of 2

Thread: Need VBA Outlook help- saves over duplicate file

  1. #1
    VBAX Newbie
    Joined
    Jun 2019
    Posts
    1
    Location

    Need VBA Outlook help- saves over duplicate file

    Trying to auto save incoming attachments based on a rule and then running VBA to save the file to a folder. The code works but I ran into a problem when there are duplicate files named with the same name, it will just overwrite the old file. Is there a way to add to the following code a number to end of the naming convention? like 1 , 2, 3 and so on so that it will not overwrite the other file? or better yet add the date to the end of the file path when saving? Thanks for your help

    Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
    Dim objAtt As Outlook.Attachment
    Const saveFolder As String = "C:\Users\wrighta\Documents\Test"
    For Each objAtt In itm.Attachments
    objAtt.SaveAsFile saveFolder & "" & objAtt.DisplayName
    Set objAtt = Nothing
    Next
    End Sub

  2. #2
    Use the following, versions of which I have posted here previously

    Option Explicit
    
    Public Sub saveAttachtoDisk(olItem As Outlook.MailItem)
    'Graham Mayor - https://www.gmayor.com - Last updated - 26 Jun 2019
    Dim olAttach As Attachment
    Dim strFName As String
    Dim strExt As String
    Dim j As Long
    Dim strSaveFldr As String
    
    
        strSaveFldr = Environ("USERPROFILE") & "\Documents\Test\"
        CreateFolders strSaveFldr
    
    
        On Error GoTo lbl_Exit
        If olItem.Attachments.Count > 0 Then
            For j = 1 To olItem.Attachments.Count
                Set olAttach = olItem.Attachments(j)
                If Not olAttach.fileName Like "image*.*" Then
                    strFName = olAttach.fileName
                    strExt = Right(strFName, Len(strFName) - InStrRev(strFName, Chr(46)))
                    strFName = FileNameUnique(strSaveFldr, strFName, strExt)
                    olAttach.SaveAsFile strSaveFldr & strFName
                End If
            Next j
            olItem.Save
        End If
    lbl_Exit:
        Set olAttach = Nothing
        Set olItem = Nothing
        Exit Sub
    End Sub
    
    
    Private Function FileNameUnique(strPath As String, _
                                    strFileName As String, _
                                    strExtension As String) As String
    'An Outlook macro by Graham Mayor
    Dim lngF As Long
    Dim lngName As Long
        lngF = 1
        lngName = Len(strFileName) - (Len(strExtension) + 1)
        strFileName = Left(strFileName, lngName)
        Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
            strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
            lngF = lngF + 1
        Loop
        FileNameUnique = strFileName & Chr(46) & strExtension
    lbl_Exit:
        Exit Function
    End Function
    
    
    Private Function FileExists(filespec) As Boolean
    'An Outlook macro by Graham Mayor
    Dim fso As Object
        Set fso = CreateObject("Scripting.FileSystemObject")
        If fso.FileExists(filespec) Then
            FileExists = True
        Else
            FileExists = False
        End If
    lbl_Exit:
        Exit Function
    End Function
    
    
    Private Function FolderExists(fldr) As Boolean
    'An Outlook macro by Graham Mayor
    Dim fso As Object
        Set fso = CreateObject("Scripting.FileSystemObject")
        If (fso.FolderExists(fldr)) Then
            FolderExists = True
        Else
            FolderExists = False
        End If
    lbl_Exit:
        Exit Function
    End Function
    
    
    Private Function CreateFolders(strPath As String)
    'An Outlook macro by Graham Mayor
    Dim strTempPath As String
    Dim lngPath As Long
    Dim VPath As Variant
        VPath = Split(strPath, "\")
        strPath = VPath(0) & "\"
        For lngPath = 1 To UBound(VPath)
            strPath = strPath & VPath(lngPath) & "\"
            If Not FolderExists(strPath) Then MkDir strPath
        Next lngPath
    lbl_Exit:
        Exit Function
    End Function
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •