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?