Outlook Macro to move PDF attachments to hard drive - vba

My goal is: on incoming email, move any PDF attachments to a hard drive folder with the date appended to the end of it.
I had a macro running with a rule, but the rule constantly errors and turns off, So I am going to put it in This Outlook Session.
I modified this macro that I found to do what I need, however it is giving me the compile error: Next without For.
Thank you for your assistance on this.
Option Explicit
Private WithEvents olInboxItems As Items
Private Sub Application_Startup()
Dim objNS As NameSpace
Set objNS = Application.Session
' instantiate objects declared WithEvents
Set olInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items
Set objNS = Nothing
End Sub
Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
On Error Resume Next
If Item.Attachments.Count > 0 Then
Dim objAttachments As Outlook.Attachments
Dim lngCount As Long
Dim strFile As String
Dim sFileType As String
Dim i As Long
Dim dtDate As Date
Dim sName As String
Dim objMsg As Outlook.MailItem
Dim lcount As Integer
Dim pre As String
Dim ext As String
Dim strFolderpath As String
Set objAttachments = Item.Attachments
lngCount = objAttachments.Count
For i = lngCount To 1 Step -1
If lngCount > 0 Then
dtDate = objMsg.SentOn
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, vbUseSystem)
' Get the file name.
strFile = sName & objAttachments.Item(i).FileName
If LCase(Right(strFile, 4)) = ".pdf" Then
lcount = InStrRev(strFile, ".") - 1
pre = Left(strFile, lcount)
ext = Right(strFile, Len(strFile) - lcount)
' Combine with the path to make the final path
strFile = strFolderpath & pre & "_" & sName & ext
' Get the path to your My Documents folder
strFolderpath = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%USERPROFILE%")
strFolderpath = strFolderpath & "\1 Inbox\"
' Combine with the path to the folder.
strFile = strFolderpath & strFile
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile
Next i
End If
End If
End Sub

You don't need rule, try adding this to OutlookSession then restart your Outlook
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
Save_PDF Item
End If
End Sub
Private Sub Save_PDF(ByVal Item As Object)
Dim Atmts As Outlook.Attachments
Dim intCount As Long
Dim sFileName As String
Dim i As Long
Dim sDate As String
Dim Frmt_Date As String
Dim FolderPath As String
If Item.Attachments.Count > 0 Then
Set Atmts = Item.Attachments
intCount = Atmts.Count
For i = intCount To 1 Step -1
If intCount > 0 Then
sDate = Item.SentOn
Frmt_Date = Format(sDate, "yyyymmdd", vbUseSystemDayOfWeek, vbUseSystem)
' Get the file name.
sFileName = Atmts.Item(i).FileName
If LCase(Right(sFileName, 4)) = ".pdf" Then
' Get the path to your My Documents folder
FolderPath = Environ("USERPROFILE") & "\Documents\1 Inbox\"
' Combine with the FolderPath and FileName_DateSentOn
sFileName = FolderPath & Frmt_Date & "_" & sFileName
' Save the attachment as a file.
Atmts.Item(i).SaveAsFile sFileName
End If
End If
Next i
End If
Set Items = Nothing
Set Atmts = Nothing
End Sub

Related

Save all emails and .msg files in outlook

