saving and removing attachments of attachments

[magnamundian]

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.x ltx", LCase(sExt)) > 0 Then
sFolder = Trim(Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(R eplace(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