How to remove JPEG / BMP / PDF TIFF attachment from the Mail in Outlook 2007

[earthworm]

Dear All,

I need to remove all the following attachments from my outlook 2007 archives . How to achieve this

Below are the files which i want to remove from outlook email attachments

1) JPEG
2) BMP
3) PDF
4) TIFF


All these might be present in my huge archive with emails . I dont want the email to be deleted , if any of these files found inside my email , then i want them to be deleted from my outlook 2007 only . The orginal email should be left intact .

Please help !!

 

[earthworm]

I have found the code . This code is working correctly , however there is one issue . this macro removes all the attachments to seperate folder inside an outlook email . but if there is any email attached within an email , below are the issue

1) It does extract that email , but the file size is 0kb , and i am unable to open that file .
2) If there is any attachment inside that email that is email --> email --> attachment , its not extracting those attachments as well.

Please suggest as i believe there only minor tweaking is required in this macro.

' Setup and instructions' (1) Digitally sign VBA project
' start->office->Microsoft office tools->digital certificates for VBA
' create a certificate
' (2) sign the code
' from Outlook -> menu -> Tools -> Macros -> Visual Basic Editor (VBA)
' project 1 -> Microsoft Office Outlook -> ThisOutlookSession (double ckick)
' * paste this source code *
' from Microsoft Visual Basic -> menu -> Tools -> digital signature -> (choose certificate previously created)
' (3) add icon on toolbar
' from outlook
' tools->customize (select "Commands" TAB)
' add icon on toolbar
' [rearrange commands] to change icon and name on toolbar
' (4) be sure that tools->macros->security
' on "thrusted publishers" "trust all installed add-ins and templates" is checked
'
'

Private Declare Function SHGetFolderPath Lib "shell32.dll" Alias "SHGetFolderPathA" ( _
ByVal HWnd As Long, ByVal csidl As Long, ByVal hToken As Long, ByVal dwFlags As Long, ByVal pszPath As String) As Long

Private Const MAX_PATH = 260&

Public Sub StripAttachments()
Dim ilocation As String
Dim objOL As Outlook.Application
Dim objMsg As Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolder As String

Dim result

'Put in the folder location you want to save attachments to
ilocation = GetSpecialFolder(&H5) & "\Removed Attachs\" ' CSIDL_MY_DOCUMENTS As Long = &H5"
On Error Resume Next

result = MsgBox("Do you want to remove attachments from selected email(s)?", vbYesNo + vbQuestion)
If result = vbNo Then
Exit Sub
End If

' Instantiate an Outlook Application object.
' Set objOL = CreateObject("Outlook.Application")
Set objOL = Application
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection

' Check each selected item for attachments.
' If attachments exist, save them to the Temp
' folder and strip them from the item.
For Each objMsg In objSelection
' This code only strips attachments from mail items.
If objMsg.Class = olMail Then
' Get the Attachments collection of the item.
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
' We need to use a count down loop for
' removing items from a collection. Otherwise,
' the loop counter gets confused and only every
' other item is removed.
strFile = ""
For i = lngCount To 1 Step -1
' Save attachment before deleting from item.
' Get the file name.

Dim strHTML As String
strHTML = "<li><a href=" & Chr(34) & "file:" & ilocation & objAttachments.Item(i).FileName & Chr(34) & ">" & objAttachments.Item(i).FileName & "</a><br>" & vbCrLf

strFile = strFile & strHTML


' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile (ilocation & objAttachments.Item(i))

' Save the attachment as a file.
objAttachments.Item(i).Delete
Next i

strFile = "Attachment removed from the message and backup-ed to[<a href='" & ilocation & "'>" & ilocation & "</a>]:<br><ul>" & strFile & "</ul><hr><br><br>" & vbCrLf & vbCrLf

Dim objDoc As Object
Dim objInsp As Outlook.Inspector
Set objInsp = objMsg.GetInspector
Set objDoc = objInsp.WordEditor


objDoc.Characters(1).InsertBefore strFile
objMsg.HTMLBody = strFile + objMsg.HTMLBody

Set objInsp = Nothing
Set objDoc = Nothing
End If
strFile = strFile & vbCrLf & vbCrLf
objMsg.Save
End If
Next

ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
Public Function GetSpecialFolder(FolderCSIDL As Long) As String
Dim HWnd As Long
Dim Path As String
Dim Res As Long
Dim ErrNumber As Long
Dim ErrText As String
Path = String$(MAX_PATH, vbNullChar)

''''''''''''''''''''''''''''''''''''''''''''
' get the folder name
''''''''''''''''''''''''''''''''''''''''''''
Res = SHGetFolderPath(HWnd:=0&, _
csidl:=FolderCSIDL, _
hToken:=0&, _
dwFlags:=0&, _
pszPath:=Path)
Select Case Res
Case S_OK
Path = TrimToNull(Text:=Path)
GetSpecialFolder = Path
Case S_FALSE
MsgBox "The folder code is valid but the folder does not exist."
GetSpecialFolder = vbNullString
Case E_INVALIDARG
MsgBox "The value of FolderCSIDL is not valid."
GetSpecialFolder = vbNullString
Case Else
ErrNumber = Err.LastDllError
ErrText = "ERROR!"
MsgBox "An error occurred." & vbCrLf & _
"System Error: " & CStr(ErrNumber) & vbCrLf & _
"Description: " & ErrText
End Select
End Function
Public Function TrimToNull(Text As String) As String
Dim N As Long
N = InStr(1, Text, vbNullChar)
If N Then
TrimToNull = Left(Text, N - 1)
Else
TrimToNull = Text
End If
End Function