VBA Help: Save & Rename Attachment with File Name & Yesterday's Date

[PeachyData]

Hi all

As post title states, I am trying to write some VBA code that will save & rename Outlook attachments with the attachments filename along with yesterday's date.

The attachments all have a string of 16 characters (date & time as numbers) at the end of each attachment. I wish to remove these 16 characters and replace with yesterday's date.

E.g.
Attachment filename with the 16 characters:

302-AgentGroupPerformancebyAgent-2018103111482312

Expected output after running VBA:

302-AgentGroupPerformancebyAgent-301018.xls

I borrowed some code from a colleague that they use to do something similar but I have now got to the point where I need some more expert help to get this working.

Current VBA code:

Public Sub SaveDailyIndCallReportsToDisk(MItem As Outlook.MailItem)    
    Dim oAttachment As Outlook.Attachment
    Dim sSaveFolder As String
    Dim itemDate As Date
    Dim sDate As String
    Dim fName() As String
    Dim fPath As String
    Dim lPath As String
    Dim dName As String
    Dim FileFormatNum As Long
    
    itemDate = MItem.CreationTime
    sDate = Format(itemDate - 1, "ddmmyy")
    sSaveFolder = "C:\Users\PYM\Documents\MailAttachements\"


    dName = Right(MItem.Subject, -16)


    If itemDate >= Date - 5 Then
    For Each oAttachment In MItem.Attachments
        fName = Split(oAttachment.FileName, ".")
        fPath = sSaveFolder & dName & " " & sDate & "." & fName(1)
        lPath = LCase(fPath)
        oAttachment.SaveAsFile lPath
    Next
    End If


End Sub

Any and all help is appreciated.

Thanks for reading

Regards

 

[John_w]

    Dim p As Long
    For Each oAttachment In MItem.Attachments
        p = InStrRev(oAttachment.Filename, ".")
        fPath = sSaveFolder & Left(oAttachment.Filename, p - 17) & sDate & Mid(oAttachment.Filename, p)
        oAttachment.SaveAsFile fPath
    Next

 

[PeachyData]

    Dim p As Long
    For Each oAttachment In MItem.Attachments
        p = InStrRev(oAttachment.Filename, ".")
        fPath = sSaveFolder & Left(oAttachment.Filename, p - 17) & sDate & Mid(oAttachment.Filename, p)
        oAttachment.SaveAsFile fPath
    Next

Thank you for the reply John but unfortunately this did not solve my problem.

Regards

PeachyD

 

[John_w]

Apologies if it's obvious, but my code replaces your For Each ... Next loop.

How are you using the entire code? As written, the code should be put inside an Outlook module and is designed to be run as an Outlook rule script. Try setting a breakpoint (F8) and run the rule and step through the code in the VBA debugger.

To prove that my code correctly changes the file name, here it is in a test routine. The only change is the addition of the If p > 17 Then to prevent a crash if there aren't at least 17 characters before the "." in the file name.

Private Sub Test()

    Dim p As Long
    Dim fileNames As Variant, fileName As Variant
    Dim sSaveFolder As String, sDate As String, fPath As String
    
    sSaveFolder = "C:\Users\PYM\Documents\MailAttachments\"
    sDate = "301018" 'Format(Date - 1, "ddmmyy")
    fileNames = Array("302-AgentGroupPerformancebyAgent-2018103111482312.xls")
    
    For Each fileName In fileNames
        p = InStrRev(fileName, ".")
        If p > 17 Then
            fPath = sSaveFolder & Left(fileName, p - 17) & sDate & Mid(fileName, p)
            MsgBox fileName & " saved as " & vbCrLf & fPath
        End If
    Next

End Sub