Save Email Attachments In a Folder Based on the date an email was received.

[nathandavies]

Hi All
I have been using this code which someone helped write on here for me but i'm wanting to make a change if possible? i want to save the attachments in a folder based on the date received in the email is this possible?


Private Sub SaveAttachments(olItem As MailItem, strSaveFolder As String) 'An Outlook macro by Graham Mayor
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim j As Long
On Error GoTo CleanUp
If olItem.Attachments.Count > 0 Then
For j = olItem.Attachments.Count To 1 Step -1
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(strSaveFolder, strFname, strExt)
olAttach.SaveAsFile strSaveFolder & strFname
'olAttach.Delete 'delete the attachment
End If
Next j
olItem.SAVE
End If
CleanUp:
Set olAttach = Nothing
Set olItem = Nothing
lbl_Exit:
Exit Sub
End Sub

[skatonni]

Replace

strFname = olAttach.FileName

with

strFname = Format(olItem.ReceivedTime, "yyyy-mm-dd ") & olAttach.fileName

[nathandavies]

I'm not sure if I got my question correct or if I'm reading the code wrong.

Does this create a folder based on the date and put the attachements in that folder?

[nathandavies]

I have tried the code today and the code works well for renaming the file, but i would like to create a new folder within the "Document Received" folder with the days date as the Folder Name, and then save all attachments from that date in the folder.

Is this possible?

My full code for your assistance.


Option ExplicitPrivate Const strRoot As String = "\\NEWBENSON\Projects\drawings\"
Sub Save()
Dim olObj As Object
Dim olMsg As MailItem
Dim selCount As Long
Dim j As Long

selCount = ActiveExplorer.Selection.Count

For j = selCount To 1 Step -1
Set olObj = ActiveExplorer.Selection.Item(j)
If olObj.Class = olMail Then
Set olMsg = olObj
Debug.Print olMsg.Subject
SaveItem olMsg
End If

Next j
lbl_Exit:
Exit Sub
End Sub


Private Function GetPath(strCustomer As String) As String
Dim FSO As Object
Dim Folder As Object
Dim subFolder As Object
Dim strPath As String
Dim bPath As Boolean
Start:
strPath = InputBox("Enter Project Number.")
If strPath = "" Then GoTo lbl_Exit
If Not Len(strPath) = 5 And Not IsNumeric(Right(strPath, 4)) Then
MsgBox "Enter a Letter and 4 digits!"
GoTo Start:
End If
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Folder = FSO.GetFolder(strRoot & Chr(92) & strCustomer) 'error on strRoot?
For Each subFolder In Folder.SubFolders
'Debug.Print subFolder & vbTab & strRoot & strPath
If InStr(1, CStr(subFolder), UCase(strPath)) > 0 Then
strPath = CStr(subFolder)
bPath = True
Exit For
End If
Next
If Not bPath Then strPath = ""
lbl_Exit:
GetPath = strPath
Exit Function
End Function

