Download attachment in folder with Subject line

Hi,

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
Next

End Sub

Regards,
Uday

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

Code:

---

Option Explicit

Sub TestCode()
Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    SaveAttachments olMsg
lbl_Exit:
    Exit Sub
End Sub


Public Sub SaveAttachments(olItem As MailItem)
'Graham Mayor - https://www.gmayor.com - 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
        olItem.Save
    End If
lbl_Exit:
    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 - https://www.gmayor.com - 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
    Loop
    FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
    Set fso = Nothing
    Exit Function
End Function

---