I've been using a piece of code for awhile to save selected emails as .msg files but I cant figure out what to modify to get it to save all emails:
Option Explicit
Public Sub SaveMessageAsMsg()
Dim oMail As Outlook.MailItem
Dim objItem As Object
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim enviro As String
Dim strFolderpath As String
enviro = CStr(Environ("USERPROFILE"))
strFolderpath = BrowseForFolder(enviro & "\documents\")
For Each objItem In ActiveExplorer.Selection
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem
sName = oMail.Subject
ReplaceCharsForFileName sName, "-"
dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
sPath = strFolderpath & "\"
Debug.Print sPath & sName
oMail.SaveAs sPath & sName, olMSG
End If
Next
End Sub
I know I need to change the For Each objItem In ActiveExplorer.Selection section to include all items but I'm not overly familiar with VB and haven't found what it needs to be replaced with.
I have tried using current folder and a few other options.
Example would be
Option Explicit
Public Sub Example()
Dim olNs As Outlook.NameSpace
Set olNs = Application.Session
Dim Inbox As Outlook.MAPIFolder
Set Inbox = olNs.GetDefaultFolder(olFolderInbox) ' Inbox
' // Process Current Folder
CURRENT_FOLDER Inbox
End Sub
Private Sub CURRENT_FOLDER(ByVal ParentFolder As Outlook.MAPIFolder)
Dim SUBFOLDER As Outlook.MAPIFolder
Dim Items As Outlook.Items
Set Items = ParentFolder.Items
Debug.Print ParentFolder.Name ' Print on Immediate Window
Dim i As Long
For i = Items.Count To 1 Step -1
DoEvents
Debug.Print Items(i).Subject ' Print on Immediate Window
Next
' // Recurse through subfolders
If ParentFolder.Folders.Count > 0 Then
For Each SUBFOLDER In ParentFolder.Folders
CURRENT_FOLDER SUBFOLDER
Next
End If
End Sub
Create a function that takes MAPIFolder as a parameter and loops through all items in the MAPIFolder.Items collection. The function must then call itself recursively for all subfolders in the MAPIFOlder.Folders collection.
Your code above must call that function for all folders in the Application.Session.Folders collection (represents all top level folders in Outlook).
Here is the full code I am using to do what I was needing
Option Explicit
Dim StrSavePath As String
Sub SaveAllEmails_ProcessAllSubFolders()
Dim i As Long
Dim j As Long
Dim n As Long
Dim StrSubject As String
Dim StrName As String
Dim StrFile As String
Dim StrReceived As String
Dim StrFolder As String
Dim StrSaveFolder As String
Dim StrFolderPath As String
Dim iNameSpace As NameSpace
Dim myOlApp As Outlook.Application
Dim SubFolder As MAPIFolder
Dim mItem As MailItem
Dim FSO As Object
Dim ChosenFolder As Object
Dim Folders As New Collection
Dim EntryID As New Collection
Dim StoreID As New Collection
Set FSO = CreateObject("Scripting.FileSystemObject")
Set myOlApp = Outlook.Application
Set iNameSpace = myOlApp.GetNamespace("MAPI")
Set ChosenFolder = iNameSpace.PickFolder
If ChosenFolder Is Nothing Then
GoTo ExitSub:
End If
BrowseForFolder StrSavePath
Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)
For i = 1 To Folders.Count
StrFolder = StripIllegalChar(Folders(i))
n = InStr(3, StrFolder, "\") + 1
StrFolder = Mid(StrFolder, n, 256)
StrFolderPath = StrSavePath & "\" & StrFolder & "\"
StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"
If Not FSO.FolderExists(StrFolderPath) Then
FSO.CreateFolder (StrFolderPath)
End If
Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
On Error Resume Next
For j = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(j)
StrReceived = Format(mItem.ReceivedTime, "YYYYMMDD-hhmm")
StrSubject = mItem.Subject
StrName = StripIllegalChar(StrSubject)
StrFile = StrSaveFolder & StrReceived & "_" & StrName & ".msg"
StrFile = Left(StrFile, 256)
mItem.SaveAs StrFile, 3
Next j
On Error GoTo 0
Next i
ExitSub:
End Sub
Function StripIllegalChar(StrInput)
Dim RegX As Object
Set RegX = CreateObject("vbscript.regexp")
RegX.Pattern = "[\" & Chr(34) & "\!\#\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
RegX.IgnoreCase = True
RegX.Global = True
StripIllegalChar = RegX.Replace(StrInput, "")
ExitFunction:
Set RegX = Nothing
End Function
Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As MAPIFolder)
Dim SubFolder As MAPIFolder
Folders.Add Fld.FolderPath
EntryID.Add Fld.EntryID
StoreID.Add Fld.StoreID
For Each SubFolder In Fld.Folders
GetFolder Folders, EntryID, StoreID, SubFolder
Next SubFolder
ExitSub:
Set SubFolder = Nothing
End Sub
Function BrowseForFolder(StrSavePath As String, Optional OpenAt As String) As String
Dim objShell As Object
Dim objFolder ' As Folder
Dim enviro
enviro = CStr(Environ("USERPROFILE"))
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Please choose a folder", 0, enviro & "\Documents\")
StrSavePath = objFolder.self.Path
On Error Resume Next
On Error GoTo 0
ExitFunction:
Set objShell = Nothing
End Function

