Sunday, February 06, 2005

MS Outlook Attachment Stripper

posted by ShyK at 01:32

My mail-box recently exceeded 1 GB, primarily because I had some 2000 items lying in the Deleted Items folders. Well, its not the first time my mailbox has exceeded 1 GB - but I usually acrhive of mails at the end of the project and manage to periodically get my Main PST file considerably down. Offlate, I am hitting the 1 GB faster and cannot afford to archive either. Hence the hunt for an attachment stripper that would go some way in cutting down the mailbox size.

There are a few "add-ins" available in the market that allow you to strip attachments off MS Outlook.

Read on to find my own work-in-progress version of the code...



Sub SaveAttachment()
'Declaration
Dim intAttCount, intdotloc As Integer
Dim strFolder, strFilename, strFile, strfilewoext, strfileext, strBfolder As String
Dim strAttList(100) As String
Dim objItems, objItem, objAttachments, objAttachment As Object
Dim objOlApp As New Outlook.Application
Dim objOlExp As Outlook.Explorer
Dim objOlSel As Outlook.Selection
Dim objFileSys As Scripting.FileSystemObject

On Error GoTo ERRORHANDLER

'Set/Get Base Folder
Set objFileSys = CreateObject("Scripting.FileSystemObject")
strBfolder = "C:\Mail\Attachments\"
strBfolder = InputBox("Base Folder", "Save Attachments", strBfolder)
If Not objFileSys.FolderExists(strBfolder) Then
objFileSys.CreateFolder (strBfolder)
End If

'work on selected items
Set objOlExp = objOlApp.ActiveExplorer
Set objOlSel = objOlExp.Selection

'for all items
For Each objItem In objOlSel

'of type e-mail
If objItem.Class = olMail Then

'Set attachments
Set objAttachments = objItem.Attachments
intAttCount = objAttachments.Count

'if there are attachments
If intAttCount > 0 Then

'if there are more than 100 attachments, die since strAttlist has max size 101.
If intAttCount > 100 Then
MsgBox "Message has more attachments than what this program can handle", vbCritical
End If

'Set destination folder based on Sent Date and Sent From
strFolder = strBfolder & Format(objItem.SentOn, "YYYY-MM-DD") & "\"
If Not objFileSys.FolderExists(strFolder) Then
objFileSys.CreateFolder (strFolder)
End If
strFolder = strFolder & objItem.SenderName & "\"
If Not objFileSys.FolderExists(strFolder) Then
objFileSys.CreateFolder (strFolder)
End If

'for all attachments do...
For i = 1 To intAttCount
'If the attachment is not a link
If Not (objAttachments(i).Type = olByReference) Then
'get file name and identify 'save' name
strFilename = objAttachments(i).DisplayName

'Folder s are by date and sender. Check if same sender has sent same file on same day
'If yes, add time stamp to avoide overwrite.
If objFileSys.FileExists(strFolder & strFilename) Then
intdotloc = InStrRev(strFilename, ".")
strfileext = Mid(strFilename, intdotloc)
strfilewoext = Mid(strFilename, 1, intdotloc - 1)
strfilewoext = strfilewoext & "_" & Format(objItem.SentOn, "HHMMSS")
strFile = strFolder & strfilewoext & "." & strfilext
Else
strFile = strFolder & strFilename
End If

'Save attachment to location/name specified
objAttachments(i).SaveAsFile strFile

'Create List of Saved attachments/locations
strAttList(i) = strFile
Else
'If the attachment is a link, link is not saved so file name needs to be destination
'rather than link itself - To be done.
'strAttList(i) = strFile
End If
Next i

'Remove Attachments
For i = 1 To intAttCount
'Use this method in Outlook XP
'objAttachments.Remove 1

'Use this method in Outlook 2000
objAttachments(1).Delete
Next i

'Add links
For i = 1 To intAttCount
strFile = strAttList(i)
objAttachments.Add strFile, olByReference, i, "Link To _ " & strFile
Next i

'Save Modified E-Mail
objItem.Save
End If
End If
Next

'free variables
Set objItems = Nothing
Set objItem = Nothing
Set objAttachments = Nothing
Set objAttachment = Nothing
Set objOlApp = Nothing
Set objOlExp = Nothing
Set objOlSel = Nothing

ERRORHANDLER:
If Err Then
MsgBox Err.Source & " - " & Err.Number & " - " & Err.Description, vbCritical
End If
End Sub

Labels:

Link to MS Outlook Attachment Stripper Post a comment 2 comments
Links to this post:
` `
2 Comments:

You might try the new Mozilla email client 'Thunderbird' I just switched to it from Outlook and have been enjoying no file size limits as well as a better email client.

-Chris

By Blogger Chris, at 12:13 AM  

Want more clicks to your Adsense Ads on your Blog?

Then you have to check out my blog. I have found a FREE and Legitimate way that will increase your earnings.

Come Check us out. How to Boost Your AdSense Revenue

By Blogger Google Page Rank 6, at 4:26 PM