Hi

I currently have the code below which does the following, this is designed to reduce the amount of space I am using within my outlook profile by moving obvious documents to a network location. The code...

- scans all emails in the currently selected folder
- identifies all MS Office and PDF attachments
- saves the attachments to a network location within a folder that reflects the emails subject/timestamp (renaming duplicate filenames)
- adds a link to the start of the email to the attachment.

Works perfectly, except sometimes the emails have another email nested as an attachment (.msg). I was hoping to simply pass the attachment back into the ScanAttachment subroutine in order to scan the 'attachments of the attachment'.

I noticed a similar thread on here about printing attachments of attachments, however as the aim here is to reduce space used by the emails I need something that doesn't rely on creating a temporary file. I need to be able to find documents within the .msg attachments, save them, and then remove them so the .msg attachment is smaller in size.

I can manually double-click an email, double click an attachment of type .msg and then right-click and save / remove the attachments within the attachment, just struggling to do this in code.

Any suggestions?


Public Sub ArchiveFolder()

    Dim poFolder As Outlook.Folder, poFSO As Object, poMail As Outlook.MailItem, psMain$
    
    On Error GoTo ErrorArchiveFolderKB
    psMain = "\\server\share\very-long-nested-location"
    Debug.Print MapDrive("X:", psMain)
    Set poFSO = CreateObject("Scripting.FileSystemObject")
    Set poFolder = Application.ActiveExplorer.CurrentFolder
    On Error GoTo 0
    
    For Each poMail In poFolder.Items
        ScanAttachment poMail, poFSO, psMain
    Next
    MsgBox "Attachment Doc Archive completed", vbOKOnly

Exit Sub
        
ErrorArchiveFolderKB:
    MsgBox Err.Number & " " & Err.Description
    MsgBox poMail.Subject
    DoEvents
    Resume
End Sub

Public Sub ScanAttachment(ByRef oMail, ByVal oFSO, sMain$)
    
    Dim oAtt As Outlook.Attachments
    Dim lCount&, lFind&, lLoop&, lVer&, sBody$, sCheck$, sDir$, sExt$, sFile$, sFolder$
    
    On Error GoTo ErrorScanAttachment
    
    'ONLY scan emails and meeting requests that have attachments
    Set oAtt = oMail.Attachments
    If (oMail.Class = olMail Or oMail.Class = olMeetingRequest) And oAtt.Count > 0 Then
            
        For lLoop = oAtt.Count To 1 Step -1
                
            sExt = ""
            sFile = oAtt.Item(lLoop).FileName
            lFind = InStrRev(sFile, ".")
            If lFind <> 0 Then
                sExt = Right(sFile, Len(sFile) - lFind + 1)
                sFile = Trim(Left(Left(sFile, lFind - 1), 100))
            End If
                
            If InStr(".pdf.docb.docm.docx.dotm.dotx.ppsm.ppsx.pptm.pptx.pub.xlam.xlsb.xlsm.xlsx.xltx", LCase(sExt)) > 0 Then
                sFolder = Trim(Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(oMail.Subject, "\", "-"), "/", "-"), ":", "."), "*", "x"), "?", "-"), """", "''"), "<", "{"), ">", "}"), "|", "-"), 100))
                sFolder = "X:\" & Format(oMail.ReceivedTime, "YYYY") & "\" & Format(oMail.ReceivedTime, "YYYY-MM-DD hh.mm.ss") & " " & sFolder
                If Not (oFSO.FolderExists(sFolder)) Then oFSO.CreateFolder sFolder
                sCheck = sFile & sExt
                lVer = 0
                While oFSO.FileExists(sFolder & "\" & sCheck)
                    lVer = lVer + 1
                    sCheck = sFile & "_" & Format(lVer) & sExt
                Wend
                oAtt.Item(lLoop).SaveAsFile (sFolder & "\" & sCheck)
                sBody = oMail.HTMLBody
                lFind = InStr(LCase(sBody), "<body")
                lFind = InStr(lFind, sBody, ">")
                sBody = Left(sBody, lFind) & "<font face=Tahoma size=2><a href='" & sMain & Right(sFolder, Len(sFolder) - 2) & "\" & sCheck & "'>" & sCheck & "</a></font><br>" & Right(sBody, Len(sBody) - lFind)
                oMail.HTMLBody = sBody
                '### append attachment link to email
                oAtt.Item(lLoop).Delete
            End If
            
            If InStr(".msg", LCase(sExt)) > 0 Then
                'inception!
                ScanAttachment oAtt.Item(lLoop), oFSO, sMain
            End If
            
        Next lLoop
        
        oMail.Save
    End If
    
    On Error GoTo 0

Exit Sub
        
ErrorScanAttachment:
    MsgBox Err.Number & " " & Err.Description
    MsgBox oMail.Subject
    DoEvents
    Resume
End Sub