Consulting

Results 1 to 5 of 5

Thread: Automatically save attachments when mail received ...

  1. #1
    VBAX Newbie
    Joined
    Mar 2020
    Posts
    3
    Location

    Automatically save attachments when mail received ...

    I know there are posts on this (and other) forum of a similar nature, but having tried countless of the answers, I cannot get any to work ...

    I want to save attachments that I KNOW will be named NEWINCIDENT??????.xlsm (where ?????? is a unique string) to a named folder ...

    I'm running Office 365 Home/Outlook Version 2002 (Build 12527.20278 Click-to-Run) ...

    This is "typical" of the VBA code I've put into ThisOutlookSession ...

    Public WithEvents olItems As Outlook.Items

    Private Sub Application_Startup()
    Set olItems = Session.GetDefaultFolder(olFolderInbox).Items
    End Sub

    Private Sub olItems_ItemAdd(ByVal Item As Object)
    Dim NewMail As Outlook.MailItem
    Dim Atts As Attachments
    Dim Att As Attachment
    Dim strPath As String
    Dim strName As String

    If Item.Class = olMail Then
    Set NewMail = Item
    End If

    Set Atts = Item.Attachments

    If Atts.Count > 0 Then
    For Each Att In Atts
    'neither of the following 2 lines work
    If Att.FileName = "NEWINCIDENT*.*" Then
    'If InStr(LCase(Att.FileName), "NEWINCIDENT") > 0 Then
    strPath = "C:\Users\User\Documents\$$$ADAM\New_Incidents_Submitted"
    strName = NewMail.Subject & " " & Chr(45) & " " & Att.FileName
    Att.SaveAsFile strPath & strName
    End If
    Next
    End If
    End Sub

    ... and Saved/restarted Outlook ...

    ... but it doesn't seem to do anything (at least not what I want it to!) ...

    Can anyone help please?

    Many thanks ...

  2. #2
    I have posted how to do this several times. The only real difference here is that you want to download only a specific attachment. The following will do that (and includes a ProcessAttachment macro to enable you to test it). Create a rule that will identify the messages and run a script and the script to run is SaveAttachments(olItem As MailItem). If the script option is missing from rules, see https://www.slipstick.com/outlook/ru...-script-rules/


    Option Explicit
    
    Sub ProcessAttachment()
    'An Outlook macro by Graham Mayor
    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 - 31 Mar 2020
    Dim olAttach As Attachment
    Dim strFname As String
    Dim strExt As String
    Dim j As Long
    Dim strSaveFldr As String
    strSaveFldr = Environ("USERPROFILE") & "\Documents\$$$ADAM\New_Incidents_Submitted\"
    
        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 olAttach.fileName Like "NEWINCIDENT*.*" Then
                    strFname = olAttach.fileName
                    strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
                    strFname = FileNameUnique(strSaveFldr, strFname, strExt)
                    olAttach.SaveAsFile strSaveFldr & strFname
                    Exit For
                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
    '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
        Loop
        FileNameUnique = strFileName & Chr(46) & strExtension
    lbl_Exit:
        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
        Else
            FileExists = False
        End If
    lbl_Exit:
        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
        Else
            FolderExists = False
        End If
    lbl_Exit:
        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
    lbl_Exit:
        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

  3. #3
    VBAX Newbie
    Joined
    Mar 2020
    Posts
    3
    Location

    Many thanks for your response

    [QUOTE=gmayor;400377]I have posted how to do this several times. The only real difference here is that you want to download only a specific attachment. The following will do that (and includes a ProcessAttachment macro to enable you to test it). Create a rule that will identify the messages and run a script and the script to run is SaveAttachments(olItem As MailItem). If the script option is missing from rules, see https://www.slipstick.com/outlook/ru...-script-rules/


    Is there any way I can get this working WITHOUT needing to enable Run a Script (long story, but would take reams of red tape!)?

    Eg I was hoping to use WithEvents?

    Thanks again ...

  4. #4
    Are you seriously telling me that you can create and run macros, but cannot create a rule in Outlook? You must work in the public sector ◔̯◔ .
    You can use the bulk of the code to work as you suggest, if you transfer the correct syntax to your original effort.
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  5. #5
    VBAX Newbie
    Joined
    Mar 2020
    Posts
    3
    Location

    All sorted ...

    Quote Originally Posted by gmayor View Post
    Are you seriously telling me that you can create and run macros, but cannot create a rule in Outlook? You must work in the public sector ◔̯◔ .
    You can use the bulk of the code to work as you suggest, if you transfer the correct syntax to your original effort.
    Graham, itís not quite as harsh as that, but not far off - Iím retired, but using my Excel (wasnít supposed to be VBA which Iíd never touched before!) skills to help a charitable organisation (as a volunteer) use Excel ďproperlyĒ - but itís a one step at a time and a RegEdit is several steps away!!!

    But ... the good news is Iíve got it working with WithEvents - actually, it was already working, but I hadnít spotted I had a ďrogueĒ Outlook Data File that was set as the default - reset the default and allís well!!!

    But huge thanks for your response/help ...

    PS; I tried your code/Run a Script on my personal machine and it worked a treat ...

Tags for this Thread

Posting Permissions

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