Saving msg to local folder using illegal characters in file name

I have the following code to save emails from Outlook to a folder on the desktop.
I would like to name the files with the email subjects exactly the way they are in Outlook. I do not want to strip any characters.
I have played around with the macro but I can't fix it. Also would like to remove the time stamp date etc.
Option Explicit
Dim StrSavePath As String
Sub SaveAllEmails_ProcessAllSubFolders()
Dim i As Long
Dim j As Long
Dim n As Long
Dim StrSubject As String
Dim StrName As String
Dim StrFile As String
Dim StrReceived As String
Dim StrFolder As String
Dim StrSaveFolder As String
Dim StrFolderPath As String
Dim iNameSpace As NameSpace
Dim myOlApp As Outlook.Application
Dim SubFolder As MAPIFolder
Dim mItem As MailItem
Dim FSO As Object
Dim ChosenFolder As Object
Dim Folders As New Collection
Dim EntryID As New Collection
Dim StoreID As New Collection
Set FSO = CreateObject("Scripting.FileSystemObject")
Set myOlApp = Outlook.Application
Set iNameSpace = myOlApp.GetNamespace("MAPI")
Set ChosenFolder = iNameSpace.PickFolder
If ChosenFolder Is Nothing Then
'GoTo ExitSub:
End If
BrowseForFolder StrSavePath
Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)
For i = 1 To Folders.Count
StrFolder = StripIllegalChar(Folders(i))
n = InStr(3, StrFolder, "\") + 1
StrFolder = Mid(StrFolder, n, 256)
StrFolderPath = StrSavePath & "\" & StrFolder & "\"
StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"
If Not FSO.FolderExists(StrFolderPath) Then
FSO.CreateFolder (StrFolderPath)
End If
Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
On Error Resume Next
For j = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(j)
StrReceived = Format(mItem.ReceivedTime, "YYYYMMDD-hhmm")
StrSubject = mItem.Subject
StrName = StripIllegalChar(StrSubject)
StrFile = StrSaveFolder & StrReceived & "_" & StrName & ".msg"
StrFile = Left(StrFile, 256)
mItem.SaveAs StrFile, 3
Next j
On Error GoTo 0
Next i
ExitSub:
End Sub
Function StripIllegalChar(StrInput)
Dim RegX As Object
Set RegX = CreateObject("vbscript.regexp")
RegX.Pattern = "[\" & Chr(34) & "\!\#\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
RegX.IgnoreCase = True
RegX.Global = True
StripIllegalChar = RegX.Replace(StrInput, "")
ExitFunction:
Set RegX = Nothing
End Function
Sub GetFolder(Folders As Collection, EntryID As Collection, _
StoreID As Collection, Fld As MAPIFolder)
Dim SubFolder As MAPIFolder
Folders.Add Fld.FolderPath
EntryID.Add Fld.EntryID
StoreID.Add Fld.StoreID
For Each SubFolder In Fld.Folders
GetFolder Folders, EntryID, StoreID, SubFolder
Next SubFolder
ExitSub:
Set SubFolder = Nothing
End Sub
Function BrowseForFolder(StrSavePath As String, _
Optional OpenAt As String) As String
Dim objShell As Object
Dim objFolder ' As Folder
Dim enviro
enviro = CStr(Environ("USERPROFILE"))
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Please choose a folder", _
0, enviro & "C:\Temp\Folders")
StrSavePath = objFolder.self.Path
On Error Resume Next
On Error GoTo 0
ExitFunction:
Set objShell = Nothing
End Function
an alternative approach if you absolutely want to retain the original email unaltered is to create a new email message to yourself with the original email saved as an attachment. Save the new email with a corrected subject to avoid windows naming errors, it will retain a link to the unaltered original.
It's a few extra steps but you should be able to automate those if you insist on retaining the original email unaltered.
Its bad idea like Tim said, but if that is what you want to do then modify your j loop to something like this...
For j = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(j)
StrSubject = mItem.Subject
StrSubject = StrSaveFolder & StrSubject & ".msg"
mItem.SaveAs StrSubject, 3
Next j
Good Luck...

