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 ...

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/

Code:

---

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

---

[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 ...

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.

Quote:

---

Originally Posted by gmayor

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 ...