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