VBA save attachment by rule

gazmoz17

Board Regular
Joined
Sep 18, 2020
Messages
53
Office Version
  1. 365
Platform
  1. Windows
Hi,

Not sure if this a general VBA section or excel only....apologies in advance as this is an outlook question! ?

In an effort to become paperless, anything to do with purchase ledger, I want to make a script rule which sends to a sub folder, marks as certain category and saves attachment (90% of time PDF) in certain g:drive folder with a file naming convention.

Sub folders:
  1. Direct
  2. PO
  3. Confirmation
  4. Delivery Notes
  5. Invoices
  6. Statements


Categories:
  1. PO
  2. Confirmation
  3. Delivery Note
  4. Invoice
  5. Statement

;don't require a "Direct Category"

I'm able to use normal outlook rules for move to folder and assign category.....there's about 30 indiv rules based on supplier name etc that achieve this.

Had a look at some vba scripts but would I have to have 30 diff scripts to tag onto my 30 current move to folder/assign cat scripts. To assign the separate file name pathways?

Or can I adapt a script that knows if a email hits "Invoice" it saves to Gmail\blah\blah\Invoices.

Email hits Delivery Notes it saves to Gmail\blah\blah\Delivery Notes

File naming Convention; not thought too much into yet

Date & Time received email and who supplier is. Joe Bloggs Ltd 17/09/21 11.34am

Also a way of marking if any duplicate files Joe Bloggs Ltd 17/09/21 11.34am (2)

Many Thanks
Gareth
 

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
2,827
Office Version
  1. 2013
Platform
  1. Windows
If you're on Gmail I'm afraid I can't help you. If you're using Outlook the topic of the thread below is pretty much similar of what you want ...

 

gazmoz17

Board Regular
Joined
Sep 18, 2020
Messages
53
Office Version
  1. 365
Platform
  1. Windows
Hi many thanks for the reply & yes I am using outlook ?.

Its more than a little over my head!

So I have say 20 indiv outlook rules per Supplier which will put the email into my subfolder "Invoices".

Anything that hits "Invoices" sub folder I want the attachment saving in: G:\My Drive\Outlook attachments\Invoices

Could you please help with the below from your code:

VBA Code:
Public Sub Example()



Dim sOutlFldr As String

Dim sDiskFldr As String

Dim sFind As String



sOutlFldr = "Diagnostics Orders\Inbox" [COLOR=rgb(251, 160, 38)];is this my folder structure in outlook[/COLOR]

sDiskFldr = "C:\Users\Wassej03\Documents\IOVFs_Master\IOVFs_Master_2020" ; i[COLOR=rgb(251, 160, 38)]s this G:\My Drive\Outlook attachments\Invoices[/COLOR]

sFind = "IOVF"[COLOR=rgb(251, 160, 38)] ; confused on this as doesn’t need to search for anything specifically if can monitor “Invoices” subfolder for new attachments...if this is possible even?[/COLOR]



' save all attachments, do NOT include the email subject in the file name

Call Save_Email_Attachments(sOutlFldr, sDiskFldr, False)



' save specific attachments, include the email subject in the file name

Call Save_Email_Attachments(sOutlFldr, sDiskFldr, True, sFind)

End Sub

Many Thanks
 

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
2,827
Office Version
  1. 2013
Platform
  1. Windows
The code below saves the attachments of each email item based on the outlook folder where the email item is located rather than based on a rule.
Note that the code assumes an outlook root folder named "Archive" with the subfolders you mentioned directly below it. Code also assumes the presence of subfolders of the same name directly under the disk root folder. Change both names as required and see if this works for you.


VBA Code:
Public Sub gazmoz17()

    Const OUTLOOK_ROOTFOLDER As String = "Archive\"                                 ' <<< change to suit
    Const DISK_ROOTFOLDER    As String = "C:\Users\gazmoz17\OutlookAttachments\"    ' <<< change to suit

    Dim SubFolders  As Variant
    Dim sf          As Variant
    Dim OutlFolder  As String
    Dim DiskFolder  As String

    SubFolders = Array("PO", "Confirmation", "Delivery Note", "Invoice", "Statement")

    For Each sf In SubFolders

        OutlFolder = OUTLOOK_ROOTFOLDER & sf
        DiskFolder = DISK_ROOTFOLDER & sf

        ' save all attachments, do NOT include the email subject in the file name
        Call Save_Email_Attachments(OutlFolder, DiskFolder, False)

    Next sf
