Consulting

Results 1 to 9 of 9

Thread: save outlook attachments from excel macro with specific file name

  1. #1
    VBAX Contributor
    Joined
    Jun 2019
    Posts
    155
    Location

    save outlook attachments from excel macro with specific file name

    Dear Team,


    I want to download outlook mail attachment with specific file name ("Calibration") on current month and create the new folder on name of current month and save the files to on that folder.


    For example when i click button first it should search what ever the mail attachment received in the name of "Calibration" on current month (EXample: May) only and create sub folder with current month name to C:\Users\SENTHIL KUMAR P\Desktop\SUmmary\ (Month Name) and save all that file to the folder.


    I tried the bellow code. This code is downloading entire mail attachment. I dont know how to change this code as per my requirement.


    Sub AttDownload()
     For Each it In CreateObject("Outlook.Application").GetNamespace("MAPI").getdefaultfolder(6).items
     For Each at In it.attachments
     at.SaveAsFile "C:\Users\SENTHIL KUMAR P\Desktop\SUmmary\" & at.FileName
     Next
     Next
    End Sub


    Can any one please help me to solve this.

  2. #2
    Maybe something like the following,

    Sub AttDownload()
    Dim oItem As Object
    Dim oAtt As Object
    Dim sName As String
    Dim sExt As String
    Dim sPath As String
        sPath = Environ("USERPROFILE") & "\Desktop\SUmmary\"
        For Each oItem In CreateObject("Outlook.Application").GetNamespace("MAPI").getdefaultfolder(6).Items
            If TypeName(oItem) = "MailItem" Then
                If Format(oItem.ReceivedTime, "mmmm yyyy") = Format(Date, "mmmm yyyy") Then
                    For Each oAtt In oItem.attachments
                        If LCase(oAtt.FileName) Like "*calibration*" Then
                            sName = oAtt.FileName
                            sExt = Right(sName, Len(sName) - InStrRev(sName, Chr(46)))
                            sName = FileNameUnique(sPath, sName, sExt)
                            oAtt.SaveAsFile sPath & sName
                        End If
                    Next oAtt
                End If
            End If
        Next oItem
        Set oAtt = Nothing
        Set oItem = Nothing
    End Sub
    
    Private Function FileNameUnique(strPath As String, _
                                   strFileName As String, _
                                   strExtension As String) As String
    'Graham Mayor - http://www.gmayor.com - Last updated - 22 Jun 2018
    'strPath is the path in which the file is to be saved
    'strFilename is the filename to check
    'strextension is the extension of the filename to check
    Dim lng_F As Long
    Dim lng_Name As Long
    Dim FSO As Object
        Set FSO = CreateObject("Scripting.FileSystemObject")
        Do Until Right(strPath, 1) = "\"
            strPath = strPath & "\"
        Loop
        If InStr(1, strFileName, "\") > 0 Then
            strFileName = Mid(strFileName, InStrRev(strFileName, "\") + 1)
        End If
        strExtension = Replace(strExtension, Chr(46), "")
        lng_F = 1
        lng_Name = Len(strFileName) - (Len(strExtension) + 1)
        strFileName = Left(strFileName, lng_Name)
        'If the filename exists, add or increment a number to the filename
        'and keep checking until a unique name is found
        Do While FSO.FileExists(strPath & strFileName & Chr(46) & strExtension) = True
            strFileName = Left(strFileName, lng_Name) & "(" & lng_F & ")"
            lng_F = lng_F + 1
        Loop
        'Reassemble the filename
        FileNameUnique = strFileName & Chr(46) & strExtension
    lbl_Exit:
        Set FSO = Nothing
        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

  3. #3
    VBAX Contributor
    Joined
    Jun 2019
    Posts
    155
    Location
    Dear Gmayor,

    Thanks for your reply. I checked your code. It saving "Calibration" file from current month mail. But the files are downloading on Environ("USERPROFILE") & "\Desktop\Summary" only. It is not creating sub folder with name of current month (May-2020).

    If the file is already existing on the sub folder it want save again

  4. #4
    VBAX Contributor
    Joined
    Jun 2019
    Posts
    155
    Location
    Dear Gmayor,

    Can you please help me how to save the files with creating new folder with name of current month

  5. #5
    VBAX Contributor
    Joined
    Jun 2019
    Posts
    155
    Location
    Dear Gmayor,

    I modified your code as per my requirement. Not the sub folder is creating and saved all the files inside that.

    The modified code is here

    Sub AttDownload()Dim oItem As Object
    Dim oAtt As Object
    Dim sName As String
    Dim sExt As String
    Dim sPath As String
    Dim sFolderName As String, sFolderPath As String
    
    
        sFolderPath = Environ("USERPROFILE") & "\Desktop\KRA SUmmary\"
        sFolderName = Format(DateAdd("M", -1, Now), "mmmm yyyy") & "\"
        sPath = sFolderPath & sFolderName
        
        For Each oItem In CreateObject("Outlook.Application").GetNamespace("MAPI").getdefaultfolder(6).Items
            If TypeName(oItem) = "MailItem" Then
                If Format(oItem.ReceivedTime, "mmmm yyyy") = Format(Date, "mmmm yyyy") Then
                    For Each oAtt In oItem.attachments
                        If LCase(oAtt.Filename) Like "*kra*" Then
                            sName = oAtt.Filename
                            sExt = Right(sName, Len(sName) - InStrRev(sName, Chr(46)))
                            sName = FileNameUnique(sPath, sName, sExt)
                            oAtt.SaveAsFile sPath & sName
                        End If
                    Next oAtt
                End If
            End If
            
        Next oItem
        Set oAtt = Nothing
        Set oItem = Nothing
    End Sub
    
    
    Private Function FileNameUnique(strPath As String, _
                                   strFileName As String, _
                                   strExtension As String) As String
    
    
    Dim lng_F As Long
    Dim lng_Name As Long
    Dim FSO As Object
        Set FSO = CreateObject("Scripting.FileSystemObject")
    
    
        If Dir(strPath, vbDirectory) = "" Then
            MkDir strPath
        End If
        If InStr(1, strFileName, "\") > 0 Then
            strFileName = Mid(strFileName, InStrRev(strFileName, "\") + 1)
        End If
            strExtension = Replace(strExtension, Chr(46), "")
            lng_F = 1
            lng_Name = Len(strFileName) - (Len(strExtension) + 1)
            strFileName = Left(strFileName, lng_Name)
    
    
            FileNameUnique = strFileName & Chr(46) & strExtension
    lbl_Exit:
        Set FSO = Nothing
        Exit Function
    End Function
    I request you to kindly go through this code and reply me about this

  6. #6
    Add the following sub to the same module, and call it from the main macro immediately after defining sPath i.e.
    sPath = sFolderPath & sFolderName
    CreateFolders sPath
    Private Sub CreateFolders(strPath As String)
    'A Graham Mayor/Greg Maxey AddIn Utility Macro
    Dim oFSO As Object
    Dim lng_PathSep As Long
    Dim lng_PS As Long
        If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
        lng_PathSep = InStr(3, strPath, "\")
        If lng_PathSep = 0 Then GoTo lbl_Exit
        Set oFSO = CreateObject("Scripting.FileSystemObject")
        Do
            lng_PS = lng_PathSep
            lng_PathSep = InStr(lng_PS + 1, strPath, "\")
            If lng_PathSep = 0 Then Exit Do
            If Len(Dir(Left(strPath, lng_PathSep), vbDirectory)) = 0 Then Exit Do
        Loop
        Do Until lng_PathSep = 0
            If Not oFSO.FolderExists(Left(strPath, lng_PathSep)) Then
                oFSO.CreateFolder Left(strPath, lng_PathSep)
            End If
            lng_PS = lng_PathSep
            lng_PathSep = InStr(lng_PS + 1, strPath, "\")
        Loop
    lbl_Exit:
        Set oFSO = Nothing
        Exit Sub
    End Sub
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  7. #7
    VBAX Contributor
    Joined
    Jun 2019
    Posts
    155
    Location
    Dear Gmayor,

    It is working great. Thanks for your support.

    i have one doubt. The files are being downloaded only from Inbox or it will download from send item also. Can you pls confirm

  8. #8
    It downloads from the Inbox as your original -
    For Each oItem In CreateObject("Outlook.Application").GetNamespace("MAPI").getdefaultfolder(6).Items
    If you want it to also download from your sent items folder you will need another loop to process that folder e.g.

    Sub AttDownload()
    
    Dim olApp As Object
    Dim oItem As Object
    Dim oAtt As Object
    Dim sName As String
    Dim sExt As String
    Dim sPath As String
    Dim sFolderName As String, sFolderPath As String
    
    
        sFolderPath = Environ("USERPROFILE") & "\Desktop\KRA SUmmary\"
        sFolderName = Format(DateAdd("M", -1, Now), "mmmm yyyy") & "\"
        sPath = sFolderPath & sFolderName
        CreateFolders sPath
        Set olApp = CreateObject("Outlook.Application")
        With olApp
            For Each oItem In .GetNamespace("MAPI").GetDefaultFolder(6).Items    'Default Inbox
                If TypeName(oItem) = "MailItem" Then
                    If Format(oItem.ReceivedTime, "mmmm yyyy") = Format(Date, "mmmm yyyy") Then
                        For Each oAtt In oItem.Attachments
                            If LCase(oAtt.FileName) Like "*kra*" Then
                                sName = oAtt.FileName
                                sExt = Right(sName, Len(sName) - InStrRev(sName, Chr(46)))
                                sName = FileNameUnique(sPath, sName, sExt)
                                oAtt.SaveAsFile sPath & sName
                            End If
                        Next oAtt
                    End If
                End If
                DoEvents
            Next oItem
    
            For Each oItem In .GetNamespace("MAPI").GetDefaultFolder(5).Items    'Default Sent Items
                If TypeName(oItem) = "MailItem" Then
                    If Format(oItem.SentOn, "mmmm yyyy") = Format(Date, "mmmm yyyy") Then
                        For Each oAtt In oItem.Attachments
                            If LCase(oAtt.FileName) Like "*kra*" Then
                                sName = oAtt.FileName
                                sExt = Right(sName, Len(sName) - InStrRev(sName, Chr(46)))
                                sName = FileNameUnique(sPath, sName, sExt)
                                oAtt.SaveAsFile sPath & sName
                            End If
                        Next oAtt
                    End If
                End If
                DoEvents
            Next oItem
        End With
        Set olApp = Nothing
        Set oAtt = Nothing
        Set oItem = Nothing
    End Sub
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  9. #9
    VBAX Contributor
    Joined
    Jun 2019
    Posts
    155
    Location
    OK. Thanks for your support

Posting Permissions

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