Automatically save attachments when mail received ...

[adambc]

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

[gmayor]

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/rules/outlook-run-a-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

[adambc]

[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/rules/outlook-run-a-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 ...

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

[adambc]

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