Search code examples
vbaoutlookoutlook-filter

Executing VBA Script without access to the "Run a Script" rule in Outlook 2016


I have Outlook 2016 on my computer at work and the "Run a Script" rule has been disabled. I'm aware of the changes that should be made in the regedit file, but I need admin access to do so. My IT team is located across the country from me, so I've been waiting for two weeks for them to change this and I'm convinced that it's never going to happen.

So, I'm wondering if there's a workaround or a way to code the same process?

When I receive an e-mail with certain words in the subject line, I would like the rule/script to save the file attachment (inside the e-mail) into a folder on my computer.

I'm no VBA expert at all (especially with Outlook), so I'm probably far away from being on the right path, but I've given it a shot:

Private Sub Application_Startup()
    Dim oRule as Outlook.Rule
    Dim oRuleAction as Outlook.RuleAction
    Dim oRuleCondition as Outlook.RuleCondition

    Set oRule = colRules.Create("Transfer Attachment", olRuleSubject)
    Set oRuleCondition = oRule.Conditions.Subject("FINAL-CPW GRP SALES")
    Set oRuleAction = SaveAtlasReport
End Sub

Public Sub SaveAtlasReport()
    Dim att as Attachment
    Dim FileName as string

    FileName = "C:\Users\WCD1867\Documents\AttachTest\PositivePOS.xlsx"
    att.SaveAsFile FileName

End Sub

Solution

  • Replace your "Outlook Rule / Run a Script" with Items.ItemAdd Event (Outlook) and Items.Restrict Method (Outlook) to Filter Items by subject line.

    Example

    Private WithEvents Items As Outlook.Items
    Private Sub Application_Startup()
        Dim olNs As Outlook.NameSpace
        Dim Inbox  As Outlook.MAPIFolder
        Dim Filter As String
    
        Filter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & _
                           Chr(34) & " Like '%FINAL-CPW GRP SALES%' AND " & _
                           Chr(34) & "urn:schemas:httpmail:hasattachment" & _
                           Chr(34) & "=1"
    
        Set olNs = Application.GetNamespace("MAPI")
        Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
        Set Items = Inbox.Items.Restrict(Filter)
    
    End Sub
    
    Private Sub Items_ItemAdd(ByVal Item As Object)
        If TypeOf Item Is Outlook.mailitem Then
            Dim AtmtName As String
            Dim FilePath As String
                FilePath = "C:\Temp\"
            
            Dim Atmt As Attachment
            For Each Atmt In Item.Attachments
                AtmtName = FilePath & Atmt.FileName
                Debug.Print AtmtName ' Print on Immediate Window
                Atmt.SaveAsFile AtmtName
            Next
        End If
    End Sub
    

    Items.ItemAdd Event (Outlook) Occurs when one or more items are added to the specified collection. This event does not run when a large number of items are added to the folder at once. This event is not available in Microsoft Visual Basic Scripting Edition (VBScript).


    Items.Restrict method is an alternative to using the Find method or FindNext method to iterate over specific items within a collection. The Find or FindNext methods are faster than filtering if there are a small number of items. The Restrict method is significantly faster if there is a large number of items in the collection, especially if only a few items in a large collection are expected to be found.


    Filtering Items Using a String Comparison that DASL filters support includes equivalence, prefix, phrase, and substring matching. Note that when you filter on the Subject property, prefixes such as "RE: " and "FW: " are ignored.


    For those who wanna edit reg see https://stackoverflow.com/a/48778903/4539709