I receive emails from >10 different stores every day. Each email usually has more than one attachment. I download each email's attachments into the respective local sub-directories.
I download the attachments using a code I found online. I coupled the script with rules so attachments download to their respective local folders.
Problem: Let's say that store 1 sends a file with name ABC.xlsx every day. My rules/ script run, in a reverse chronological order and thus the script goes through each mail one by one and each file replaces the latest file until I get the earliest file.
I need my script to either save the latest file, or more appropriately, update the file name with current date appended to the existing file name.
Public Sub SaveAttachmentsToDisk_St10(MItem As Outlook.MailItem)
Dim oAttachment As Outlook.Attachment
Dim sSaveFolder As String
sSaveFolder = "H:\Folder1\Projects\Online\Data\Store 10\MC\"
For Each oAttachment In MItem.Attachments
oAttachment.SaveAsFile sSaveFolder & oAttachment.DisplayName
Next
End Sub
You can get the date from your mail item using ReceivedTime. This returns a date, use this with the Format function to create a suffix that you append to the filename. I would suggest to put the date as YYYYMMDD, that helps sorting the filenames.
For Each oAttachment In MItem.Attachments
Dim filename As String, p As Long, suffix As String
filename = oAttachment.DisplayName
suffix = "_" & Format(MItem.ReceivedTime, "YYYYMMDD_HHNN")
' Now add the suffix before the file extension
p = InStrRev(filename, ".") ' Find dot to separate file extension
If p > 0 Then
filename = Left(filename, p - 1) & suffix & Mid(filename, p)
Else
filename = filename & suffix
End If
oAttachment.SaveAsFile sSaveFolder & filename
Next
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 need to search through 9,000 emails and save the attachments with a certain timestamp (these are security camera feeds).
The code works on a small number of emails, but after about 20 the processing in Outlook appears to speed up significantly (attachments stop saving) and then Outlook hangs with a memory error.
My guess is the save step is not completed before the script moves to the next email in the target folder and therefore the backlog of saves becomes too large for Outlook.
' this function grabs the timestamp from the email body
' to use as the file rename on save in the following public sub
Private Function GetName(olItem As MailItem) As String
Const strFind As String = "Exact Submission Timestamp: "
Dim olInsp As Inspector
Dim wdDoc As Object
Dim oRng As Object
Dim strDate As String
With olItem
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
With oRng.Find
Do While .Execute(strFind)
oRng.Collapse 0
oRng.End = oRng.End + 23
strDate = oRng.Text
strDate = Replace(strDate, Chr(58), Chr(95))
GetName = strDate & ".jpg"
Exit Do
Loop
End With
End With
lbl_Exit:
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Exit Function
End Function
Public Sub SaveAttachmentsToDisk24(MItem As outlook.MailItem)
Dim oAttachment As outlook.Attachment
Dim sSaveFolder As String
Dim strFname As String
sSaveFolder = "C:\Users\xxxxx\"
For Each oAttachment In MItem.Attachments
If oAttachment.FileName Like "*.jpg" Then
strFname = GetName(MItem)
oAttachment.SaveAsFile sSaveFolder & strFname
Set oAttachment = Nothing
Set MItem = Nothing
End If
Next oAttachment
There are other possibilities but my belief is that the memory errors are the result of creating Word objects and then not closing them. Om3r asked for more information but you ignored his requests making it impossible to provide a definitive answer. However, I wanted to prove it was possible to extract attachments from a large number of emails without problems so I have made some guesses.
I understand why you need a routine that will scan your Inbox for the backlog of 8,000 camera feed emails. I do not understand why you want to use an event to monitor your Inbox as well. I cannot believe this is a time critical task. Why not just run the scan once or twice a day? However, the routine I have coded could be adapted to create a macro to be called by an event routine. My current code relies of global variables which you will have to change to local variables. I am not a fan of global variables but I did not want to create a folder reference for every call of the inner routine and the parameter list for a macro that might be called by an event routine is fixed.
To test the code I planned to create, I first generated 790 emails to myself that matched (I hope) your camera feed emails. I had planned to create more but I think my ISP has classified me as a spammer, or perhaps a flamer, and it would not let me send any more. The body of these emails looked like:
xxx Preamble xxx ‹cr›‹lf›|
Exact Submission Timestamp: 2019-02-22 15:00:00 ‹cr›‹lf›|
xxx Postamble xxx ‹cr›‹lf›|
Your code requires the string “Exact Submission Timestamp:” followed by a date which you use as a file name. I have assumed that date in in a format that VBA can recognise as a date and I have assumed the date is ended by a standard Windows newline (carriage return, line feed). The second assumption would be easy to change. I have a routine that will accept many more date formats than VBA’s CDate which I can provide if necessary.
Each email has a different date and time between November, 2018 and February, 2019.
I would never save 8,000 files in a single disc folder. Even with a few hundred files in a folder, it becomes difficult to find the one you want. My root folder is “C:\DataArea\Test” but you can easily change that. Given the timestamp in my example email, my routine would check for folder “C:\DataArea\Test\2019” then “C:\DataArea\Test\2019\02” and finally “C:\DataArea\Test\2019\02\22”. If a folder did not exist, it would be created. The attachment is then saved in the inner folder. My code could easily be adapted to save files at the month level or the hour level depending on how many of these files you get per month, day or hour.
My routine checks every email in Inbox for the string “Exact Submission Timestamp:” followed by a date. If it finds those, it checks for an attachment with an extension of JPG. If the email passes all these tests, the attachment is saved in the appropriate disc folder and the email is moved from Outlook folder “Inbox” to “CameraFeeds1”. The reasons for moving the email are: (1) it clears the Inbox and (2) you can rerun the routine as often as you wish without finding an already processed email. I named the destination folder “CameraFeeds1” because you wrote that you wanted to do some more work on these emails. I thought you could move the emails to folder “CameraFeeds2” once you had completed this further work.
I assumed processing 790 or 8,000 emails would take a long time. In my test, the duration was not as bad as I expected; 790 emails took about one and a half minutes. However, I created a user form to show progress. I cannot include the form in my answer so you will have to create your own. Mine looks like:
The appearance is not important. What is important is the name of the form and the four controls on the form:
Form name: frmSaveCameraFeeds
TextBox name: txtCountCrnt
TextBox name: txtCountMax
CommandButton name: cmdStart
CommandButton name: cmdStop
If you run the macro StartSaveCameraFeeds it will load this form. Click [Start] to start the save process. You can let the macro run until it has checked every email in the Inbox or you can click [Stop] at any time. The stop button is not as important as I feared. I thought the routine might take hours but that was not the case.
You don’t report where your 8,000 emails are. I have an Inbox per account plus the default Inbox which I only use for testing. I moved the 790 test emails to the default Inbox and used GetDefaultFolder to reference it. I assume you know how to reference another folder if necessary. Note I use Session instead of a name space. These two methods are supposed to be equivalent but I always use Session because it is simpler and because I once had a failure with a name space that I could not diagnose. I reference folder “CameraFeeds1” relative to the Inbox.
You will have to adjust my code at least partially. For the minimum changes, do the following:
Create a new module and copy this code into it:
Option Explicit
Public Const Marker As String = "Exact Submission Timestamp: "
Public Const RootSave As String = "C:\DataArea\Test"
Public FldrIn As Outlook.Folder
Public FldrOut As Outlook.Folder
Sub StartSaveCameraFeeds()
' Reference outlook folders then pass control to frmSaveCameraFeeds
Set FldrIn = Session.GetDefaultFolder(olFolderInbox)
Set FldrOut = FldrIn.Parent.Folders("CameraFeeds1")
Load frmSaveCameraFeeds
With frmSaveCameraFeeds
.Caption = "Saving jpg files from Camera feed emails"
.txtCountCrnt = 0
.txtCountMax = FldrIn.Items.Count
.Show vbModal
End With
' Form unloaded by cmdStop within form
Set FldrIn = Nothing
Set FldrOut = Nothing
End Sub
Public Sub SaveCameraFeed(ByRef ItemCrnt As MailItem)
' Checks a single mail item to be a "camera feed" email. If the mail item is
' a "camera feed" email, it saves the JPG file using the date within the
' email body as the file name. If the mail item is not a "camera feed"
' email, it does nothing.
' To be a camera feed mail item:
' * The text body must contain a string of the form: "xxxyyyy" & vbCr & vbLf
' where "xxx" matches the public constant Marker and "yyy" is recognised
' by VBA as a date
' * It must have an attachment with an extension of "JPG" or "jpg".
' If the mail item is a camera feed email:
' * In "yyy" any colons are replaced by understores.
' * The JPG attachment is saved with the name yyy & ".jpg"
Dim DateCrnt As Date
Dim DateStr As String
Dim DayCrnt As String
Dim InxA As Long
Dim MonthCrnt As String
Dim PathFileName As String
Dim PosEnd As Long
Dim PosStart As Long
Dim SomethingToSave As Boolean
Dim YearCrnt As String
SomethingToSave = False ' Assume no JPG to save until find otherwise
With ItemCrnt
PosStart = InStr(1, .Body, Marker)
If PosStart > 0 Then
PosStart = PosStart + Len(Marker)
PosEnd = InStr(PosStart, .Body, vbCr & vbLf)
DateStr = Mid$(.Body, PosStart, PosEnd - PosStart)
If IsDate(DateStr) Then
DateCrnt = DateStr
For InxA = 1 To .Attachments.Count
If LCase(Right$(.Attachments(InxA).Filename, 4)) = ".jpg" Then
SomethingToSave = True
Exit For
End If
Next
End If
End If
If SomethingToSave Then
DateStr = Replace(DateStr, ":", "_")
YearCrnt = Year(DateCrnt)
MonthCrnt = Month(DateCrnt)
DayCrnt = Day(DateCrnt)
Call CreateDiscFldrIfItDoesntExist(RootSave, YearCrnt, MonthCrnt, DayCrnt)
PathFileName = RootSave & "\" & YearCrnt & "\" & MonthCrnt & "\" & DayCrnt & _
"\" & Trim(DateStr) & ".jpg"
.Attachments(InxA).SaveAsFile PathFileName
.Move FldrOut
End If
End With
End Sub
Public Sub CreateDiscFldrIfItDoesntExist(ByVal Root As String, _
ParamArray SubFldrs() As Variant)
' If a specified disk folder (not an Outlook folder) does not exist, create it.
' Root A disk folder which must exist and for which the user
' must have write permission.
' SubFldrs A list of sub-folders required within folder Root.
' Example call: CreateDiscFldrsIfNecessary("C:\DataArea", "Aaa", "Bbb", "Ccc")
' Result: Folder "C:\DataArea\Aaa\Bbb\Ccc" will be created if it does not already exist.
' Note: MkDir("C:\DataArea\Aaa\Bbb\Ccc") fails unless folder "C:\DataArea\Aaa\Bbb" exists.
Dim Filename As String
Dim Fldrname As String
Dim InxSF As Long
Fldrname = Root
For InxSF = LBound(SubFldrs) To UBound(SubFldrs)
Fldrname = Fldrname & "\" & SubFldrs(InxSF)
If Not PathExists(Fldrname) Then
Call MkDir(Fldrname)
End If
Next
End Sub
Public Function PathExists(ByVal Pathname As String) As Boolean
' Returns True if path exists
' Coded by Tony Dallimore
' Based on code written by iDevlop: http://stackoverflow.com/a/28237845/973283
On Error Resume Next
PathExists = ((GetAttr(Pathname) And vbDirectory) = vbDirectory)
On Error GoTo 0
End Function
I must warn you that I have modules full of standard routines that I use all the time. I believe I have included all the standard routines used by the code I have written for you. If the code fails because a sub or function is missing, post a comment and I will apologise and add the missing macro to my code.
Near the top of the above code is Public Const RootSave As String = "C:\DataArea\Test". You will have to change this to reference your root folder.
The first statement of Sub StartSaveCameraFeeds() is Set FldrIn = Session.GetDefaultFolder(olFolderInbox). Amend this as necessary if the emails are not in the default Inbox.
In the body of Sub StartSaveCameraFeeds() you will find PosEnd = InStr(PosStart, .Body, vbCr & vbLf). If the date string is not ended by a standard Windows’ newline, amend this statement as necessary.
Create a user form. Add two TextBoxes and two CommandButtons. Name them as defined above. Copy the code below to the code area of the form:
Option Explicit
Private Sub cmdStart_Click()
' Call SaveCameraFeed for every MailItem in FldrIn
Dim CountMax As Long
Dim InxI As Long
Dim MailItemCrnt As MailItem
With FldrIn
CountMax = FldrIn.Items.Count
For InxI = CountMax To 1 Step -1
If .Items(InxI).Class = olMail Then
Set MailItemCrnt = .Items(InxI)
Call SaveCameraFeed(MailItemCrnt)
Set MailItemCrnt = Nothing
End If
txtCountCrnt = CountMax - InxI + 1
DoEvents
Next
End With
Unload Me
End Sub
Private Sub cmdStop_Click()
Unload Me
End Sub
The form code should not need amendment.
As I have already written, this code processed 790 camera feed emails in about one and a half minutes. I coded a further routine that checked that for every email the date matched the name of a jpg file. I could include this routine in my answer if you would like to perform the same check.
I am trying to copy a file from one path to another and rename it. However the source folder contains several files, and the naming convention is the following: 123456_EXyymmdd.txt now the 123456 part is a randomly generated number, so I can only identify the file to copy for a given day by the EXyymmdd part. I have the following code where I tried to put the identifying segment of the string as "**" but it doesn't work, probably due to the date:
Sub SOQuestion()
Dim myDate1 As String
Dim Ipan1 As String
Dim Ipan2 As String
Dim mGlobalDate as string
mGlobalDate=Format(Date, "yyyymmdd")
myDate1 = Format(Date, "yymmdd")
Ipan1 = "157782_EX" & mGlobalDate & ".txt"
Ipan2 = "*_EX*" & myDate1 & ".TXT*"
'source path below
FileCopy "C:\sample\" & Ipan2, "C:\sample2\" & Ipan1
End Sub
It's confused because of the wildcard. It would be like copying a bunch of files to one file, which if you think about it, doesn't make much sense. Instead, use the wildcard and the Dir function to get the exact filename and use that as your source argument.
Dim sFilename as String
sFilename = Dir("C:\sample\" & Ipan2)
Then:
FileCopy "C:\sample\" & sFilename, "C:\sample2\" & Ipan1
MSDN Dir Function
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 am working on a project in VBA where I'm searching a directory for files of a certain date that also meet other criteria, and all of that is working fine. What I am stuck on, which should be a trivial issue, is that when I try to use FileCopy to copy the file to another folder, I keep getting a path/file access error. This confuses me because I am pulling the path directly from the FileItem I'm using to search for the criteria, I'm the person who created both the source and destination folders, and put the files in the source folder. Any thoughts?
Sub ListFilesInFolder()
Dim counter As Integer
Dim theString1 As String, theString2 As String
theString1 = "ISA*00*"
theString2 = "ISA|00|"
Dim line As String, fileName As String
Dim datestring As String
'datestring = Format(FileItem.DateLastModified, "mm/dd/yyyy")
Dim today As String
today = Format(DateAdd("d", -2, Date), "mm/dd/yyyy")
Dim destinationFolder As String
destinationFolder = "C:\Users\kragan\Desktop\test\folder2"
Dim file As TextStream
Dim FSO As Scripting.FileSystemObject
Set FSO = New Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Set SourceFolder = FSO.GetFolder("C:\Users\kragan\Desktop\test\folder1")
Dim FileItem As Scripting.file
For Each FileItem In SourceFolder.Files
datestring = "10/18/2015"
If (datestring = today) Then
Do While (SourceFolder <> "")
Set file = FSO.OpenTextFile(FileItem)
counter = 0
Do While Not file.AtEndOfLine And counter < 1
line = file.ReadLine
If InStr(1, line, theString1, vbTextCompare) > 0 Or InStr(1, line, theString2, vbTextCompare) > 0 Then
fileName = "C:\Users\kragan\Desktop\test\folder1\" + FSO.GetBaseName(FileItem) + ".AETCLS"
'The line where I get the error:
FileCopy fileName, destinationFolder
file.Close
counter = counter + 1
Exit Do
End If
Loop
Loop
End If
Next FileItem
MsgBox ("done")
End Sub
You need to specify destination folder + destination file name (and not only destination folder).
So this will work:
FileCopy fileName, destinationFolder & "\" & FSO.GetBaseName(FileItem) & ".AETCLS"
You were probably assuming this will work like a file manager application, where giving destination folder is enough... :) But when programming, you need to specify destination path exactly as it is, i.e. including the file name.
One of my friends was getting similar error on creating directory newdir1\newdir2\newdir3. It was not working despite his best effort. But the solution was to create newdir1, then it became possible to specify newdir1\newdir2, then finally newdir1\newdir2\newdir3. Programming file operations does not do the job often seen in file managers, but everything must be specified in detail and performed in elementary steps.
Thanks for your help. What I discovered is that you have to have the full destination path, including the file name, even though it isn't changing. Solved!