Sub SaveItem(olItem As MailItem)
Dim objItem As Outlook.MailItem
Dim fname As String
Dim fPath1 As String, fPath2 As String
Dim strPath As String, strSavePath As String
fPath1 = InputBox("Enter the customer folder name in which to save the message." & vbCr & _
"The path will be created if it doesn't exist.", _
"Save Message")
fPath1 = Replace(fPath1, "\", "")

fPath2 = GetPath(fPath1)
If fPath2 = "" Then
MsgBox "The project number does not exist!"
'so end processing
GoTo lbl_Exit
End If

strPath = fPath2

'CreateFolders strPath 'superfluous as the following line will create strPath
CreateFolders strPath & "\Correspondence" & "\Sent"
CreateFolders strPath & "\Correspondence" & "\Received"
CreateFolders strPath & "\Documents" & "\Documents Received"
'vProject = Split(fPath2, Chr(92))
'strProject = vProject(UBound(vProject) - 1)
'Debug.Print strProject

If olItem.Sender Like "Nathan Davies" Then 'Looks for messages from you
fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
strSavePath = strPath & "\Correspondence\Sent\"
Else
fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
strSavePath = strPath & "\Correspondence\Received\"
End If

fname = Replace(fname, Chr(58) & Chr(41), "")
fname = Replace(fname, Chr(58) & Chr(40), "")
fname = Replace(fname, Chr(34), "-")
fname = Replace(fname, Chr(42), "-")
fname = Replace(fname, Chr(47), "-")
fname = Replace(fname, Chr(58), "-")
fname = Replace(fname, Chr(60), "-")
fname = Replace(fname, Chr(62), "-")
fname = Replace(fname, Chr(63), "-")
fname = Replace(fname, Chr(124), "-")
SaveUnique olItem, strSavePath, fname



If MsgBox("Save Attachments?", vbYesNo, "Save Attachments?") = vbYes Then
SaveAttachments olItem, strPath & "\Documents\Documents Received\"
End If
If MsgBox("Save To Excel?", vbYesNo, "Save Attachments?") = vbYes Then
CopyToExcel olItem, strPath 'The line goes here
End If
lbl_Exit:

End Sub

Private Sub SaveAttachments(olItem As MailItem, strSaveFolder As String)
'An Outlook macro by Graham Mayor
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim j As Long
On Error GoTo CleanUp
If olItem.Attachments.Count > 0 Then
For j = olItem.Attachments.Count To 1 Step -1
Set olAttach = olItem.Attachments(j)
If Not olAttach.FileName Like "image*.*" Then
strFname = Format(olItem.ReceivedTime, "yyyy-mm-dd ") & olAttach.FileName
strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
strFname = FileNameUnique(strSaveFolder, strFname, strExt)
olAttach.SaveAsFile strSaveFolder & strFname
'olAttach.Delete 'delete the attachment
End If
Next j
olItem.Save
End If
CleanUp:
Set olAttach = Nothing
Set olItem = Nothing
lbl_Exit:
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

Public Sub CreateFolders(strPath As String)
'A Graham Mayor/Greg Maxey AddIn Utility Macro
Dim oFSO As Object
Dim lngPathSep As Long
Dim lngPS As Long
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
lngPathSep = InStr(3, strPath, "\")
If lngPathSep = 0 Then GoTo lbl_Exit
Set oFSO = CreateObject("Scripting.FileSystemObject")
Do
lngPS = lngPathSep
lngPathSep = InStr(lngPS + 1, strPath, "\")
If lngPathSep = 0 Then Exit Do
If Len(Dir(Left(strPath, lngPathSep), vbDirectory)) = 0 Then Exit Do
Loop
Do Until lngPathSep = 0
If Not oFSO.FolderExists(Left(strPath, lngPathSep)) Then
oFSO.CreateFolder Left(strPath, lngPathSep)
End If
lngPS = lngPathSep
lngPathSep = InStr(lngPS + 1, strPath, "\")
Loop
lbl_Exit:
Set oFSO = Nothing
Exit Sub
End Sub

Private Function SaveUnique(oItem As Object, _
strPath As String, _
strFileName As String)
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName)
Do While FileExists(strPath & strFileName & ".msg") = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
oItem.SaveAs strPath & strFileName & ".msg"
lbl_Exit:
Exit Function
End Function

Private Function FileExists(filespec As String) As Boolean
'An Office macro by Graham Mayor - www.gmayor.com
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 String) As Boolean
'An Office macro by Graham Mayor - www.gmayor.com
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
Sub CopyToExcel(olItem As MailItem, strFolder As String)

Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rCount As Long
Dim bXStarted As Boolean
Dim strPath As String
Dim objFolder As Outlook.MAPIFolder
Dim strColA, strColB, strColC, strColD, strColE, strColF As String

' Get Excel set up
'the path of the workbook
Do Until Right(strFolder, 1) = Chr(92)
strFolder = strFolder & Chr(92)
Loop
strPath = strFolder & "correspondence\email register.xlsx"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
'etc


On Error Resume Next
' Open the workbook to input the data
' Create workbook if doesn't exist
Set xlWB = xlApp.Workbooks.Open(strPath)
If Err <> 0 Then
Set xlWB = xlApp.Workbooks.Add
xlWB.SaveAs FileName:=strPath
End If
On Error GoTo 0
Set xlSheet = xlWB.Sheets("email")

On Error Resume Next
' add the headers if not present
If xlSheet.Range("A7") = "" Then
xlSheet.Range("A7") = "Sender Name"
xlSheet.Range("B7") = "Sent To"
xlSheet.Range("C7") = "Date"
xlSheet.Range("D7") = "Subject"
xlSheet.Range("E7") = "Body"
End If

'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
'needed for Exchange 2016. Remove if causing blank lines.
rCount = rCount + 1

'collect the fields

strColA = olItem.SenderName
strColB = olItem.To
strColC = olItem.ReceivedTime
strColD = olItem.Subject
strColE = olItem.Body

' Get the Exchange address
' if not using Exchange, this block can be removed
Dim olEU As Outlook.ExchangeUser
Dim oEDL As Outlook.ExchangeDistributionList
Dim recip As Outlook.Recipient
Set recip = Application.Session.CreateRecipient(strColC)


If InStr(1, strColB, "/") > 0 Then
' if exchange, get smtp address
Select Case recip.AddressEntry.AddressEntryUserType
Case OlAddressEntryUserType.olExchangeUserAddressEntry
Set olEU = recip.AddressEntry.GetExchangeUser
If Not (olEU Is Nothing) Then
strColC = olEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olOutlookContactAddressEntry
Set olEU = recip.AddressEntry.GetExchangeUser
If Not (olEU Is Nothing) Then
strColC = olEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
Set oEDL = recip.AddressEntry.GetExchangeDistributionList
If Not (oEDL Is Nothing) Then
strColC = olEU.PrimarySmtpAddress
End If
End Select
End If
' End Exchange section


'write them in the excel sheet
xlSheet.Range("A" & rCount) = strColA
xlSheet.Range("B" & rCount) = strColB
xlSheet.Range("c" & rCount) = strColC
xlSheet.Range("d" & rCount) = strColD
xlSheet.Range("e" & rCount) = strColE

'Next row
rCount = rCount + 1
xlWB.Save

'wrap lines
xlSheet.Rows.WrapText = True


xlWB.Save
xlWB.Close 1

If bXStarted Then
'xlApp.Quit 'With looped messages it will be faster if Excel is not closed
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub
Private Sub ReplaceCharsForFileName(sName As String, _
sChr As String _
)
sName = Replace(sName, "'", sChr)
sName = Replace(sName, "*", sChr)
sName = Replace(sName, "/", sChr)
sName = Replace(sName, "\", sChr)
sName = Replace(sName, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
End Sub

[gmayor]

Createfolders will create any missing valid folder path you throw at it, so in this case change

If Not olAttach.fileName Like "image*.*" Then
to

If Not olAttach.fileName Like "image*.*" Then
strSavefolder = strSavefolder & Format(olItem.ReceivedTime, "yyyy-mm-dd") & Chr(92)
CreateFolders strSavefolder
If the path exists the Createfolders function does nothing
Be aware that some date formats e.g. 01/08/2017 contain illegal filename characters, so stick to yyyy-mm-dd or yyyymmdd

[nathandavies]

Graham, this code works for single attachments but when there are two or more attachments it puts multiple new folders in.

19957
It puts the dated folder in the "document received" but then it puts another in the dated folder within its self.

[gmayor]

Oops. I should have checked that before posting. Sorry.
The issue there is that the folder creating is inside the attachments loop. It needs to go outside it e.g.


If olItem.Attachments.Count > 0 Then
strSaveFolder = strSaveFolder & Format(olItem.ReceivedTime, "yyyy-mm-dd") & Chr(92)
CreateFolders strSaveFolder
For j = olItem.Attachments.Count To 1 Step -1
Set olAttach = olItem.Attachments(j)
If Not olAttach.fileName Like "image*.*" Then

[nathandavies]

Graham,
Thank you very much! that has work perfectly!!!