Outlook attachements from a second PST file and VBA

[jonwas]

I have numerous times to find the right combination of VBA code (originally from Excel VBA) and then in conjunction with Outlook VBA to be able to do the following;
1) From the inbox of a second .pst file in my outlook tree
2) All messages with attachements containing *IOVF*
3) Place them in a specific folder on my computer

Reading the literature it appeared that a combination of a function and its call sub were necessary. I have included the code here. I get no error, however no action is taken...can you help?

Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
Dim oFolder As Outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer

On Error GoTo GetFolderPath_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.Item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetFolderPath = Nothing
End If
Next
End If
'Return the oFolder
Set GetFolderPath = oFolder
Exit Function

GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function
End Function
Private Sub Application_NewMail()
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 Items = GetFolderPath("Diagnostics Orders\Inbox").Items
Set Atts = Items.Attachments

If Atts.Count > 0 Then
For Each Att In Atts
If InStr(LCase(Att.FileName), "*" & "IOVF" & "*") > 0 Then
strPath = "C:\Users\Wassej03\Documents\IOVFs_Master\IOVFs_Master_2020"
strName = NewMail.Subject & " " & Chr(45) & " " & Att.FileName
Att.SaveAsFile strPath & strName
End If
Next
End If
End Sub

 

[GWteB]

In your code this line

If InStr (LCase (Att.FileName), "*" & "IOVF" & "*")> 0 Then

is the "bad guy".
This comparison will never evaluate to TRUE because the file name of the found attachment is converted to lowercase, after which a search is made within this converted string for something consisting only of upper case. Not sure about that but probably this line would work:

If InStr (LCase (Att.FileName), "iovf")> 0 Then

BTW, the InStr function does not treat the * as a wildcard so both should be removed (file names will not contain wildcard characters).

I modified and extended your code a bit and now it consists of six procedures. The Save_Email_Attachments procedure does the actual work, has four dependencies (**) and is called from the Example procedure.

Public Sub Example()

    Dim sOutlFldr   As String
    Dim sDiskFldr   As String
    Dim sFind       As String

    sOutlFldr = "Diagnostics Orders\Inbox"
    sDiskFldr = "C:\Users\Wassej03\Documents\IOVFs_Master\IOVFs_Master_2020"
    sFind = "IOVF"

    ' 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


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

(**)
the GetOutlookFolder function retrieves the required folder as an object;
The ValidateFileName function ensures that no invalid characters are used;
the AddSuffix function adds a numeric suffix in case of duplicate file names;
the UpdateFileSuffix function increases an existing numeric suffix in case of duplicate file names.