Hi, I am new in this forum..... I have code where by clicking on mail and using VBA..i can save that email attachment in my documents in that particular folder(For T&E and For President).......it is working fine but what I trying to do is .....saving attachment but before that create a folder according to the email date...let's say if email date is 06/05/2017 then is should create a June month folder and then save attachment. Please suggest
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 = Environ("HOMEDRIVE") & Environ("HOMEPATH") & "\Documents"
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
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 = Environ("HOMEDRIVE") & Environ("HOMEPATH") & "\Documents"
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