How to save specific incoming messages to the local hard drive programmatically
or
How to save an outlook folder to a local hard drive programmatically
either or works for me
The simplest way to save emails is using Outlook Rule + simple vba Script
Example
Option Explicit
Public Sub Save_Example(Item As Outlook.MailItem)
Dim Path As String
Dim FileName As String
Path = "C:\Temp\"
If Item.Subject = "Hello" Then
FileName = "Bla Bla" & ".msg"
Item.SaveAs Path & FileName, olMsg
End If
End Sub
Related
I completely lost my VBA touch, anyone that can help, I greatly appreciate it.
For outlook desktop I want to a rule that automatically moves item to a folder, marks it as read and calls a script. ( I managed to do that )
How to enable script in outlook 2016: https://www.slipstick.com/outlook/rules/outlooks-rules-and-alerts-run-a-script/
For the subroutine to be seen by Rule Wizard, the argument must by type MailItem.
The script I want to run, is to save the message identified by the rule to disk as a txt file, and for that I am using:
In the module "ThisOutlookSession" the following code ( found it on Outlook VBA macro for saving emails copies in a local folder ) :
Public Sub SaveToDiskScript(Item As Outlook.MailItem)
Const olMsg As Long = 0 '0=Text format (.txt) -> https://learn.microsoft.com/en-us/office/vba/api/outlook.olsaveastype
Dim m As MailItem
Dim savePath As String
Set m = Item
savePath = "C:\Users\im.a.pretty.user\Desktop\StorageFolder\"
savePath = savePath & m.Subject & Format(Now(), "yyyy-mm-dd-hhNNss")
savePath = savePath & ".txt"
m.SaveAs savePath, olMsg
End Sub
Thank you
The file path passed to the SaveAs method of the MailItem class is built based on the Subject line which may contain forbidden symbols:
savePath = "C:\Users\im.a.pretty.user\Desktop\StorageFolder\"
savePath = savePath & m.Subject & Format(Now(), "yyyy-mm-dd-hhNNss")
savePath = savePath & ".txt"
I'd recommend checking whether it contains any forbidden symbols before, see What characters are forbidden in Windows and Linux directory names? for more information.
Also you may try to specify a different folder without dots in the file path.
I receive 4 weekly emails from 3 different senders.
Emails 1 and 2 are from the same sender and can be recognized through VBA. These emails contain zip files, where each zip file has one .csv file.
Emails 3 and 4 can also be recognized by VBA and the attachments are Excel sheets (.xlsx).
I want to extract and unzip (where needed) and save these 4 files in a folder as; email1.report, email2.report etc.
Then make a copy of these 4 files in a different folder for each file and rename like; "Today's date".email1.report.csv etc.
I want to combine these steps in a single code and to replace the email1.report, email2.report etc., files without a prompt asking "do you want to replace the files? Yes, No?"
Is it possible to detect the new weekly emails and do this automatically?
The code I use to unzip and save:
Else
For Each Atmt In Item.Attachments
If Right(Atmt.FileName, 3) = "zip" Then
FileNameFolder = "C:\Users\..."
FileName = FileNameFolder & Left(Atmt.FileName, (InStr(1, Atmt.FileName, ".zip") - 1)) & ".txt"
Atmt.SaveAsFile FileName
FileNameT = FileNameFolder & Atmt.FileName
Name FileName As FileNameT
Set oApp = CreateObject("Shell.Application")
oApp.NameSpace((FileNameFolder)).CopyHere oApp.NameSpace((FileNameT)).Items
Kill FileNameT
i = i + 1
End If
Next Atmt
'item.Close
End If
I won't develop the code for your specific problem, but I recently wrote something similar. Maybe you can go from here by altering to your criteria etc.
In my case I had two e-mails incoming shortly after another, within 60 seconds. Both mails had "FP" in their subject and a .pdf-attachment. The task was to concatenate these attachments using the installed PDF24, which luckily offers a shell command for this.
This was the code, placed in the "ThisOutlookSession" of the Outlook VBA project explorer.
Public btAttachmentMails As Byte
Public dtArrivalStamp As Date
Public strPathFirstMailAttachment As String
Private WithEvents inboxItems As Outlook.Items
Private Sub Application_Startup()
Dim outlookApp As Outlook.Application
Dim objectNS As Outlook.NameSpace
Set outlookApp = Outlook.Application
Set objectNS = outlookApp.GetNamespace("MAPI")
Set inboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub inboxItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
If TypeName(Item) = "MailItem" Then
Dim i As Integer
Dim strDocumentsFolder As String
strDocumentsFolder = CreateObject("WScript.Shell").SpecialFolders(16)
strPathFirstMailAttachment = strDocumentsFolder & "\attachment_mail1.pdf"
If Item.Subject Like "FP*" Then
If btAttachmentMails = 0 Then
'first mail -> save attachment and set counter to 1
btAttachmentMails = 1
dtArrivalStamp = Time
For i = 1 To Item.Attachments.Count
If InStr(Item.Attachments.Item(i).DisplayName, ".PDF") > 0 Then
Item.Attachments.Item(i).SaveAsFile strPathFirstMailAttachment
End If
Next i
ElseIf btAttachmentMails = 1 Then
Dim dtNow As Date: dtNow = Time
If TimeDiff(dtArrivalStamp, dtNow) <= 60 Then
'second mail within 60 seconds with subject containing "FP" -> save attachment and concatenate both via pdf24, then delete both files
'save attachment of second mail
Dim strPathSecondMailAttachment As String
strPathSecondMailAttachment = strDocumentsFolder & "\attachment_mail2.pdf"
For i = 1 To Item.Attachments.Count
If InStr(Item.Attachments.Item(i).DisplayName, ".PDF") > 0 Then
Item.Attachments.Item(i).SaveAsFile strPathSecondMailAttachment
End If
Next i
'concatenate pdf documents via pdf24 shell
Dim strOutputPath As String
strOutputPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & Year(Date) & Month(Date) & Day(Date) & "_Wartungsplan_" & Replace(CStr(Time), ":", "-") & ".PDF"
Shell ("""C:\Program Files (x86)\PDF24\pdf24-DocTool.exe"" -join -profile ""default/good"" -outputFile " & strOutputPath & " " & strPathFirstMailAttachment & " " & strPathSecondMailAttachment)
'inform user
MsgBox ("Files have been successfully concatenated. You can find the combined file on your desktop.")
'reset status, delete temporary documents
btAttachmentMails = 0
If CreateObject("Scripting.FileSystemObject").fileexists(strPathFirstMailAttachment) Then Kill strPathFirstMailAttachment
If CreateObject("Scripting.FileSystemObject").fileexists(strPathSecondMailAttachment) Then Kill strPathSecondMailAttachment
Else
'second mail did not arrive within 60 seconds -> treat as first mail
'save new arrival time and overwrite old firstMailAttachment with this one
dtArrivalStamp = Time
For i = 1 To Item.Attachments.Count
If InStr(Item.Attachments.Item(i).DisplayName, ".PDF") > 0 Then
Item.Attachments.Item(i).SaveAsFile strPathFirstMailAttachment 'overwrites existing file
End If
Next i
End If
End If
End If
End If
ExitNewItem:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description & " - please contact XY"
Resume ExitNewItem
End Sub
Function TimeDiff(StartTime As Date, StopTime As Date)
TimeDiff = Abs(StopTime - StartTime) * 86400
End Function
cr44sh has posted an answer while I was creating mine. He has recommended using a new item event while I have recommended using a rule. I prefer rules but you can choose which ever approach you favour.
It is impossible to fully answer your question but I believe I can give enough help for you to construct the macros you need yourself.
You say that these emails can be identified with VBA. That suggests the best approach is an Outlook rule which uses the “run a script” option where “run a script” means “run a macro”. I will discuss the rule later but first you need the macros that will be run.
You will need two macros like this:
Public Sub Type1Email(ByRef ItemCrnt As MailItem)
' Relevant code
End Sub
Public Sub Type2Email(ByRef ItemCrnt As MailItem)
' Relevant code
End Sub
I am sure you can create better names for these macros. I have read that macros to be run by a rule must be in ThisOutlookSession. In my experience, they can be in an ordinary module providing they are declared as Public. I only use ThisOutlookSession for code that has to be in that code area. If code can be in a module, that is where I place it. I suggest creating a new module which will be named Module1 or Module2. Use function key F4 to access its properties and rename it as “ModRuleMacros” or similar. Giving modules meaningful names makes it so much easier to find the code you want to look at today.
Although the aim is to create a macro to be run by a rule, you need a way of testing the macro. If you have some of these emails saved somewhere, you can activate the rule by moving one of those emails to Inbox. However, I generally find it easier to use a macro like this:
Sub TestType1Email()
Dim Exp As Explorer
Dim ItemCrnt As MailItem
Set Exp = Outlook.Application.ActiveExplorer
If Exp.Selection.Count = 0 Then
Call MsgBox("Pleaase select one or more emails then try again", vbOKOnly)
Exit Sub
Else
For Each ItemCrnt In Exp.Selection
Call Type1Email(ItemCrnt)
Next
End If
End Sub
To use this macro, you select one or more Type1 emails and then run macro TestType1Email. This macro will pass the selected emails, one at a time, to the macro Type1Email. This will allow you to single step through macro Type1Email and ensure that it works to your entire satisfaction. I find this to be the easier method of testing a new Outlook macro.
It may be helpful to check what a rule can do for you. Select one of these emails and then click on Rules, which is in the middle of the Home tab, and then Create rule …. Selecting one of these emails means the first window is filled out with some options. Click Advanced options …. The new window lists all the options for selecting an email. Are all the options you need to select a type 1 or a type 2 email listed? The list is comprehensive but not complete. For example, you cannot select by the presence of attachments. Identify the options you can use and identify the options you need that are missing. Click Cancel twice to exist from rule creation.
You will need include code for any missing options in your macro.
Your question implies you have all the code you need for processing the emails except for suppressing the replace question. You need to check if there is an existing file before creating the new file. This is the routine that I use to check if a file exists:
Public Function FileExists(ByVal PathName As String, ByVal FileName As String) As Boolean
' Returns True if file exists. Assumes path already tested.
' Coded by Tony Dallimore
' Based on code written by iDevlop: http://stackoverflow.com/a/28237845/973283
' Ensure only one "\" between path and filename
If Right$(PathName, 1) <> "\" Then
PathName = PathName & "\"
End If
If Left$(FileName, 1) = "\" Then
FileName = Mid$(FileName, 2)
End If
FileExists = False
On Error Resume Next
FileExists = ((GetAttr(PathName & FileName) And vbDirectory) <> vbDirectory)
On Error GoTo 0
End Function
If the file exists, you can:
Use VBA statement Kill (https://learn.microsoft.com/en-gb/office/vba/Language/Reference/user-interface-help/kill-statement) to delete the old file.
Use VBA statement Name (https://learn.microsoft.com/en-gb/office/vba/language/reference/user-interface-help/name-statement) to move the old file to another folder or rename it perhaps by adding a date at the beginning of the name.
I favour the second option because I do not like deleting a file until I am really, really sure I will not need it again. I saw too many situations during my career where a file deleted as no longer needed was found to be incorrectly or incompletely processed a few months later.
Once you have fully tested the macros, you can create the rules to execute them. For each type of email:
Select an email of the required type.
Click on Rules and then Create rule ….
Tick any relevant boxes on the first window.
Click Advanced options ….
Tick all relevant boxes on the second window.
Click Next.
Tick the box against “Run a script”.
Click a script.
You will be shown a list of all the macros that can be run from a rule. Select the required macro.
Click Next.
Tick the box against any appropriate exceptions and enter any additional information required.
Click Next.
Name the rule. Tick “run this rule against any messages already in Inbox” if required. Review the rule and edit if necessary.
Click Finish.
I hope the above is enough to plug the holes in your knowledge.
I want to add the sender's name of every incoming email to the saved attachment item, by storing into a variable so I can use it later, to return the email to that name or email address.
The code below first creates a counter for every item on a folder and rename the file with the date and the original attachment as follows: "2016-01-29 1026 1 POCreation" - the number 1 before the "POCreation" is the counter.
Then I save the attachment by running a rule in Outlook to run below script - as you might be aware - and save the attachment name by using the objAtt.DisplayName
So basically I want to get the name of the sender or the email of the sender stored on a variable. All the forums that I visit, even here, explained that they go to the "MAPI" folder to read all the emails in there but I am thinking that perhaps I can get it straight just like using the .displayname.
I tried to use mailitem.sendername but this throws an error of object not found, I guess is not reading it from the incoming email. I am running this into a module of Outlook.
Public Sub pdf(itm As Outlook.MailItem)
Dim FolderPath As String, path As String, count As Integer
FolderPath = "C:\Users\esacahui\Documents\POS\received"
path = FolderPath & "\*.xlsm"
FileName = Dir(path)
Do While FileName <> ""
count = count + 1
FileName = Dir()
Loop
' that was the counter, now is the save attachment
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "C:\Users\esacahui\Documents\POS\received"
Dim dateFormat As String
dateFormat = Format(itm.ReceivedTime, "yyyy-mm-dd Hmm")
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & "\" & dateFormat & " " & count & " " & objAtt.DisplayName
Next
End Sub
itm.senderEmailAddress will get you the email address of the sender.
You can use the following properties of the MailItem class:
SenderEmailAddress - a string that represents the e-mail address of the sender of the Outlook item.
SenderName - a string indicating the display name of the sender for the Outlook item.
See How to: Get the SMTP Address of the Sender of a Mail Item for more information.
I need to add text string to all files on a folder, as a footer
For example, on the folder on the path and called C:\mobatchscripts\
I have a random number of txt files, with text.
I want to add a line for example "text" on each of the text files on the folder
I have little knowledge of vba programming, but for what I have read I can use append, but I need something that loop on the files on the folder, and modify them.
So far I tried this:
Sub footer()
Dim FolderPath As String
Dim FileName As String
Dim wb As Excel.Workbook
FolderPath = "C:\mobatchscripts\"
FileName = Dir(FolderPath)
Do While FileName <> ""
Open FileName For Append As #1
Print #1, "test"
Close #1
FileName = Dir
Loop
End Sub
But seems that its not looking into the files, or appending the text.
On the assumption that you're writing to text files (I see "batchscripts" in the path), you need a reference to the Microsoft Scripting Runtime (Within the VBE you'll find it in Tools, References)
Option Explicit
Public Sub AppendTextToFiles(strFolderPath As String, _
strAppendText As String, _
blnAddLine As Boolean)
Dim objFSO As FileSystemObject
Dim fldOutput As Folder
Dim filCurrent As File
Dim txsOutput As TextStream
Set objFSO = New FileSystemObject
If objFSO.FolderExists(strFolderPath) Then
Set fldOutput = objFSO.GetFolder(strFolderPath)
For Each filCurrent In fldOutput.Files
Set txsOutput = filCurrent.OpenAsTextStream(ForAppending)
If blnAddLine Then
txsOutput.WriteLine strAppendText
Else
txsOutput.Write strAppendText
End If
txsOutput.Close
Next
MsgBox "Wrote text to " & fldOutput.Files.Count & " files", vbInformation
Else
MsgBox "Path not found", vbExclamation, "Invalid path"
End If
End Sub
I'd recommend adding error handling as well and possibly a check for the file extension to ensure that you're writing only to those files that you want to.
To add a line it would be called like this:
AppendTextToFiles "C:\mobatchscripts", "Test", True
To just add text to the file - no new line:
AppendTextToFiles "C:\mobatchscripts", "Test", False
Alternatively, forget the params and convert them to constants at the beginning of the proc. Next time I'd recommend working on the wording of your question as it's not really very clear what you're trying to achieve.
I have a vbscript macro that I'm using in Outlook. It moves a mailitem to some folder, say X. After I run the macro and I try to manually move a mailitem from Outlook with Control-v, it defaults to folder X. I would like Control-v to default to the folder that it would have used before I ran the macro.
Is there some way in VBScript to find out what folder the last mailitem was move to, and to return that to be the default folder after I run my script? Or is there a way to move a mailitem in my script without the destination folder being remembered by Outlook Control-v after I run the script?
Thanks for any hints.
OK, here is the code I'm using. It is a macro to save a mailitem as HTML and open it in a browser. I save any attachments in a separate directory and I add in a list of URLs to the attachments. I do this by modifying the mailitem, but I don't want change the original message - I want it to remain in my inbox as it was. So I create a copy and when I'm done I want to get rid of the copy. For some reason the .Delete method just doesn't do anything. So, one solution for me would be to figure out why .Delete is not working. I created a work-around by just moving the copied message into my deleted items folder. The problem I have with this is that I often use control-v to move items from my inbox to an archive folder. Once I run the macro, though, the default folder for control-v is the deleted item folder. I keep archiving items there by mistake. So the best solution would be to get .Delete working, but even then, that might change the control-v default behavior after running the macro.
Here's the code. I've only been doing vba for a couple of days, so any tips on things I'm missing appreciated.
Option Explicit
Sub CreateHTML()
Select Case TypeName(Outlook.Application.ActiveWindow)
Case "Inspector"
CreateHTMLfromObject Outlook.Application.ActiveInspector.CurrentItem
Case "Explorer"
Dim objItem As Object
For Each objItem In Outlook.Application.ActiveExplorer.Selection
CreateHTMLfromObject objItem
Next
End Select
End Sub
Sub CreateHTMLfromObject(objItem As Object)
' For now, assume all items are mail items
'Select Case objItem.Class
'Case olMail
Dim objMailOrig As MailItem
Dim objMailCopy As MailItem ' Work on a copy of the message
Set objMailOrig = objItem
Set objMailCopy = objMailOrig.copy
' Where all HTML versions of messages will be stored
Dim fileDir As String
fileDir = "C:\Lib\olHTML\"
' A unique message id from the original message
Dim MsgId As String
MsgId = objMailOrig.EntryID
' The file the HTML version of the message will be stored in
Dim fileName As String
fileName = MsgId & ".html"
' The full file system path where the HTML verison of the message will be stored
Dim filePath As String
filePath = fileDir & fileName
' ---------------------------------------------------------------
' Save Attachments
' ---------------------------------------------------------------
' Subdirectory for attachments on this message
' A unique subdirectory for each message
Dim atmtDir As String
atmtDir = MsgId & "_atmt\"
' Full file system path to the attachment directory
Dim atmtDirPath As String
atmtDirPath = fileDir & atmtDir
' File system object for creating the attachment folder
Dim oFSO
Set oFSO = CreateObject("Scripting.FileSystemObject")
If (objMailCopy.Attachments.Count > 0) And (Not oFSO.FolderExists(atmtDirPath)) Then
oFSO.CreateFolder (atmtDirPath)
End If
' To hold the full file system path to each attachment file
Dim atmtFilePath As String
' String to accumulate HTML code for displaying links to attachments
' in the body of the HTML message
Dim atmtLinks As String
atmtLinks = " "
Dim atmt As Attachment
For Each atmt In objMailCopy.Attachments
atmtFilePath = atmtDirPath & atmt.fileName
atmt.SaveAsFile atmtFilePath
' create a relative URL
atmtLinks = atmtLinks & _
"<br><a href='" & atmtDir & atmt.fileName & "'>" & atmt.fileName & "</a>"
Next atmt
' ---------------------------------------------------------------
' Add links to attachments
' ---------------------------------------------------------------
' This changes the original message in Outlook - so we work on a copy
' Convert body to HTML if RTF, Text or other format
If (objMailCopy.BodyFormat = olFormatPlain Or olFormatRichText Or olFormatUnspecified) Then
objMailCopy.BodyFormat = olFormatHTML
End If
' Add attachments links at the beginning
If objMailCopy.Attachments.Count > 0 Then
objMailCopy.HTMLBody = _
"<p>" & "Attachments: " & atmtLinks & "</p>" & objMailCopy.HTMLBody
End If
' ---------------------------------------------------------------
' Save the HTML message file
' ---------------------------------------------------------------
objMailCopy.SaveAs filePath, olHTML
' ---------------------------------------------------------------
' Delete the copy from Outlook
' ---------------------------------------------------------------
'! This seems to have no effect
' objMailCopy.Delete
' Move copied message to deleted items folder
objMailCopy.Move Outlook.Application.GetNamespace("MAPI").GetDefaultFolder(olFolderDeletedItems)
' ---------------------------------------------------------------
' Open the HTML file with default browser
' ---------------------------------------------------------------
Dim url As String
url = "file:///" & filePath
CreateObject("WScript.Shell").Run (url)
End Sub
i would not make a copy in the inbox and delete that afterwards (that will make your deleted-folder explode one day), but make your changes in the local copy of the message-file:
here an example:
Sub changelocalcopy(olitem As Outlook.MailItem)
Dim oNamespace As Outlook.NameSpace
Set oNamespace = Application.GetNamespace("MAPI")
Dim oSharedItem As Outlook.MailItem
Dim pfaddatei As String
pfaddatei = c:\test.msg 'path for your local copy here
olitem.SaveAsFile pfaddatei
Set oSharedItem = oNamespace.OpenSharedItem(pfaddatei)
'now do your changes
'you will not want the following line, I leave it here in case you Need it:
Kill pfaddatei
oSharedItem.Close (olDiscard)
Set oSharedItem = Nothing
Set oNamespace = Nothing
End Sub