Automatically export specific emails to text file from Outlook

I am trying to use a VBA script to automatically export all incoming emails with a specific subject to text files that I will then parse with a Python script. The code below works for the most part, but it will randomly skip some of the emails come in.
I haven't found any reason as to why this is, and it doesn't skip emails from the same sender each day, it varies.
We have about 20-30 emails coming in during a 30 minute period or so if that matters. I'd love some help with this.
Private Sub Items_ItemAdd(ByVal Item As Object)
Dim strSubject As String
strSubject = Item.Subject
If TypeOf Item Is Outlook.MailItem And strSubject Like "VVAnalyze Results" Then
SaveMailAsFile Item
End If
End Sub
Private Sub SaveMailAsFile(oMail As Outlook.MailItem)
Dim dtDate As Date
Dim sName As String
Dim sFile As String
Dim sExt As String
sPath = "C:\Users\ltvstatus\Desktop\Backup Reports\"
sExt = ".txt"
sName = oMail.Subject
ReplaceCharsForFileName sName, "_"
dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & sExt
oMail.SaveAs sPath & sName, olSaveAsTxt
End Sub
Your code looks okay to me so I am not sure if your overwriting your saved emails with new one or your getting to many emails at once while the code is processing one and skipping the other...
I have modified your code to loop in your Inbox and added Function to create new file name if the file already exist...
if you receive 10 email in 1 second, the function will create FileName(1).txt, FileName(2).txt and so on...
I will also advise you to move the emails to subfolder as you SaveAs txt...
Item.Move Subfolder
CODE UPDATED
Option Explicit
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
SaveMailAsFile Item ' call sub
End If
End Sub
Public Sub SaveMailAsFile(ByVal Item As Object)
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim ItemSubject As String
Dim NewName As String
Dim RevdDate As Date
Dim Path As String
Dim Ext As String
Dim i As Long
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items.Restrict("[Subject] = 'VVAnalyze Results'")
Path = Environ("USERPROFILE") & "\Desktop\Backup Reports\"
ItemSubject = Item.Subject
RevdDate = Item.ReceivedTime
Ext = "txt"
For i = Items.Count To 1 Step -1
Set Item = Items.Item(i)
DoEvents
If Item.Class = olMail Then
Debug.Print Item.Subject ' Immediate Window
Set SubFolder = Inbox.Folders("Temp") ' <--- Update Fldr Name
ItemSubject = Format(RevdDate, "YYYYMMDD-HHNNSS") _
& " - " & _
Item.Subject & Ext
ItemSubject = FileNameUnique(Path, ItemSubject, Ext)
Item.SaveAs Path & ItemSubject, olTXT
Item.Move SubFolder
End If
Next
Set olNs = Nothing
Set Inbox = Nothing
Set SubFolder = Nothing
Set Items = Nothing
End Sub
'// Check if the file exists
Private Function FileExists(FullName As String) As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(FullName) Then
FileExists = True
Else
FileExists = False
End If
Exit Function
End Function
'// If the same file name exist then add (1)
Private Function FileNameUnique(Path As String, _
FileName As String, _
Ext As String) As String
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(FileName) - (Len(Ext) + 1)
FileName = Left(FileName, lngName)
Do While FileExists(Path & FileName & Chr(46) & Ext) = True
FileName = Left(FileName, lngName) & " (" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = FileName & Chr(46) & Ext
Exit Function
End Function

Outlook Save multiple attachments using the subject line, and incrementing that name