End Sub


Private Sub Save_Email_Attachments(ByVal argOutlookFolderPath As String, ByVal argDiskFolder As String, ByVal argSubject As Boolean, Optional ByVal argSearch As String = "")

    Dim oFSO    As Object
    Dim Itms    As Outlook.Items
    Dim Itm     As Outlook.MailItem
    Dim Att     As Outlook.Attachment
    
    Dim sPath   As String, sFullName As String, sSubject As String
    Dim bSave   As Boolean

    On Error Resume Next
    Set Itms = GetOutlookFolder(argOutlookFolderPath).Items
    On Error GoTo 0

    If Not Itms Is Nothing Then
        If Itms.Count > 0 Then
            Set oFSO = CreateObject("Scripting.FileSystemObject")
            If oFSO.FolderExists(argDiskFolder) Then
                For Each Itm In Itms
                    For Each Att In Itm.Attachments
                        If Len(argSearch) = 0 Then
                            bSave = True
                        ElseIf InStr(1, Att.Filename, argSearch, vbTextCompare) > 0 Then
                            bSave = True
                        Else
                            bSave = False
                        End If
                        
                        If bSave Then
                            If argSubject Then
                                sSubject = ValidateFileName(Att.Parent.Subject) & " - "
                            End If
                            sFullName = IIf(Right(argDiskFolder, 1) = "\", argDiskFolder, argDiskFolder & "\") & sSubject & Att.Filename
                            If oFSO.FileExists(sFullName) Then
                                sFullName = AddSuffix(sFullName)
                            End If
                            Att.SaveAsFile sFullName
                            DoEvents
                        End If
                        
                    Next Att
                Next Itm
            End If
        End If
    End If
End Sub


Function GetOutlookFolder(ByVal FolderPath As String) As Outlook.Folder

    Dim SubFolders      As Outlook.Folders
    Dim oFolder         As Outlook.Folder
    Dim FoldersArray    As Variant
    Dim i               As Integer

    On Error GoTo GetOutlookFolder_Error
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If

    'Convert folderpath to array
    FoldersArray = Split(FolderPath, "\")
    Set oFolder = Outlook.Application.Session.Folders.Item(FoldersArray(0))
    If Not oFolder Is Nothing Then
        For i = 1 To UBound(FoldersArray, 1)
            Set SubFolders = oFolder.Folders
            Set oFolder = SubFolders.Item(FoldersArray(i))
            If oFolder Is Nothing Then
                Set GetOutlookFolder = Nothing
            End If
        Next
    End If

    'Return the oFolder
    Set GetOutlookFolder = oFolder
    Exit Function

GetOutlookFolder_Error:
    Set GetOutlookFolder = Nothing
    Exit Function
End Function


Public Function ValidateFileName(ByVal argFileName As String) As String

    Const cUnwanted As String = "<>""/:\|?*"

    Dim sResult As String, i As Long

    sResult = argFileName
    For i = 1 To Len(cUnwanted)
        sResult = Replace(sResult, Mid(cUnwanted, i, 1), "_")
    Next
    ValidateFileName = sResult
End Function


Public Function AddSuffix(ByVal argFileName As String) As String
    
    Dim oFSO As Object, lPos As Long, sFile As String, sResult As String

    Set oFSO = CreateObject("Scripting.FileSystemObject")
    sResult = argFileName

    lPos = InStrRev(sResult, ".")
    If lPos = 0 Then
        sResult = UpdateFileSuffix(sResult)
    Else
        sFile = Left(sResult, lPos - 1)
        If Len(sFile) = 0 Then
            sFile = UpdateFileSuffix(sResult)
        Else
            sFile = UpdateFileSuffix(sFile)
        End If
        sResult = sFile & "." & Right(sResult, Len(sResult) - lPos)
    End If
    If oFSO.FileExists(sResult) Then
        AddSuffix = AddSuffix(sResult)
    Else
        AddSuffix = sResult
    End If
End Function


Public Function UpdateFileSuffix(ByVal argFileName As String) As String

    Dim sSfx As String, lPos As Long

    If Not argFileName Like "*(*)" Then
        UpdateFileSuffix = argFileName & "(1)"
    Else
        lPos = InStrRev(argFileName, "(") + 1
        sSfx = Mid(argFileName, lPos, Len(argFileName) - lPos)
        If IsNumeric(sSfx) Then
            UpdateFileSuffix = Left(argFileName, lPos - 1) & (CLng(sSfx) + 1) & ")"
        Else
            UpdateFileSuffix = argFileName & "(1)"
        End If
    End If
End Function
 

gazmoz17

Board Regular
Joined
Sep 18, 2020
Messages
53
Office Version
  1. 365
Platform
  1. Windows
Hi,

Thanks for the prompt reply ? appreciate it, been trying to do this for a while?‍♂️

I didn't give you the sub folder names accurately so I've changed your code to match rather than other way around in case changing sub folder names messes up my Move outlook scripts.

1632212526784.png


  1. From my screen shot above is the below correct:

Const OUTLOOK_ROOTFOLDER As String = "Archive\" ' <<< change to suit

So will my route folder be:

"emailallpst\" ?

or

"emailallpst\Inbox\"

2. Is my root folder correct, per below?

G:\My Drive\Outlook Subfolders


1632215932600.png




3. Where does the script need to be saved? Is below correct location, thanks?

1632216988856.png


Many Thanks
Gareth
 

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
2,827
Office Version
  1. 2013
Platform
  1. Windows
You are welcome.

1) looks like "emailallpst\Inbox\" would be correct.
2) correct.
3) in a separate module; perfect!
 

