Results 1 to 2 of 2

Thread: Save attachments with subject name

  1. #1
    VBAX Regular
    Feb 2018

    Save attachments with subject name

    Hi, hoping this is a quick fix. I'm using this macro to save attachments as they arrive in to a mailbox. I'd like to attachments to include to subject as well as the document name. Is this possible?


    Sub FindFilesAndMove()    Dim MyFolder As String, MyFile As String, srchStr As String, DestFoldFull As String, FSO As Object, rCell As Range
        Dim DestFold As String
        Set FSO = CreateObject("Scripting.Filesystemobject")
        MyFolder = "Y:\accounts\Conv slips\" '<<< change to suit
        DestFold = "Y:\accounts\Conv slips\Completions packs\" 
        For Each rCell In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).Cells
            MyFile = Dir(MyFolder)
            srchStr = rCell.Value
            DestFoldFull = DestFold & srchStr & "\"
            MkDir DestFoldFull
            Do While MyFile <> ""
                If InStr(MyFile, srchStr) Then
                    FSO.MoveFile Source:=MyFolder & MyFile, Destination:=DestFoldFull & MyFile
                End If
            MyFile = Dir
        Next rCell
    End Sub

  2. #2
    Your code doesn't appear to have anything to do with attachments?
    If you want to save attachments from Outlook messages as they arrive and include the message subject, this may create issues relating to illegal filename characters, and in some cases excessive string length. However the following will correct the former and when run from a Rule to identify the messages to process, will save the message attachments to the named folder as they arrive in the inbox. I have included a test macro to test the code:
    Option Explicit
    Sub TestSaveAttachments()
    Dim olMsg As MailItem
        On Error Resume Next
        Select Case Outlook.Application.ActiveWindow.Class
            Case olInspector
                Set olMsg = ActiveInspector.currentItem
            Case olExplorer
                Set olMsg = Application.ActiveExplorer.Selection.Item(1)
        End Select
        SaveAttachments olMsg
        Exit Sub
    End Sub
    Public Sub SaveAttachments(olItem As MailItem)
    'Graham Mayor - - Last updated - 26 May 2017
    Dim olAttach As Attachment
    Dim strFname As String
    Dim strExt As String
    Dim j As Long
    Const strSaveFldr As String = "D:\Path\Attachments\" 'the folder to save the attachments
        CreateFolders strSaveFldr
        On Error Resume Next
        If olItem.Attachments.Count > 0 Then
            For j = 1 To olItem.Attachments.Count
                Set olAttach = olItem.Attachments(j)
                If Not olAttach.FileName Like "image*.*" Then
                    strFname = olAttach.FileName
                    strFname = CleanFileName(olItem.Subject & "_" & strFname)
                    strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
                    strFname = FileNameUnique(strSaveFldr, strFname, strExt)
                    olAttach.SaveAsFile strSaveFldr & strFname
                End If
            Next j
        End If
        Set olAttach = Nothing
        Set olItem = Nothing
        Exit Sub
    End Sub
    Private Function FileNameUnique(strPath As String, _
                                    strFileName As String, _
                                    strExtension As String) As String
    'An Outlook macro by Graham Mayor
    Dim lngF As Long
    Dim lngName As Long
        lngF = 1
        lngName = Len(strFileName) - (Len(strExtension) + 1)
        strFileName = Left(strFileName, lngName)
        Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
            strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
            lngF = lngF + 1
        FileNameUnique = strFileName & Chr(46) & strExtension
        Exit Function
    End Function
    Private Function FileExists(filespec) As Boolean
    'An Outlook macro by Graham Mayor
    Dim FSO As Object
        Set FSO = CreateObject("Scripting.FileSystemObject")
        If FSO.FileExists(filespec) Then
            FileExists = True
            FileExists = False
        End If
        Exit Function
    End Function
    Private Function FolderExists(fldr) As Boolean
    'An Outlook macro by Graham Mayor
    Dim FSO As Object
        Set FSO = CreateObject("Scripting.FileSystemObject")
        If (FSO.FolderExists(fldr)) Then
            FolderExists = True
            FolderExists = False
        End If
        Exit Function
    End Function
    Private Function CreateFolders(strPath As String)
    'An Outlook macro by Graham Mayor
    Dim strTempPath As String
    Dim lngPath As Long
    Dim VPath As Variant
        VPath = Split(strPath, "\")
        strPath = VPath(0) & "\"
        For lngPath = 1 To UBound(VPath)
            strPath = strPath & VPath(lngPath) & "\"
            If Not FolderExists(strPath) Then MkDir strPath
        Next lngPath
        Exit Function
    End Function
    Private Function CleanFileName(strFileName As String) As String
    Dim arrInvalid() As String
    Dim lng_Index As Long
        'Define illegal characters (by ASCII CharNum)
        arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|")
        'Remove any illegal filename characters
        CleanFileName = strFileName
        For lng_Index = 0 To UBound(arrInvalid)
            CleanFileName = Replace(CleanFileName, Chr(arrInvalid(lng_Index)), Chr(95))
        Next lng_Index
        Exit Function
    End Function
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes

Posting Permissions

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