Consulting

Results 1 to 3 of 3

Thread: Rename attachment with part of email subject

  1. #1
    VBAX Regular
    Joined
    Feb 2018
    Posts
    54
    Location

    Rename attachment with part of email subject

    Hi, I've been using this VBA code in outlook for a while and works great. My needs have now changed slightly. It takes a .XLS attachment and renames it with the subject and saves in a folder for me. Is it possible that this could rename the file with only part of the subject? I'll give you an example

    Subject Incident Date: 12/02/2020, Our ref: 529098

    The emails will come through like this (incident date and ref will always change) I only want it to rename the file Our ref: 529098

    Is this possible?

    Many thanks


    HTML Code:
    Sub saveAttachtoDisk(itm As Outlook.MailItem)
    Dim objAtt As Outlook.Attachment
    Dim saveFolder As String
    Dim strName As String
        saveFolder = "Y:\accounts\success fee bills\"
        For Each objAtt In itm.Attachments
            If Right(LCase(objAtt.FileName), 4) = ".xls" Then
                strName = CleanFileName(itm.Subject & ".xls", ".xls")
                objAtt.SaveAsFile saveFolder & strName
            End If
        Next objAtt
        Set objAtt = Nothing
    End Sub
    
    Public Function CleanFileName(strFilename As String, strExtension As String) As String
    'Graham Mayor
    'A function to ensure there are no illegal filename
    'characters in a string to be used as a filename
    'strFilename is the filename to check
    'strExtension is the extension of the file
    Dim arrInvalid() As String
    Dim vfName As Variant
    Dim lng_Name As Long
    Dim lng_Ext As Long
    Dim lngIndex As Long
        'Ensure there is no period included with the extension
        strExtension = Replace(strExtension, Chr(46), "")
        'Record the length of the extension
        lng_Ext = Len(strExtension)
        'Remove the path from the filename if present
        If InStr(1, strFilename, Chr(92)) > 0 Then
            vfName = Split(strFilename, Chr(92))
            CleanFileName = vfName(UBound(vfName))
        Else
            CleanFileName = strFilename
        End If
        'Remove the extension from the filename if present
        If Right(CleanFileName, lng_Ext + 1) = "." & strExtension Then
            CleanFileName = Left(CleanFileName, InStrRev(CleanFileName, Chr(46)) - 1)
        End If
    
        'Define illegal characters (by ASCII CharNum)
        arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|")
        'Add the extension to the filename
        CleanFileName = CleanFileName & Chr(46) & strExtension
        'Remove any illegal filename characters
        For lngIndex = 0 To UBound(arrInvalid)
            CleanFileName = Replace(CleanFileName, Chr(arrInvalid(lngIndex)), Chr(95))
        Next lngIndex
    lbl_Exit:
        Exit Function
    End Function

  2. #2
    Replace the first part with

    Sub saveAttachtoDisk(itm As Outlook.MailItem)
    Dim objAtt As Outlook.Attachment
    Dim saveFolder As String
    Dim strSubject As String
    Dim strName As String
        strSubject = "Our Ref: " & Right(itm.Subject, Len(itm.Subject) - InStrRev(itm.Subject, Chr(32)))
        saveFolder = "Y:\accounts\success fee bills\"
        For Each objAtt In itm.Attachments
            If Right(LCase(objAtt.fileName), 4) = ".xls" Then
                strName = CleanFileName(strSubject & ".xls", ".xls")
                objAtt.SaveAsFile saveFolder & strName
            End If
        Next objAtt
        Set objAtt = Nothing
    End Sub
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    VBAX Regular
    Joined
    Feb 2018
    Posts
    54
    Location
    Thank you for this! I really appreciate it. I will give this a try when I'm back in the office.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •