Hi all,
First off, I am a first time poster but long-time lurker here on the forums. Thank you to everyone who takes time out of their day to help out on these forums. It is much appreciated.
To my question, I currently have a macro set up in an excel workbook that, when run, it allows the user to select a folder within outlook (which contains many, many emails with attachments) that loops through all emails within the folder and copies and saves all attachments to another specified non-outlook folder on a shared drive. The code can be viewed below.
My question comes in the form of, how one would go about building in logic to search the attachment filename for a wildcard and match it to a folder with the same wildcard. Once matched, the attachment would be copied and saved in the respective folder. The intuition is that the destination folder would already be setup beforehand, so that all the macro does is search the filename for a wildcard inside the destination folder name, and then moves the attachment after the match.
Also as an added bonus, it would be nice to have the macro run on non-read emails, and if an attachment is copied, then it would mark the email as read. Again, not a necessity, but it would be nice. Thanks all in advance.
This code was originally written by Jimmy Pena @ http://www.jpsoftwaretech.com/.
Sub GetAttachments()
Call SaveAllAttachments("S:\All\Data", False)
End Sub
Sub SaveAllAttachments(ByVal folderName As String, _
ByVal StripAttachments As Boolean)
' save all attachments from all emails in a folder to a folder on the hard disk
' optionally delete the attachments as well
' check if folder exists, if not then create it
' if folder cannot be created, exit
If Not FolderExists(folderName) Then
On Error Resume Next
MkDir folderName
If Err <> 0 Then Exit Sub
On Error GoTo 0
End If
' check that folderName ends with "\"
If Right$(folderName, 1) <> "\" Then
folderName = folderName & "\"
End If
' get default Inbox items collection
Dim olFldr As Outlook.MAPIFolder
Dim itms As Outlook.Items
Set olFldr = Outlook.GetNamespace("MAPI").PickFolder
If olFldr Is Nothing Then Exit Sub
Set itms = olFldr.Items
' create subset of items collection
Dim newItems As Outlook.Items
Set newItems = itms.Restrict("[Attachment] > 0")
' if there are no messages with attachments, exit
If newItems.Count = 0 Then
RmDir folderName
Exit Sub
End If
' loop through items subset, save all attachments to disk folder
Dim Msg As Outlook.MailItem
Dim MsgAttach As Outlook.Attachments
Dim attachmentNumber As Integer
For Each Msg In newItems
Set MsgAttach = Msg.Attachments
For attachmentNumber = MsgAttach.Count To 1 Step -1
MsgAttach.Item(attachmentNumber).SaveAsFile _
folderName & Format(Msg.ReceivedTime, "mmddyyyy_") & MsgAttach.Item(attachmentNumber).Filename
' delete attachment (optional)
If StripAttachments Then
MsgAttach.Item(attachmentNumber).Delete
End If
Next attachmentNumber
Next Msg
End Sub
Private Function GetDefaultFolder(outlookFolder As OlDefaultFolders) As _
Outlook.MAPIFolder
' returns MAPIFolder object from default folder list to calling program
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set GetDefaultFolder = olNS.GetDefaultFolder(outlookFolder)
End Function
Function FolderExists(ByVal strPath As String) As Boolean
On Error Resume Next
FolderExists = ((GetAttr(strPath) And vbDirectory) = vbDirectory)
End Function
First off, I am a first time poster but long-time lurker here on the forums. Thank you to everyone who takes time out of their day to help out on these forums. It is much appreciated.
To my question, I currently have a macro set up in an excel workbook that, when run, it allows the user to select a folder within outlook (which contains many, many emails with attachments) that loops through all emails within the folder and copies and saves all attachments to another specified non-outlook folder on a shared drive. The code can be viewed below.
My question comes in the form of, how one would go about building in logic to search the attachment filename for a wildcard and match it to a folder with the same wildcard. Once matched, the attachment would be copied and saved in the respective folder. The intuition is that the destination folder would already be setup beforehand, so that all the macro does is search the filename for a wildcard inside the destination folder name, and then moves the attachment after the match.
Also as an added bonus, it would be nice to have the macro run on non-read emails, and if an attachment is copied, then it would mark the email as read. Again, not a necessity, but it would be nice. Thanks all in advance.
This code was originally written by Jimmy Pena @ http://www.jpsoftwaretech.com/.
Sub GetAttachments()
Call SaveAllAttachments("S:\All\Data", False)
End Sub
Sub SaveAllAttachments(ByVal folderName As String, _
ByVal StripAttachments As Boolean)
' save all attachments from all emails in a folder to a folder on the hard disk
' optionally delete the attachments as well
' check if folder exists, if not then create it
' if folder cannot be created, exit
If Not FolderExists(folderName) Then
On Error Resume Next
MkDir folderName
If Err <> 0 Then Exit Sub
On Error GoTo 0
End If
' check that folderName ends with "\"
If Right$(folderName, 1) <> "\" Then
folderName = folderName & "\"
End If
' get default Inbox items collection
Dim olFldr As Outlook.MAPIFolder
Dim itms As Outlook.Items
Set olFldr = Outlook.GetNamespace("MAPI").PickFolder
If olFldr Is Nothing Then Exit Sub
Set itms = olFldr.Items
' create subset of items collection
Dim newItems As Outlook.Items
Set newItems = itms.Restrict("[Attachment] > 0")
' if there are no messages with attachments, exit
If newItems.Count = 0 Then
RmDir folderName
Exit Sub
End If
' loop through items subset, save all attachments to disk folder
Dim Msg As Outlook.MailItem
Dim MsgAttach As Outlook.Attachments
Dim attachmentNumber As Integer
For Each Msg In newItems
Set MsgAttach = Msg.Attachments
For attachmentNumber = MsgAttach.Count To 1 Step -1
MsgAttach.Item(attachmentNumber).SaveAsFile _
folderName & Format(Msg.ReceivedTime, "mmddyyyy_") & MsgAttach.Item(attachmentNumber).Filename
' delete attachment (optional)
If StripAttachments Then
MsgAttach.Item(attachmentNumber).Delete
End If
Next attachmentNumber
Next Msg
End Sub
Private Function GetDefaultFolder(outlookFolder As OlDefaultFolders) As _
Outlook.MAPIFolder
' returns MAPIFolder object from default folder list to calling program
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set GetDefaultFolder = olNS.GetDefaultFolder(outlookFolder)
End Function
Function FolderExists(ByVal strPath As String) As Boolean
On Error Resume Next
FolderExists = ((GetAttr(strPath) And vbDirectory) = vbDirectory)
End Function