Script: Strip all attachments from incoming mail

This script can be a good friend if you get lots of attachments in your inbox and you wish to have it shipped somewhere else automatically.Here is how you do this:

1. Start Outlook
2. Press ALT+F11 to go into VB editor
3. Rightclick Project1 and choose Insert > Module
4. Click Module1 (can be renamed)
5. Paste in this code below
6. Change the row Const BASE_PATH = "H:\\MailAttachments\\" to where you wanna save the attachments. Make sure you created the folder it points to.
7. Click Save button
8. Make a rule with the script option (depends on which mails you want to strip)
9. Restart Outlook to have the script start working

Code:

Sub StripAttachments(Item As Outlook.MailItem)

On Error GoTo EarlyBath

Const BASE_PATH = "H:\\MailAttachments\\"

If Item.Class = olMail Then
If Item.Attachments.Count > 0 Then
Dim objAtt As Outlook.Attachments
Set objAtt = Item.Attachments
For Each objattach In objAtt
Dim i, lngCounter As Long
Dim strLogger, strFile, strLocalFileLink, strLocalPath, strUser, strFolder As String


lngCounter = Item.Attachments.Count
'Debug.Print lngcounter
strLogger = "-------------------------------------------------------------------------------------------------"

'organise folders by sender
strFolder = BASE_PATH & Item.SenderName & "\\"

If Dir(strFolder, vbDirectory) = "" Then
MkDir (strFolder)
End If

'organise subfolder by received date
strFolder = strFolder & Strings.Format(Item.ReceivedTime, "ddmmyyyy") & "\\"

If Dir(strFolder, vbDirectory) = "" Then
MkDir (strFolder)
End If


'create and display link to dest folder
strLocalPath = "file://" & Replace(strFolder, " ", "%20")
strLocalPath = Replace(strLocalPath, "\\", "\")
strLogger = strLogger & vbCrLf & "Attachment Path: " & strLocalPath & vbCrLf
strLogger = strLogger & vbCrLf & "The following attachments have been stripped from this message:"



'move through the attachments, saving the file, deleting from msg body and inserting links
For i = lngCounter To 1 Step -1

strFile = objAtt.Item(i).FileName
If Len(strFile) > 0 Then
Dim trimLen: trimLen = Len(strFile) - InStrRev(strFile, ".")
Dim time As String
time = Format(Now(), "hhmm")
strFile = strFolder & "\\" & time & "_" & strFile
objAtt.Item(i).SaveAsFile strFile
objAtt.Item(i).Delete
strLocalFileLink = Replace(strFile, "\\", "\")
strLocalFileLink = "file://" & Replace(strLocalFileLink, " ", "%20")

strLogger = strLogger & vbCrLf & vbCrLf & "Attachment " & lngCounter & ": " & strLocalFileLink
Else
End If
'strLogger = ""
SkipAtt:
Next i

strLogger = strLogger & vbCrLf & "-------------------------------------------------------------------------------------------------" & vbCrLf

Item.Body = strLogger & Item.Body
Item.Save
Next
Set objAtt = Nothing

End If
End If
EarlyBath:
Exit Sub
End Sub