Help to save attachments "Outlook item file"

[leemcder]

Good afternoon. I am using this macro which saves attachments which arrive in to my mailbox and saves them to a file location. It excludes .png and .gif files. It works fine except when someone attaches an outlook email as an attachment. File type "outlook item file" Is there any way for these attachments to be saved too? only .png and .gif is files are excluded so I can't see the issue?

Many thanks

Public Sub saveAttToDisk(item As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "Y:\accounts\Conv slips\"    'change path as you wish
For Each objAtt In item.Attachments
If Right$(objAtt.DisplayName, 3) = "png" Then 'in this case all files with extension "png" will be excluded (this excludes signatures)
GoTo LastLine
Else
If Right$(objAtt.DisplayName, 3) = "gif" Then
GoTo LastLine
Else
objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName
Set objAtt = Nothing
End If
End If
LastLine:
Next
End Sub

[gmayor]

The following will save attachments that are messages. It also ensures that existing files of the same name are not overwritten. Use the test macro to test it

Option Explicit

Sub TestSaveAttachments()
Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    SaveAttachments olMsg
lbl_Exit:
    Exit Sub
End Sub

Sub SaveAttachments(olItem As MailItem)
'Graham Mayor - http://www.gmayor.com - Last updated - 26 May 2017
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim j As Long
Const strSaveFldr As String = "Y:\accounts\Conv slips\"

    On Error Resume Next
    If olItem.Attachments.Count > 0 Then
        For j = 1 To olItem.Attachments.Count
            Set olAttach = olItem.Attachments(j)
            If Not olAttach.FileName Like "image*.*" Then
                strFname = olAttach.FileName
                strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
                strFname = FileNameUnique(strSaveFldr, strFname, strExt)
                olAttach.SaveAsFile strSaveFldr & strFname
                'olAttach.Delete        'delete the attachment
            End If
        Next j
        olItem.Save
    End If
lbl_Exit:
    Set olAttach = Nothing
    Set olItem = Nothing
    Exit Sub
End Sub

Private Function FileNameUnique(strPath As String, _
                                strFileName As String, _
                                strExtension As String) As String
'An Outlook macro by Graham Mayor
Dim lngF As Long
Dim lngName As Long
    lngF = 1
    lngName = Len(strFileName) - (Len(strExtension) + 1)
    strFileName = Left(strFileName, lngName)
    Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
    Exit Function
End Function

Private Function FileExists(filespec) As Boolean
'An Outlook macro by Graham Mayor
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(filespec) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
    Exit Function
End Function

[leemcder]

Excellent, thanks a lot, this works great! If I wanted to overwrite files with the same name, what would I change? sometimes amendments are made to documents and are emailed through again, so I would ideally I'd like files with the same name to be overwritten. Thank you.

[gmayor]

If you want to overwrite existing files then remove the lines:

strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46))) 
strFname = FileNameUnique(strSaveFldr, strFname, strExt)

from the main macro and the two additional functions are then superfluous.

[leemcder]

Brilliant, working perfectly now. Thanks so much.