Archive Outlook (2000-2003) Email Attachments Upon Arrival. (Embeds Link to Drive and Path within Email)
Here is some code that I thought might be useful. It has been compiled from the many samples that are available on the internet.
To configure, Open up the outlook VBA Editor and Cut and Paste the below section into the “ThisOutlookSession“
Additionally you will need to download and paste the code into another module called common.
http://www.trigeminal.com/code/guids.bas
Enjoy!
Option Explicit
Public SearchStatus As String
Public strPath As String
Sub ProcessRecursive()
Call SaveFileAttachmentsEvent(Application.ActiveExplorer.Session.GetDefaultFolder(olFolderInbox), True, True)
End Sub
Sub ProcessRecursiveRead()
Call SaveFileAttachmentsEvent(Application.ActiveExplorer.Session.GetDefaultFolder(olFolderInbox), True, False)
End Sub
Sub SaveFileAttachmentsEvent(objFolder As MAPIFolder, bRecursive As Boolean, bUnRead As Boolean)
Dim objFS As Object
Dim strFilePath As String
Dim strPathTemp As String
Dim objSubFolder As MAPIFolder
Set objFS = CreateObject("Scripting.FileSystemObject")
strPath = "x:\Outlook"
strPathTemp = Mid(objFolder.FolderPath, InStrRev(objFolder.FolderPath, "\") + 1, Len(objFolder.FolderPath))
If strPathTemp <> "Inbox" Then
strPath = strPath & "\" & strPathTemp
End If
If objFS.FolderExists(strPath) = False Then objFS.CreateFolder strPath
If bRecursive Then
For Each objSubFolder In objFolder.Folders
Call SaveFileAttachmentsEvent(objSubFolder, bRecursive, bUnRead)
Next ' SubFolder
End If
ProcessFolder objFolder, bUnRead
End Sub
Sub ProcessFolder(objFolder As MAPIFolder, bUnRead As Boolean)
Dim objItem 'As MailItem
Dim itemIndex As Long
Dim attachIndex As Long
Dim ToBeProcessed() As MailItem
Dim ToBeDeleted() As Attachment
Dim objAttachment As Attachment
Dim validFile As Boolean
Dim strScope As String
Dim strFilter As String
Dim strRead As String
Dim objSearch As Search
Dim strTag As String
Dim strFilePath As String
Dim i As Long
itemIndex = 0
Select Case bUnRead
Case True: strRead = "0"
Case False: strRead = "1"
End Select
strScope = "SCOPE ('shallow traversal of """ & objFolder.FolderPath & """')"
strFilter = """DAV:isfolder"" = false and ""urn:schemas:httpmail:hasattachment"" = true and ""urn:schemas:httpmail:read"" = " & strRead & ""
strTag = "AttachmentSearch"
SearchStatus = ""
Set objSearch = Application.AdvancedSearch(strScope, strFilter, False, strTag)
Do While SearchStatus = ""
DoEvents
Loop
For Each objItem In objSearch.Results
If (TypeOf objItem Is MailItem) And (objItem.UnRead = bUnRead) Then
itemIndex = 0 + 1
ReDim Preserve ToBeProcessed(itemIndex)
Set ToBeProcessed(itemIndex) = objItem
attachIndex = 0
For Each objAttachment In objItem.Attachments
Debug.Print "Processing..." & objAttachment.DisplayName
validFile = ValidAttachment(objAttachment.DisplayName)
If validFile = True Then
attachIndex = attachIndex + 1
strFilePath = strPath & "\" & StGuidGen() & "_" & objAttachment.DisplayName
'save them to destination
objAttachment.SaveAsFile strFilePath
'add name and destination to message text
If GetFileNameInMessage(objItem.Body) = "" Then
objItem.Body = objItem.Body & vbCrLf & "Removed Attachments:" & vbCrLf
objItem.Body = objItem.Body & "<<file://" & strFilePath & ">>" & vbCrLf
End If
ReDim Preserve ToBeDeleted(attachIndex)
Set ToBeDeleted(attachIndex) = objAttachment
End If
Next ' Attachment
For i = 1 To attachIndex
ToBeDeleted(i).Delete
Next 'attachIndex
If Not objItem.Saved Then objItem.Save
End If
Next 'MailItem
End Sub
Function GetFileNameInMessage(strBody) As String
Dim posStart As Long
Dim posEnd As Long
Dim offset As Long
Dim searchExp As String
searchExp = "file://"
offset = Len(searchExp)
posStart = InStrRev(strBody, searchExp, -1, vbBinaryCompare) + offset
posEnd = InStrRev(strBody, ">>", -1, vbBinaryCompare)
If (posStart < 1) Or ((posEnd - posStart) < posStart) Then
GetFileNameInMessage = ""
Else
GetFileNameInMessage = Mid(strBody, posStart, posEnd - posStart)
End If
End Function
Function ValidAttachment(fileName As String)
If InStr(1, fileName, ".") Then
ValidAttachment = True
Else
ValidAttachment = False
End If
End Function
Private Sub Application_AdvancedSearchComplete(ByVal SearchObject As Search)
SearchStatus = "Complete"
End Sub
Private Sub Application_NewMail()
Call SaveFileAttachmentsEvent(Application.ActiveExplorer.Session.GetDefaultFolder(olFolderInbox), False, True)
End Sub