saving attachment form outlook in folder

[Veeru]

Hi, I am new this folder.I am using below code to save attachments from outlook to my documents directly...I have created to folders with name of "For T&E" and "For President". Code is working fine...but can we have further changes to make it more dynamic...Right now it is saving files in my documents in that respective folder,.....but can we also create something where before saving file, it also create a next month folder and save that file in that folder only......I want folder to be created according to the date of email. lets say if I am saving an attachment and email date is 5th june 2017...it should create a June month folder first and then save this attachment in that folder...Please suggest...thanks

Dim strFolder As String

Public Sub SaveToFolderBob()
strFolder = "For T&E"
SaveAttachments
End Sub

Public Sub SaveToFolderJim()
strFolder = "For President"
SaveAttachments
End Sub

Private Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String

' Get the path to your My Documents folder
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
Debug.Print strFolderpath
On Error Resume Next

' The attachment folder needs to exist
' You can change this to another folder name of your choice

' Set the Attachment folder.
strFolderpath = strFolderpath & "\" & strFolder & "\"
Debug.Print strFolderpath

Set objOL = Outlook.Application
Set objMsg = objOL.ActiveExplorer.Selection.Item(1)

Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count

If lngCount > 0 Then

' Use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.

For i = lngCount To 1 Step -1

' Get the file name.
strFile = objAttachments.Item(i).FileName

' Combine with the path to the Temp folder.
strFile = strFolderpath & strFile

' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile

Next i
End If

ExitSub:

Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

[gmayor]

It is easy enough to include a folder based on the date e.g. as follows, and create that folder if not present. Note that your code overwrites existing files of the same name in the target folder. To address this see http://www.vbaexpress.com/forum/showthread.php?59889-Save-all-attachments


Option Explicit

Dim strFolder As String

Public Sub SaveToFolderBob()
strFolder = "For T&E"
SaveAttachments
End Sub

Public Sub SaveToFolderJim()
strFolder = "For President"
SaveAttachments
End Sub

Private Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim strDate As String
On Error Resume Next
' Get the path to your My Documents folder
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
'Debug.Print strFolderpath

' The attachment folder needs to exist
' You can change this to another folder name of your choice

' Set the Attachment folder.

Set objOL = Outlook.Application
Set objMsg = objOL.ActiveExplorer.Selection.Item(1)

'format the date the message was sent on
strDate = Format(objMsg.SentOn, "mmmm yyyy")
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count

'include the month and year in the path
strFolderpath = strFolderpath & "\" & strFolder & "\" & strDate & "\"
'Debug.Print strFolderpath

If lngCount > 0 Then
'Create the folders (if not present)
CreateFolders strFolderpath

' Use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.

For i = lngCount To 1 Step -1

' Get the file name.
strFile = objAttachments.Item(i).fileName

' Combine with the path to the Temp folder.
strFile = strFolderpath & strFile

' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile

Next i
End If

ExitSub:

Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

Private Function CreateFolders(strPath As String)
'Graham Mayor - http://www.gmayor.com - Last updated - 31 May 2017
'Creates the full path 'strPath' if missing or incomplete
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
Dim oFSO As Object
Dim i As Integer
Set oFSO = CreateObject("Scripting.FileSystemObject")
vPath = Split(strPath, "\")
If Left(strPath, 2) = "\\" Then
strPath = "\\" & vPath(2) & "\"
For lngPath = 3 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not oFSO.FolderExists(strPath) Then MkDir strPath
Next lngPath
Else
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not oFSO.FolderExists(strPath) Then MkDir strPath
Next lngPath
End If
lbl_Exit:
Set oFSO = Nothing
Exit Function
End Function

[Veeru]

Yes this working...Great thank you....one more question....Above code use my documents path to save all files...How can I save files at some other share drive...How can I find path for the same. so that it will save file on that share drive instead of My documents....

[gmayor]

The root folder for your current macro is My Documents defined by the line

strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
If you want to use a different root folder, change that line to the path of the 'share drive'.
As you have told us nothing about the 'share drive', I cannot tell you how to locate its path, but if you can see it in Windows File Explorer, you can get the path from there.
It will work with Network drives if you put the writeable Network shared folder as the root e.g.

strFolderpath = "\\NetName\Public"

[Veeru]

I tried to use my share drive path \\us1.1corp.org\agir\Departments\Accounting\Infy\Veeru instaed of my documents path at( strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
but it is not working...it not saving attachment nor giving any error message...thanks..

[gmayor]

You have an 'on error' line which is inhibiting the error. If
strFolderpath = "\\us1.1corp.org\agir\Departments\Accounting\Infy\Veeru"
doesn't produce the correct results, my guess is that you don't have the appropriate permissions to create the sub folders in that folder. Commenting out the on error temporarily should confirm.

[Veeru]

thanks for reply but I can create folder manually In this path....so I guess, i have required permission...