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

Question

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

Oops! Can't believe I left that out. Sorry! I edited the question... 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. — Tom Sawyer

0m3r 0m3r · Accepted Answer · 2018-03-08T23:37:17

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

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

2 Answers