Capturing a string from outlook body and using it to name an attachment to save

[AussieWombat]

I'm a chemical engineer, not a programmer.

I am receiving multiple emails (from the same sender - a piece of equipment that takes a photo and emails it every 30 mins). I need to capture the attachment (jpg file), rename it and save to a hard drive. I will do this with a VBA script run from a outlook 2016 rule.

In the ody of the email is the following txt string "Exact SubmissionTimestamp: 2018-08-23 11:00:02.197" where the 2018 onwards is the date and time of the photo.

Can someone help me with code to capture the string of the date and time and use this to rename the jpg file to save.

I have the code to save to a location, but not to do so with the new file name.

The current code I am using is

PublicSub SaveAttachmentsToDisk(MItem As Outlook.MailItem)
DimoAttachment As Outlook.Attachment
DimsSaveFolder As String
sSaveFolder= "C:\XXX"
ForEach oAttachment In MItem.Attachments
oAttachment.SaveAsFilesSaveFolder & oAttachment.DisplayName
Next
End Sub


Thx

[gmayor]

If the spelling of SubmissionTimestamp is correct (i.e. no space - as there are several spaces missing from your post) then the following function will give you the time and date that follows in a format that can be used as a filename:
Private Function GetName(olItem As MailItem) As String
Const strFind As String = "Exact SubmissionTimestamp: " 'Spelling must be exact!
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
and you can call that from your macro e.g. as follows. Note that you need to limit the code to the file type.

Public Sub SaveAttachmentsToDisk(MItem As Outlook.MailItem)
Dim oAttachment As Outlook.Attachment
Dim sSaveFolder As String
Dim strFname As String
sSaveFolder = "C:\XXX\"
For Each oAttachment In MItem.Attachments
If oAttachment.fileName Like "*.jpg" Then
strFname = GetName(MItem)
oAttachment.SaveAsFile sSaveFolder & strFname
End If
Next oAttachment
Set oAttachment = Nothing
End Sub

[AussieWombat]

Thanks Graham. That code works well on a small number of emails (or emails as they come in). I need to clear a 9,000 inbox of these files. When I run the code I end up with a memory error and outlook crash after about 50 emails processed. I am running on the latest Win 10 with Office 365, 8gb RAM.

IS there any reason why the memory load is building will the script is running?