Every day we receive an email with several text file attachments. I want to download the attachments to a folder on the server, and then move the email to a subfolder in Outlook.
I found a script for downloading and saving the attachment and attached it to a rule. It works but I can't use the rules to then move the email to a subfolder as it automatically inserts the move before the download.
The alternative is to make the script more complex by combining the download and the move into one script.
I found several sample codes for moving messages but I need the rule to move only messages that have txt file attachments and from a specific email address and I don't have the capability to adapt that.
Public Sub SaveAutoAttach(item As Outlook.MailItem)
Dim object_attachment As Outlook.Attachment
Dim saveFolder As String
saveFolder = "P:\Shared Works\Catch Reports"
For Each object_attachment In item.Attachments
If InStr(object_attachment.DisplayName, ".txt") Then
object_attachment.SaveAsFile saveFolder & "\" & object_attachment.DisplayName
End If
Next
End Sub
Code I found searches through an entire folder for matching criteria and then moves the message. I need the existing code to move the item that has been identified in the existing script.
After your code saves your attachment and exits the For Each/Next loop, first define your move-to folder (I have assumed that your folder is called MyFolder and is a subfolder within your default inbox)...
Dim saveToFolder As Outlook.MAPIFolder
Set saveToFolder = Outlook.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("MyFolder") 'change the name of your destination folder accordingly
Then you can simply save your email item as follows...
item.Move saveToFolder
OMG, it works!! I had the definitions set in the wrong part of the code. Final result is:
Public Sub SaveAutoAttach(item As Outlook.MailItem)
Dim object_attachment As Outlook.Attachment
Dim saveFolder As String
Dim DestFolder As Outlook.Folder
' Folder location when I want to save my file
saveFolder = "P:\Shared Works\Catch Reports"
For Each object_attachment In item.Attachments
Dim saveToFolder As Outlook.MAPIFolder
Set saveToFolder = Outlook.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("Catch Reports") 'change the name of your destination folder accordingly
If InStr(object_attachment.DisplayName, ".txt") Then
object_attachment.SaveAsFile saveFolder & "\" & object_attachment.DisplayName
End If
Next
item.Move saveToFolder
End Sub
Thank you very much Domenic!!!
Related
I'm kind of baffled as to why a script that has run seamlessly for me in the past is now throwing an error when triggered through an Outlook Rule. The intent behind this script is to save the email attachment in a specified folder and loop through the items in that same folder to delete any files from previous dates as well as any image files.
Script is as follows:
Public Sub SaveSalesForceReports(MItem As Outlook.MailItem)
Dim oAttachment As Outlook.Attachment
Dim sSaveFolder As String
Dim sdate As Variant
sSaveFolder = "C:\Users\A6QDCZZ\Documents\SFReporting\Subscribed_Reports\" 'specify the folder where we will store our attachements that have been downloaded from the subscribed email reports
For Each oAttachment In MItem.Attachments
sdate = MItem.SentOn
If Format(sdate, "DD-MM-YYYY") = Format(Date, "DD-MM-YYYY") Then
oAttachment.SaveAsFile sSaveFolder & oAttachment.FileName
End If
Next oAttachment
Dim objFSO, objFolder, objfile As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(sSaveFolder)
For Each objfile In objFolder.Files 'deletes older reports and clears extraneous files that may have been downloaded from the email
If Format(objfile.DateCreated, "DD-MM-YYYY") <> Format(sdate, "DD-MM-YYYY") Then
Kill objfile
ElseIf InStr(Dir(objfile), ".png") > 1 Then
Kill objfile
End If
Next objfile
End Sub
For some reason unbeknownst to me, I'm now getting the following error:
Can anyone help me understand what's happening?
Sincerely Appreciated!
An outlook update disabled the capability to run scripts.
There is a registry hack that allows you to re-enable it as per this:
https://www.slipstick.com/outlook/rules/outlooks-rules-and-alerts-run-a-script/
If you have done that, then you may need to edit the rule and check that the script is still listed there. Even if it is, I would try to edit the rule and reselect the macro to run.
I have some experience with VBA in Excel, but taking my first steps in Outlook. I need to save all e-mail messages in a designated Outlook folder (Inbox\input) to disk (D:\myArchive\Email\) as .msg files and move mail item to archive folder in Outlook (Inbox\archive).
I have set up a mail rule in Outlook that moves mail to archive folder and runs a script below which actually does what I need. The problem is that I get mail rule error pop-ups occasionally and I struggle to track down the reason. Hence looking to turn away from Outlook mail rule and cycle through all folder contents "on-demand".
How could I convert it to cycle through Outlook folder as well as displace the mail item? Currently running Outlook 2019. Thanks!
edit: sorry, late clarification - target folder is in another mailbox (Office 365 shared mailbox). How to target a different account?
Public Sub saveEmailtoDisk(itm As Outlook.MailItem)
Dim saveFolder, msgName1, msgName2 As String
saveFolder = "D:\myArchive\Email\"
msgName1 = Replace(itm.Subject, ":", "")
msgName2 = Replace(msgName1, "/", "_")
itm.SaveAs saveFolder & msgName2 & ".msg", olMSG
End Sub
The following code assumes that both the input and archive folders are located within the default inbox.
Public Sub saveAndArchiveInputEmails()
Dim saveFolder As String
saveFolder = "D:\myArchive\Email\"
Dim sourceFolder As Folder
Dim destFolder As Folder
With Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set sourceFolder = .Folders("input")
Set destFolder = .Folders("archive")
End With
Dim itm As Object
Dim i As Long
With sourceFolder
For i = .Items.Count To 1 Step -1
Set itm = .Items(i)
If TypeName(itm) = "MailItem" Then
saveEmailtoDisk saveFolder, itm
itm.Move destFolder
End If
Next i
End With
End Sub
Public Sub saveEmailtoDisk(ByRef saveFolder As String, ByVal itm As Object)
Dim msgName1, msgName2 As String
msgName1 = Replace(itm.Subject, ":", "")
msgName2 = Replace(msgName1, "/", "_")
itm.SaveAs saveFolder & msgName2 & ".msg", olMSG
End Sub
EDIT
For a shared mailbox, try the following instead...
With Application.GetNamespace("MAPI")
Dim sharedEmail As Recipient
Set sharedEmail = .CreateRecipient("someone#abc.com")
Dim sourceFolder As Folder
Set sourceFolder = .GetSharedDefaultFolder(sharedEmail, olFolderInbox).Folders("input")
Dim destFolder As Folder
Set destFolder = .GetSharedDefaultFolder(sharedEmail, olFolderInbox).Folders("archive")
End With
For your default inbox...
Dim myInbox As Folder
Set myInbox = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Ever day at 12 am there is an automatic email with an excel attachment from a vendor service with a specific subject. I am using rules and code to attempt to save the attachment and insert the information into a database I have created upon being received in the inbox.
I have tried code that I have found online however I don't know if doesn't work because of some network/ security setting my company has or if its he code it self.
Rule:
CODE:
Public Sub CribMaster2Database(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "c:\temp\"
If olItem.Subject = "Test" Then
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName
Set objAtt = Nothing
Next
End If
End Sub
Add code to the ThisOutlookSession to watch your folder for arrivals.
CribMaster_ItemAdd fires whenever something arrives in your watched folder.
At the very top of the module:
Dim WithEvents CribMaster As Items
Const SAVE_PATH As String = "c:\temp\"
Private Sub Application_Startup()
Dim ns As Outlook.NameSpace
Set ns = GetNamespace("MAPI")
'Change `holi4683` to the name of your account
'(should be visible just above your inbox).
Set CribMaster = ns.Folders.Item("holi4683") _
.Folders.Item("Inbox").Items
End Sub
Sub CribMaster_ItemAdd(ByVal Item As Object)
Dim olAtt As Attachment
Dim i As Integer
With Item
For i = 1 To .Attachments.Count
Set olAtt = .Attachments(i)
olAtt.SaveAsFile SAVE_PATH & olAtt.DisplayName
.UnRead = False
DoEvents
Next i
End With
Set olAtt = Nothing
End Sub
I'd usually use a rule to move the emails to a subfolder and watch that folder - means I don't have to worry about meeting invites, etc.
To do this you'd change your watched folder like this:
Set CribMaster = ns.Folders.Item("holi4683") _
.Folders.Item("Inbox") _
.Folders.Item("SubFolder").Items
Restart Outlook for the code to work, or manually run the Application_Startup() procedure.
I am looking to set up a one drive folder that will hold reports for our companies various clients. Our reporting software only sends to email rather than saving to file so I've googled and found this piece of code to automatically download all attachments to a folder
Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim dateFormat
dateFormat = Format(Now, "yyyy-mm-dd H-mm")
saveFolder = "C:\Report Attachments\"
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & "\" & dateFormat & objAtt.DisplayName
Set objAtt = Nothing
Next
End Sub
The issue is that I want to split the reports by company. for example, I want reports for Company A to go to
C:\Report Attachments\Company A
and reports for company B to go to
C:\Report Attachments\Company B
and so on. Each report should have the companies name in the title of attachment so I'm looking for a tweak to the code to change the save location based on the attachment title. Is this possible?
Set up a rule to move the emails to specific folders when they arrive (probably rule based on the email address domain).
In the ThisOutlookSession module in Outlook enter this code in the declarations section:
Dim WithEvents CompanyA As Items
Dim WithEvents CompanyB As Items
Const COMPA_PATH As String = "C:\Report Attachments\Company A\"
Const COMPB_PATH As String = "C:\Report Attachments\Company B\"
Private Sub Application_Startup()
Dim ns As Outlook.NameSpace
Set ns = Application.GetNamespace("MAPI")
Set CompanyA = ns.Folders.item("Mailbox - tomdemaine") _
.Folders.item("Inbox") _
.Folders.item("CompanyA").Items
Set CompanyB = ns.Folders.item("Mailbox - tomdemaine") _
.Folders.item("Inbox") _
.Folders.item("CompanyA").Items
End Sub
Sub CompanyA_ItemAdd(ByVal item As Object)
Dim oAtt As Attachment
If item.Attachments.Count > 0 Then
For Each oAtt In item.Attachments
item.UnRead = False
'Note DisplayName may contain illegal characters.
oAtt.SaveAsFile COMPA_PATH & oAtt.DisplayName
DoEvents
Next oAtt
End If
Set oAtt = Nothing
End Sub
Sub CompanyB_ItemAdd(ByVal item As Object)
Dim oAtt As Attachment
If item.Attachments.Count > 0 Then
For Each oAtt In item.Attachments
item.UnRead = False
'Note DisplayName may contain illegal characters.
oAtt.SaveAsFile COMPB_PATH & oAtt.DisplayName
DoEvents
Next oAtt
End If
Set oAtt = Nothing
End Sub
The code will start watching your CompanyA & CompanyB folders when you start Outlook. Any time something gets moved there that contains attachments it will save them to your file location and mark the email as read.
I haven't tested the code - and the Outlook folders and file locations will need updating to suit your needs.
Im really new to VBA and need some help. I'm trying to write a VBA script (along with a Outlook rule) to automatically download attachments from daily emails and append the file names with the date that appears in the subject.
This is what the subject line looks like - "Email Alert for Department for 10/20/2014". I just need to isolate the rightmost 10 spaces that indicates the run date of the files.
So I found code online that works to automatically download the attachments and append by current date which does work. See below.
Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim dateFormat
dateFormat = Format(Now, "yyyymmdd ")
saveFolder = "Z:\Daily Emails"
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & "\" & dateFormat & objAtt.DisplayName
Set objAtt = Nothing
Next
End Sub
I also found online that something like this should point to the date (formatted like XX/XX/XXXX and always at the end of the subject line.
Subject = Right(itm.Subject, 10) but im having trouble incorporating it into the code above.
Can anyone help me? It would mean a lot
Thanks!
-Christina
Using Rules to run a macro is good.
I used the same set up before. The problem is if you are to work on the newly received mail, the sub wouldn't trap it. If you need to save the attachment of an incoming email with Email Alert for Department for mm/dd/yyyy as subject, try using an event instead. By default, Outlook doesn't provide Items Event so you'll have to create it.
In your ThisOutlookSession (not in a module) try something like:
Option Explicit
Private WithEvents olIBoxItem As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
'~~> change olFolder depending on what folder you're receiving the email
'~~> I assumed it is Outlook's default folder Inbox
Set olIBoxItem = olFolder.Items
End Sub
Private Sub olIBoxItem_ItemAdd(ByVal Item As Object)
Const strSub As String = "Email Alert for Department for "
If TypeOf Item Is Outlook.MailItem Then
Dim nMail As Outlook.MailItem
Set nMail = Item
If InStr(nMail.Subject, strSub) <> 0 Then
Const savefolder As String = "Z:\Details Mail\"
'~~> Extract your date
Dim dateSub As String: dateSub = Right(nMail.Subject, 10)
'~~> Make sure there is an attachment
If nMail.Attachments.Count > 0 Then
Dim olAtt As Outlook.Attachment
Set olAtt = nMail.Attachments.Item(1) '~~> if you only have 1
Dim attFName As String, addFExt As String
'~~> Get the filename and extension separately
attFName = Split(olAtt.Filename, ".")(0)
attFExt = Split(olAtt.Filename, ".")(1)
'~~> Reconstruct the filename
attFName = savefolder & attFName & " " & dateSub & attFExt
'~~> Save the attachment
olAtt.SaveAsFile attFName
End If
End If
End If
End Sub
So above routine automatically checks any received mail in the Inbox Folder. If the subject contains the specified string. If yes, it automatically saves the attachment.
If however you have more than one attachment, you'll have to look through it and then save each one. It may look confusing at first but you'll get the hang of it for sure. HTH.