Outlook VB Script to autosave attachments to drive

Question

I have created a rule in outlook that looks for a certain text string in the subject line, then moves the message to a folder and executes the script below. I want this to check the extension of the file if "JPG" then save it with a pre-defined string as the filename.

Public Sub saveAttachtoDisk_1(itm As Outlook.MailItem)
    Dim objAtt As Outlook.Attachment
    Dim saveFolder As String
    Dim dateFormat
    Dim FiledasName As String
    Dim objattext As String
    Dim objfso As Object

    dateFormat = Format(Now, "yyyy-mm-dd H-mm")
    saveFolder = "C:\Users\reeddl\Documents\Expenses_Image_Filing"

    Set objfso = CreateObject("Scripting.FileSystemObject")
    sExt = objfso.GetExtensionName(objAtt.FileName)

    For Each objAtt In itm.Attachments
        FiledasName = itm.Subject
        Set fso = New FileSystemObject
        If UCase(objfso.GetExtensionName(objAtt.Name)) = "JPG" Then
            MsgBox (objfso.GetExtensionName(objAtt.Name))
            objAtt.SaveAsFile saveFolder & "\" & dateFormat & FiledasName
        End If
        Set objAtt = Nothing
    Next
End Sub

The script errors with the following Run-time error

'429' ActiveX component can't create object.

This is at the
Set objfso = CreateObject("Scripting.FileSystemObject") line in the code.

I think I am declaring this incorrectly? Can anyone advise? Outlook 2016 on Windows.

Answer 1

I haven't tried it myself, but can you try using If UCase(objAtt.Name) Like "*.JPG" Then? Like this:

Public Sub saveAttachtoDisk_1(itm As Outlook.MailItem)
    Dim objAtt As Outlook.Attachment
    Dim saveFolder As String
    Dim dateFormat
    Dim FiledasName As String

    dateFormat = Format(Now, "yyyy-mm-dd H-mm")
    saveFolder = "C:\Users\reeddl\Documents\Expenses_Image_Filing"

    For Each objAtt In itm.Attachments
        FiledasName = itm.Subject
        Set fso = New FileSystemObject
        If UCase(objAtt.Name) Like "*.JPG" Then
            objAtt.SaveAsFile saveFolder & "\" & dateFormat & FiledasName
        End If
        Set objAtt = Nothing
    Next
End Sub

If you need to support more filetypes, you could try something like this:

Select Case UCase(Right(objAtt.Name, 3))
    Case "JPG", "PNG", "BMP", "GIF"
    objAtt.SaveAsFile saveFolder & "\" & dateFormat & FiledasName
End Select