gazmoz17

Board Regular
Joined
Sep 18, 2020
Messages
53
Office Version
  1. 365
Platform
  1. Windows
Great thank you. Knew I should of took laptop home with me tonight to try it now you’ve confirmed….loser I know ? but will be a huge time saver and will help achieve main aim of being paperless.

Sorry for being thick….my move folder scripts will populate the subfolders and then will the attachments just start auto saving once new emails hit said subfolders?

Thanks
 

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
2,827
Office Version
  1. 2013
Platform
  1. Windows
Sorry for being thick….my move folder scripts will populate the subfolders and then will the attachments just start auto saving once new emails hit said subfolders?
No, they won't. You have to run that macro manually, but then you get duplicate attachments on the G: drive if you run it more than once, obviously.
So we have to ammend the code in a way that it's done automatically the moment the emails are moved from Inbox to another folder.
I'm gonna look into that.
 

gazmoz17

Board Regular
Joined
Sep 18, 2020
Messages
53
Office Version
  1. 365
Platform
  1. Windows
Argh ok with you ?. Many thanks appreciate you having a look to see if can be done.
 

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
2,827
Office Version
  1. 2013
Platform
  1. Windows
Forget about my previous code, it may be deleted.

Like the previous, the current code assumes that the deepest folder names of both the inbox and the G: drive are exactly the same, and that both exist. If these conditions are not met no errors are thrown, but nothing else happens as well. So beware for typos.

There is one macro (gazmoz17_RunOnce) that can be run once to save all attachments of the current email items within the subfolders of Inbox. For future email items the provided FolderEvents event handler ensures that prior to moving an email item from the Inbox to one of the folders below it, the attachments of that email item are saved to the corresponding folder on disk. To make this happen the InitializeInboxWatcher macro has to be invoked within each session. This is done within the Application_StartUp event handler which fires when Outlook opens. The FolderEvents event handler is only triggered when an item is been moved, not when an item is been copied. That's not because of my code, but because of Outlook's design.

This goes in a standard module:
VBA Code:
Option Explicit

Public InboxWatcher As FolderEvents

Public Sub gazmoz17_RunOnce()

    Const OUTLOOK_ROOTFOLDER As String = "\\emailallpst\Inbox\"                         ' <<< change to suit
    Const DISK_ROOTFOLDER    As String = "G:\My Drive\Outlook Subfolders\"              ' <<< change to suit

    Dim SubFolders  As Variant, sf As Variant
    Dim OutlFolder  As String, DiskFolder  As String

    SubFolders = Array("P.O.'s", "ConfirmationNEW", "Delivery Note", "Invoices", "Statements")

    For Each sf In SubFolders
        OutlFolder = ProperPath(OUTLOOK_ROOTFOLDER) & sf
        DiskFolder = ProperPath(DISK_ROOTFOLDER) & sf
        Call SaveMultiEmailsAttachments(OutlFolder, DiskFolder, False)
    Next sf
