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.
Related
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!!!
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)
I have some VBA code that actually works fine on my machine, but not my clients. Where it gets hung up is the opening of an email attachment and saving it to a location on his computer.
For Each nm in file_names 'file_names is just an array of strings
found_file=False
curr_date=CDate("1-1-9999")
For Each olItem in olItems
If olItem.ReceivedTime < curr_date and olItem.SenderEmailAddress=email and TypeName(olItem)="MailItem" then
Set olAttach=olItem.attachments.Item(1)
If not olAttach is Nothing then
If olAttach.Filename Like nm & ".*" then
found_file=True
curr_date=olItem.ReceivedTime
end if
end if
end if
Next
If found_file then
olAttach.SaveAsFile pth & olAttach.Filename 'errors out here
...
The error message is Cannot save the attachment and does not specify a reason.
I have tried to have him enable all macros, switch off protected view options, restart excel and outlook, try different file locations to save to, there are no double \ that occur when file path is concatenated with the file name, and I made sure he wasn't using a Mac. Apparently one of the attachment files does open but it just refuses to save.
Looks like the file path/name string passed to the SaveAsFile method is not a well-formed path. For example, the FileName may contains forbidden symbols and etc. Try to use the following code as a test:
Sub SaveAttachment()
Dim myInspector As Outlook.Inspector
Dim myItem As Outlook.MailItem
Dim myAttachments As Outlook.Attachments
Set myInspector = Application.ActiveInspector
If Not TypeName(myInspector) = "Nothing" Then
If TypeName(myInspector.CurrentItem) = "MailItem" Then
Set myItem = myInspector.CurrentItem
Set myAttachments = myItem.Attachments
'Prompt the user for confirmation
Dim strPrompt As String
strPrompt = "Are you sure you want to save the first attachment in the current item to the Documents folder? If a file with the same name already exists in the destination folder, it will be overwritten with this copy of the file."
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
myAttachments.Item(1).SaveAsFile Environ("HOMEPATH") & "\My Documents\" & _
myAttachments.Item(1).DisplayName
End If
Else
MsgBox "The item is of the wrong type."
End If
End If
End Sub
I'm having trouble with automatically exporting the body of an email into a text file using a script.
I've managed a script that will save the text into a file on a macro but that won't work on a rule which is what I need.
My current code is as follows:
Sub SaveAsTXT()
Dim myItem As Outlook.Inspector
Dim objItem As Object
Dim myFolder As Folder
Set myItem = Application.ActiveInspector
If Not TypeName(myItem) = "Nothing" Then
Set myNamespace = Application.GetNamespace("MAPI")
Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox)
Set objItem = myItem.CurrentItem
strname = objItem.Subject
strdate = Format(objItem.ReceivedTime, " yyyy mm dd")
objItem.SaveAs "c:\users\philip\documents\" & strname & strdate & ".txt", olTXT
End If
End Sub
Apologies if it looks a bit messy, I've edited it countless times trying to get it to work.
That's the code that will correctly run when I'm in the open email and run it as a macro but it won't work correctly when run as a rule
I have tried amending to Sub SaveAsTXT(Item as Outlook.Mailitem) but this also doesn't seem to work
So basically the question is how to I ensure the code will select the email (which will always be entitled "Rotas" without quotes) when it is run as a rule?
Info: Using office 2010 and I'm not a very good coder to start with.
Actually I managed to sort it out myself.
I didn't consider that the item as Outlook.Mailitem element was actually the thing that was selected by the rule. So I applied item as the object rather than objItem
Find the successful (and cleaned up) code below:
Sub SaveAsTXT(myMail As Outlook.MailItem)
Dim objItem As Object
Dim myFolder As Folder
If Not TypeName(myitem) = "Nothing" Then
If myMail.Subject = "Rotas" Then
strname = myMail.Subject
strdate = Format(myMail.ReceivedTime, " yyyy mm dd")
myMail.SaveAs "c:\users\philip\documents\" & strname & ".txt", olTXT
End If
End If
End Sub
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.