Consulting

Results 1 to 2 of 2

Thread: Download attachment in folder with Subject line

  1. #1
    VBAX Regular
    Joined
    Apr 2019
    Posts
    17
    Location

    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

  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
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

Posting Permissions

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