I've spent a couple of weeks playing with VBA, I am not by any means an expert on this.
What I'm looking for is a modification of this code.
Public 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 Integer
Dim lngCount As Integer
Dim strFile As String
Dim strFolderpath As String
Dim strFileName As String
Dim objSubject As String
Dim strDeletedFiles As String
' Get the path to your My Documents folder
'strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
' The attachment folder needs to exist
' You can change this to another folder name of your choice
' Set the Attachment folder.
strFolderpath = "C:\Users\demkep\Documents\"
' Check each selected item for attachments.
For Each objMsg In objSelection
'Set FileName to Subject
objSubject = objMsg.Subject
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.
strFileName = objSubject & ".pdf"
' Combine with the path to the Temp folder.
strFile = strFolderpath & strFileName
Debug.Print strFile
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile
Next i
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
It is the closest to what I am trying to accomplish.
However when I get an email with multiple attachments, it will simply overwrite the last file. if possible. I'd like it to save (sometimes up to 30 .pdf files) as "emailsubject, emailsubject(1), emailsubject(2), emailsubject(3)" etc...
any help would be appreciated.
You are not changing the filename within the loop. Something like
strFileName = objSubject & "(" & i & ").pdf"
should take care of that.
If you only want numbers if there is more than one attachment you can check lngCount before setting the name or use IIf
If lngCount > 1 Then
strFileName = objSubject & "(" & i & ").pdf"
Else
strFileName = objSubject & ".pdf"
End If
Or
strFileName = objSubject & IIf(lngCount>1, "(" & i & ")", "") & ".pdf"
You shouldn't use On Error Resume Next on your whole sub btw.
Here is Function that will do exactly what you need
Function UniqueName(FilePath As String) As String
Dim FSO As Object
Set FSO = CreateObject("Scripting.FilesystemObject")
Dim FileName As String
FileName = FilePath
Dim Ext As String
Ext = Chr(46) & FSO.GetExtensionName(FilePath)
Dim i As Long
i = 1
Do While FSO.FileExists(FileName)
FileName = Left(FilePath, Len(FilePath) - Len(Ext)) & " (" & i & ")" & Ext
i = i + 1
Loop
UniqueName = FileName
End Function
And change this strFile = strFolderpath & strFileName To strFile = UniqueName(strFolderpath & strFileName)

How to move mail to a folder based on attachment filename?

I need a rule (or most probably a VBA macro) to sort my mails. In case I have per say "REPORT" in the filename of the attachment of a newly received mail than I would like to move that mail to a different folder, let say "REPORTS" folder.
How can I achieve this?
I already to set a rule on the mail header but that did not seem to solve the matter.
Thanks in advance!
Used code from http://www.outlookcode.com/article.aspx?id=62 and http://blog.saieva.com/2010/03/27/move-messages-to-folders-with-outlook-vba/
'code goes in "ThisOutlookSession" module
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim arr() As String
Dim i As Integer
Dim ns As Outlook.NameSpace
Dim itm As MailItem
Dim m As Outlook.MailItem
Dim att As Outlook.Attachment
On Error Resume Next
Set ns = Application.Session
arr = Split(EntryIDCollection, ",")
For i = 0 To UBound(arr)
Set itm = ns.GetItemFromID(arr(i))
If itm.Class = olMail Then
Set m = itm
If m.Attachments.Count > 0 Then
For Each att In m.Attachments
If UCase(att.FileName) Like "*REPORT*" Then
MoveToFolder m, "MoveTest"
Exit For
End If
Next att
End If
End If
Next
Set ns = Nothing
Set itm = Nothing
Set m = Nothing
End Sub
Sub MoveToFolder(mItem As MailItem, folderName)
'###you need to edit this for your account name###
Const mailboxNameString As String = "Mailbox - firstname lastname"
Dim olApp As New Outlook.Application
Dim olNameSpace As Outlook.NameSpace
Dim olDestFolder As Outlook.MAPIFolder
Set olNameSpace = olApp.GetNamespace("MAPI")
Set olDestFolder = olNameSpace.Folders(mailboxNameString).Folders(folderName)
Debug.Print "[" & Date & " " & Time & "] " & _
": folder = " & folderName & _
"; subject = " & mItem.Subject & "..."
mItem.Move olDestFolder
End Sub