End Sub


Public Sub InitializeInboxWatcher()

    Const OUTLOOK_ROOTFOLDER As String = "\\emailallpst\Inbox\"                         ' <<< change to suit
    Const DISK_ROOTFOLDER    As String = "G:\My Drive\Outlook Subfolders\"              ' <<< change to suit

    Dim SubFolders  As Variant, sf As Variant, OutlFolder As String

    Set InboxWatcher = New FolderEvents
    InboxWatcher.Init GetAsOutlookFolder(OUTLOOK_ROOTFOLDER), DISK_ROOTFOLDER

    SubFolders = Array("P.O.'s", "Confirmation", "Delivery Note", "Invoices", "Statements")

    For Each sf In SubFolders
        OutlFolder = ProperPath(OUTLOOK_ROOTFOLDER) & sf
        InboxWatcher.Add GetAsOutlookFolder(OutlFolder)
    Next sf
End Sub


Public Function ProperPath(ByVal argFolder As String) As String
    ProperPath = IIf(Right(argFolder, 1) <> "\", argFolder & "\", argFolder)
End Function

Public Sub SaveSingleEmailAttachments(ByVal argMail As Outlook.MailItem, ByVal argDiskFolder As String)

    Dim FSO As Object, Att As Outlook.Attachment, FullName As String

    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FolderExists(argDiskFolder) Then
        For Each Att In argMail.Attachments
            FullName = ProperPath(argDiskFolder) & Att.FileName
            If FSO.FileExists(FullName) Then
                FullName = AddSuffix(FullName)
            End If
            Att.SaveAsFile FullName
        Next Att
        DoEvents
    End If
    Set FSO = Nothing
End Sub

Public Function GetAsOutlookFolder(ByVal FolderPath As String) As Outlook.Folder

    Dim SubFolders      As Outlook.Folders
    Dim oFolder         As Outlook.Folder
    Dim FoldersArray    As Variant
    Dim i               As Long

    On Error GoTo GetAsOutlookFolder_Error
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
    If Right(FolderPath, 1) = "\" Then
        FolderPath = Left(FolderPath, Len(FolderPath) - 1)
    End If
    FoldersArray = Split(FolderPath, "\")
    Set oFolder = Outlook.Application.Session.Folders.Item(FoldersArray(0))
    If Not oFolder Is Nothing Then
        For i = 1 To UBound(FoldersArray, 1)
            Set SubFolders = oFolder.Folders
            Set oFolder = SubFolders.Item(FoldersArray(i))
            If oFolder Is Nothing Then
                Set GetAsOutlookFolder = Nothing
            End If
        Next
    End If
    Set GetAsOutlookFolder = oFolder
    Exit Function

GetAsOutlookFolder_Error:
    Set GetAsOutlookFolder = Nothing
    Exit Function
End Function

Public Function AddSuffix(ByVal argFileName As String) As String
    
    Dim oFSO As Object, lPos As Long, sFile As String, sResult As String

    Set oFSO = CreateObject("Scripting.FileSystemObject")
    sResult = argFileName

    lPos = InStrRev(sResult, ".")
    If lPos = 0 Then
        sResult = UpdateFileSuffix(sResult)
    Else
        sFile = Left(sResult, lPos - 1)
        If Len(sFile) = 0 Then
            sFile = UpdateFileSuffix(sResult)
        Else
            sFile = UpdateFileSuffix(sFile)
        End If
        sResult = sFile & "." & Right(sResult, Len(sResult) - lPos)
    End If
    If oFSO.FileExists(sResult) Then
        AddSuffix = AddSuffix(sResult)
    Else
        AddSuffix = sResult
    End If
End Function

Public Function UpdateFileSuffix(ByVal argFileName As String) As String

    Dim sSfx As String, lPos As Long

    If Not argFileName Like "*(*)" Then
        UpdateFileSuffix = argFileName & "(1)"
    Else
        lPos = InStrRev(argFileName, "(") + 1
        sSfx = Mid(argFileName, lPos, Len(argFileName) - lPos)
        If IsNumeric(sSfx) Then
            UpdateFileSuffix = Left(argFileName, lPos - 1) & (CLng(sSfx) + 1) & ")"
        Else
            UpdateFileSuffix = argFileName & "(1)"
        End If
    End If
End Function

Public Sub SaveMultiEmailsAttachments(ByVal argOutlookFolderPath As String, ByVal argDiskFolder As String, ByVal argSubject As Boolean, Optional ByVal argSearch As String = "")

    Dim oFSO    As Object
    Dim Itms    As Outlook.Items
    Dim Itm     As Outlook.MailItem
    Dim Att     As Outlook.Attachment
    
    Dim sPath   As String, sFullName As String, sSubject As String
    Dim bSave   As Boolean

    On Error Resume Next
    Set Itms = GetAsOutlookFolder(argOutlookFolderPath).Items
    On Error GoTo 0

    If Not Itms Is Nothing Then
        If Itms.Count > 0 Then
            Set oFSO = CreateObject("Scripting.FileSystemObject")
            If oFSO.FolderExists(argDiskFolder) Then
                For Each Itm In Itms
                    For Each Att In Itm.Attachments
                        If Len(argSearch) = 0 Then
                            bSave = True
                        ElseIf InStr(1, Att.FileName, argSearch, vbTextCompare) > 0 Then
                            bSave = True
                        Else
                            bSave = False
                        End If
                        If bSave Then
                            If argSubject Then
                                sSubject = ValidateFileName(Att.Parent.Subject) & " - "
                            End If
                            sFullName = ProperPath(argDiskFolder) & sSubject & Att.FileName
                            If oFSO.FileExists(sFullName) Then
                                sFullName = AddSuffix(sFullName)
                            End If
                            Att.SaveAsFile sFullName
                            DoEvents
                        End If
                    Next Att
                Next Itm
            End If
        End If
    End If
End Sub

Public Function ValidateFileName(ByVal argFileName As String) As String

    Const cUnwanted As String = "<>""/:\|?*"
    Dim sResult As String, i As Long

    sResult = argFileName
    For i = 1 To Len(cUnwanted)
        sResult = Replace(sResult, Mid(cUnwanted, i, 1), "_")
    Next
    ValidateFileName = sResult
End Function


This goes in a Class module, to be named FolderEvents:
VBA Code:
Option Explicit

' Class FolderEvents

Private WithEvents myInboxFolder As Outlook.Folder

Private Type TFolderEvents
    DiskRoot        As String
    MoveToFolders   As Collection
End Type
Private this As TFolderEvents


Private Sub myInboxFolder_BeforeItemMove(ByVal Item As Object, ByVal MoveTo As MAPIFolder, Cancel As Boolean)
    Dim DiskFolder As String, pos As Long
    If TypeOf Item Is Outlook.MailItem Then
        If IsAMoveToFolder(MoveTo) Then
            DiskFolder = ProperPath(this.DiskRoot) & GetDeepestFolderName(MoveTo)
            SaveSingleEmailAttachments Item, DiskFolder
        End If
    End If
End Sub

Public Sub Init(ByVal argWatchFolder As Outlook.Folder, argDiskRootFolder As String)
    Set myInboxFolder = argWatchFolder
    this.DiskRoot = argDiskRootFolder
End Sub

Public Sub Add(ByVal argDestFolder As Outlook.Folder)
    If this.MoveToFolders Is Nothing Then
        Set this.MoveToFolders = New Collection
    End If
    this.MoveToFolders.Add argDestFolder
End Sub

Private Function IsAMoveToFolder(ByVal argFolder As Outlook.Folder) As Boolean
    Dim fld As Outlook.Folder
    For Each fld In this.MoveToFolders
        IsAMoveToFolder = fld.FolderPath = argFolder.FolderPath
        If IsAMoveToFolder Then Exit For
    Next fld
End Function

Private Function GetDeepestFolderName(ByVal argFolder As Outlook.Folder) As String
    Dim pos As Long, sPath As String
    sPath = argFolder.FolderPath
    pos = InStrRev(sPath, "\")
    If Not pos = 0 Then
        GetDeepestFolderName = Right(sPath, Len(sPath) - pos)
    End If
End Function


This goes in the ThisOutlookSession module:
VBA Code:
Option Explicit

Private Sub Application_Startup()
    InitializeInboxWatcher
End Sub
 

Forum statistics

Threads
1,176,086
Messages
5,901,300
Members
434,886
Latest member
qazibelal

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top