Results 1 to 2 of 2

Thread: Download attachment in folder with Subject line

  1. #1
    VBAX Regular
    Apr 2019

    Download attachment in folder with Subject line


    I want to add the subject line of the outlook with attachment file name. Please help me add the coding with below mentioned coding.

    Public Sub SaveOutlookAttachmentsToDisk(MItem As Outlook.MailItem)

    Dim oOutlookAttachment As Outlook.Attachment
    Dim sSaveAttachmentsFolder As String
    sSaveAttachmentsFolder = “ D:\ServerReports\outlook-attachments\
    For Each oOutlookAttachment In MItem.Attachments
    oOutlookAttachment.SaveAsFile sSaveAttachmentsFolder & oOutlookAttachment.DisplayName

    End Sub


  2. #2
    If you want to add the subject then you are also going to have to check for illegal filename characters and I assume unique filenames so use the following instead

    Option Explicit
    Sub TestCode()
    Dim olMsg As MailItem
        On Error Resume Next
        Set olMsg = ActiveExplorer.Selection.Item(1)
        SaveAttachments olMsg
        Exit Sub
    End Sub
    Public Sub SaveAttachments(olItem As MailItem)
    'Graham Mayor - - Last updated - 22 Jul 2019
    Dim olAttach As Attachment
    Dim strFname As String
    Dim strExt As String
    Dim j As Long, lng_Index As Long
    Dim arrInvalid() As String
    Const strSaveFldr As String = "D:\ServerReports\outlook-attachments\"
        arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|")
        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 = olItem.Subject & "_" & olAttach.fileName
                For lng_Index = 0 To UBound(arrInvalid)
                    strFname = Replace(strFname, Chr(arrInvalid(lng_Index)), Chr(95))
                Next lng_Index
                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
    'Graham Mayor - - Last updated - 22 Jul 2019
    Dim lngF As Long
    Dim lngName As Long
    Dim fso As Object
        lngF = 1
        Set fso = CreateObject("Scripting.FileSystemObject")
        lngName = Len(strFileName) - (Len(strExtension) + 1)
        strFileName = Left(strFileName, lngName)
        Do While fso.FileExists(strPath & strFileName & Chr(46) & strExtension) = True
            strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
            lngF = lngF + 1
        FileNameUnique = strFileName & Chr(46) & strExtension
        Set fso = Nothing
        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