The intent is to use a rule to trigger a script that saves the attached files of an email if the created date is equal to today. Next, the script would delete all items from the folder that do not have the same created date.
I can run the code, but it doesn't do anything.
Public Sub SaveAttachments(MItem As Outlook.MailItem)
Dim oAttachment As Outlook.Attachment
Dim sSaveFolder As String
Dim today As Date 'today's date
Dim adate As Date 'date of attachment
today = Date
sSaveFolder = "filepath"
For Each oAttachment In MItem.Attachments
adate = oAttachment.DateCreated
If DateDiff("d", today, adate) = 0 Then
oAttachment.SaveAsFile sSaveFolder & oAttachment.DisplayName
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
If Format(objfile.DateCreated, "DD-MM-YYYY") <> Format(Date, "DD-MM-YYYY") Then
Kill objfile
End If
Next objfile
End Sub
I figured it out.
Public Sub SaveAttachmentsToDisk(MItem As Outlook.MailItem)
Dim oAttachment As Outlook.Attachment
Dim sSaveFolder As String
Dim keepfile As String
sSaveFolder = "filepath"
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.DisplayName
keepfile = oAttachment.DisplayName
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
If InStr(objfile.Name, keepfile) = 0 Then
Kill objfile
End If
Next objfile
End Sub
The Attachment class from the Outlook object model doesn't provide the DateCreated property.
Related
I'm trying to extract an Excel report from an Outlook email, and save it in a folder called "OLAttachments" in my Documents folder.
I also need it to overwrite the previous day's file. These email attachments have the same name each day.
This is what I have so far. Each time the email comes through, it saves a new file, whereas I would like to overwrite the existing file.
Public Sub SaveAttachmentsToDisk(MItem As Outlook.MailItem)
Dim oAttachment As Outlook.Attachment
Dim sSaveFolder As String
sSaveFolder = "C:\Users\fmustapha\Documents\Outlook Attachments"
For Each oAttachment In MItem.Attachments
oAttachment.SaveAsFile sSaveFolder & oAttachment.DisplayName
Next
End Sub
I do this on my server, I receive an email each night that has an Excel file attached, that auto forwards to my server where this outlook code saves off the attachment. Note there is a clause in there to make sure the file comes from me and to make sure it's an Excel file:
Private WithEvents olItems As Outlook.Items
Private Sub Application_Startup()
Dim objNS As Outlook.NameSpace
Set objNS = GetNamespace("MAPI")
Set olItems = objNS.GetDefaultFolder(olFolderInbox).Items
Set objNS = Nothing
End Sub
Private Sub olItems_ItemAdd(ByVal Item As Object)
Dim NewMail As Outlook.MailItem
Dim Atts As Attachments
Dim Att As Attachment
Dim strPath As String
Dim strName As String
If Item.Class = olMail Then
Set NewMail = Item
End If
strPath = "C:\Reporting Archive\Sales Files\"
If NewMail.Sender = "Dan Donoghue" Then
Set Atts = Item.Attachments
If Atts.Count > 0 Then
For Each Att In Atts
If InStr(LCase(Att.FileName), ".xls") > 0 Then Att.SaveAsFile strPath & Att.FileName
Next
End If
End If
End Sub
It goes in ThisOutlookSession in the VBE, once you have put it in close and reopen outlook and it will work.
To save over the top I would recommend you delete the existing file first (you can use the kill command for this then simply save the new one).
You would do that by replacing this:
If InStr(LCase(Att.FileName), ".xls") > 0 Then Att.SaveAsFile strPath & Att.FileName
with this:
If InStr(LCase(Att.FileName), ".xls") > 0 Then
Kill strPath & Att.FileName
Att.SaveAsFile strPath & Att.FileName
End If
in my code
You can setup a rule that triggers this job in any frequency you want (you probably don't want the rule to run in seconds, but more like 1x per day, overnight, etc.)
Public Sub SaveAttachmentsToDisk(MItem As Outlook.MailItem)
Dim oAttachment As Outlook.Attachment
Dim sSaveFolder As String
sSaveFolder = "C:\Users\DT168\Documents\outlook-attachments\"
For Each oAttachment In MItem.Attachments
oAttachment.SaveAsFile sSaveFolder & oAttachment.DisplayName
Next
End Sub
https://www.extendoffice.com/documents/outlook/3747-outlook-auto-download-save-attachments-to-folder.html#a1
Try using Date function Which Returns a Variant (Date) containing the current system date. MSDN
Example
oAttachment.SaveAsFile sSaveFolder & "New Members" & " " & Format(Date - 1, "MM-DD-YYYY")
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
I have VBA code to automatically download (save) received mail attached files.
I need to make a condition to only download (save) .xlsx or .jpg files.
Public Sub SaveAttachmentsToDisk(MItem As Outlook.MailItem)
Dim oAttachment As Outlook.Attachment
Dim sSaveFolder As String
sSaveFolder = "C:\Users\DT168\Documents\outlook-attachments\"
For Each oAttachment In MItem.Attachments
oAttachment.SaveAsFile sSaveFolder & oAttachment.DisplayName
Next
End Sub
Simply use Select Case Statement
Dim FileType As String
For Each oAttachment In MItem.Attachments
FileType = LCase$(Right$(oAttachment.FileName, 4)) ' Last 4
Select Case FileType
Case "xlsx", ".jpg"
oAttachment.SaveAsFile sSaveFolder & oAttachment.DisplayName
End Select
Next
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...
Below is the script to download an attachment from mails in Outlook.
Public Sub SaveAttachmentsToDisk(MItem As Outlook.MailItem)
Dim oAttachment As Outlook.Attachment
Dim sSaveFolder As String
Dim dateFormat
dateFormat = Format(Now, "yyyy-mm-dd")
sSaveFolder = "c:\My\temp\"
For Each oAttachment In MItem.Attachments
oAttachment.SaveAsFile sSaveFolder & oAttachment.DisplayName
Next
End Sub
It downloads and stores in the path which is mentioned in my code only when attachment has different name.
For example, I received mail with attachment as 'List.csv'. With same name I received mail around 10 times.
But only one file (most recent one) got saved in the path.
Final code which works for me.
Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim dt30daysAgo As Date
dt30daysAgo = DateAdd("d", -30, Now)
saveFolder = "c:\My\temp"
For Each objAtt In itm.Attachments
If itm.ReceivedTime > dt30daysAgo Then
If objAtt.FileName <> "list.csv" Then
objAtt.SaveAsFile saveFolder & "\" & objAtt.FileName
Else
objAtt.SaveAsFile saveFolder & "\" & itm.Subject & objAtt.FileName
End If
End If
Next
End Sub
You are just overwritting any existing file having the same name.
A very simple solution is to append the current date/time to the file name prior to save it.
To download attachments from the last 30 days only, add a check at the beginning of the procedure to compare the Mail's ReceivedTime with the date 30 days ago, and exit the procedure if received time is lower.
Public Sub SaveAttachmentsToDisk(MItem As Outlook.MailItem)
Dim oAttachment As Outlook.Attachment
Dim sSaveFolder As String
Dim dt30daysAgo As Date
dt30daysAgo = DateAdd("d", 30, Now)
If MItem.ReceivedTime < dt30daysAgo Then Exit Sub
sSaveFolder = "c:\My\temp\"
For Each oAttachment In MItem.Attachments
oAttachment.SaveAsFile sSaveFolder & Format(Now, "YYYY-MM-DD_hh-nn-ss") & oAttachment.DisplayName
Next
End Sub
But the check on ReceivedTime is not well placed, you should ideally do this this on the calling procedure.