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.

Code:

---

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.

Maybe something like the following,

Code:

---

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

---

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

Dear Gmayor,

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

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

Code:

---

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

Add the following sub to the same module, and call it from the main macro immediately after defining sPath i.e.

Code:

---

sPath = sFolderPath & sFolderName
CreateFolders sPath

---

Code:

---

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

---

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

It downloads from the Inbox as your original -

Code:

---

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.

Code:

---

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

---

OK. Thanks for your support