Sub SaveAndRemoveAttachments()
'Declaration
Dim CurrentItems, CurrentItem, EmailAttachments, myAttachment As Object
Dim SaveDirectory As String
Dim myOlApp As New Outlook.Application
Dim OutlookSess As Outlook.Explorer
Dim SelectedEmails As Outlook.Selection
Dim FSO As Object
Dim FolderCheck() As String
Dim Path As String
'SecurityManager.DisableOOMWarnings = True
'Ask for destination folder
SaveDirectory = InputBox("Destination", "Save Attachments", "C:\Archives\EmailAttachments\")
'leave if cancel pressed or no path passed in
If SaveDirectory = "" Then
Exit Sub
End If
SaveDirectory = Replace(SaveDirectory, "/", "\")
'check here to see if folder exists. If it doesn't use FSO to create it.
Set FSO = CreateObject("Scripting.FileSystemObject")
FolderCheck = Split(SaveDirectory, "\")
For i = 0 To UBound(FolderCheck)
Path = FSO.BuildPath(Path, FolderCheck(i))
If FSO.FolderExists(Path) = False Then
FSO.CreateFolder (Path)
End If
Next
On Error Resume Next
'work on selected items
Set OutlookSess = myOlApp.ActiveExplorer
Set SelectedEmails = OutlookSess.Selection
'get the selected items
For Each CurrentItem In SelectedEmails
Set EmailAttachments = CurrentItem.Attachments
If EmailAttachments.Count > 0 Then 'check if there are attachments
'add removal header
CurrentItem.Body = CurrentItem.Body & vbCrLf & vbCrLf & vbCrLf & "Removed Attachments:" & vbCrLf
For i = 1 To EmailAttachments.Count 'remove each attachment and add message stating removed
EmailAttachments(i).SaveAsFile SaveDirectory & DatePart("YYYY", CurrentItem.CreationTime) & Right("0" & DatePart("M", CurrentItem.CreationTime), 2) & Right("0" & DatePart("D", CurrentItem.CreationTime), 2) & "-" & Right("0" & DatePart("H", Now()), 2) & Right("0" & DatePart("N", CurrentItem.CreationTime), 2) & Right("0" & DatePart("S", CurrentItem.CreationTime), 2) & "_" & EmailAttachments(i).DisplayName
CurrentItem.Body = CurrentItem.Body & "File: " & EmailAttachments(i).DisplayName & " To: " & SaveDirectory & DatePart("YYYY", CurrentItem.CreationTime) & Right("0" & DatePart("M", CurrentItem.CreationTime), 2) & Right("0" & DatePart("D", CurrentItem.CreationTime), 2) & "-" & Right("0" & DatePart("H", Now()), 2) & Right("0" & DatePart("N", CurrentItem.CreationTime), 2) & Right("0" & DatePart("S", CurrentItem.CreationTime), 2) & "_" & EmailAttachments(i).DisplayName & vbCrLf
Next i
'Remove attachment from email
Do Until EmailAttachments.Count = 0
If IsEmpty(EmailAttachments) Then
Exit Do
End If
'remove it (use this method in Outlook 2000)
EmailAttachments(1).Delete 'EmailAttachments.Remove 1 for office XP
Loop
CurrentItem.Save 'save the email without attachment
End If
Next
'cleanup
Set CurrentItems = Nothing
Set CurrentItem = Nothing
Set EmailAttachments = Nothing
Set myAttachment = Nothing
Set myOlApp = Nothing
Set OutlookSess = Nothing
Set SelectedEmails = Nothing
'SecurityManager.DisableOOMWarnings = False
End Sub
Facebook
Twitter