|
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: Miscellaneous
|
