Sofware or VBA Code to remove Attachments

[HowardC]

It would be appreciated if someone can recommend software that one can use to remove attachments from Outlook already received or VBA code to remove these and to save these in a folder

[gmayor]

The following Outlook VBA code includes subs that will process a single message or a folder full of messages and save all the attachments in a named folder (which it will create if not present). Duplicated file names are not over-written. Put all the code in a new Outlook VBA module.

Note that in html e-mails any images are classed as attachments. If you want to remove the images also, move the line that deletes the attachment to the line after End If

                olAttach.SaveAsFile strSaveFldr & strFname
                olAttach.Delete        'delete the attachment
            End If

Option Explicit

Sub ProcessAttachment()
'An Outlook macro by Graham Mayor
Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    SaveAttachments olMsg
lbl_Exit:
    Exit Sub
End Sub

Sub ProcessFolder()
'An Outlook macro by Graham Mayor
Dim olNS As Outlook.NameSpace
Dim olMailFolder As Outlook.MAPIFolder
Dim olItems As Outlook.Items
Dim olMailItem As Outlook.MailItem
Dim oFrm As New frmProgress
Dim PortionDone As Double
Dim i As Long

    On Error GoTo err_Handler
    Set olNS = GetNamespace("MAPI")
    Set olMailFolder = olNS.PickFolder
    Set olItems = olMailFolder.Items
    oFrm.Show vbModeless
    i = 0
    For Each olMailItem In olItems
        i = i + 1
        PortionDone = i / olItems.Count
        oFrm.lblProgress.Width = oFrm.fmeProgress.Width * PortionDone
        SaveAttachments olMailItem
        DoEvents
    Next olMailItem
err_Handler:
    Unload oFrm
    Set oFrm = Nothing
    Set olNS = Nothing
    Set olMailFolder = Nothing
    Set olItems = Nothing
    Set olMailItem = Nothing
lbl_Exit:
    Exit Sub
End Sub


Private Sub SaveAttachments(olItem As MailItem)
'An Outlook macro by Graham Mayor
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim j As Long
Const strSaveFldr As String = "D:\Path\Reports\"

    CreateFolders strSaveFldr
    On Error GoTo CleanUp
    If olItem.Attachments.Count > 0 Then
        For j = olItem.Attachments.Count To 1 Step -1
            Set olAttach = olItem.Attachments(j)
            If Not olAttach.FileName Like "image*.*" Then
                strFname = olAttach.FileName
                strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
                strFname = FileNameUnique(strSaveFldr, strFname, strExt)
                olAttach.SaveAsFile strSaveFldr & strFname
                olAttach.Delete        'delete the attachment
            End If
        Next j
        olItem.Save
    End If
CleanUp:
    Set olAttach = Nothing
    Set olItem = Nothing
lbl_Exit:
    Exit Sub
End Sub

Private Function FileNameUnique(strPath As String, _
                                strFileName As String, _
                                strExtension As String) As String
'An Outlook macro by Graham Mayor
Dim lngF As Long
Dim lngName As Long
    lngF = 1
    lngName = Len(strFileName) - (Len(strExtension) + 1)
    strFileName = Left(strFileName, lngName)
    Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
    Exit Function
End Function

Private Function FileExists(filespec) As Boolean
'An Outlook macro by Graham Mayor
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(filespec) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
    Exit Function
End Function

Private Function FolderExists(fldr) As Boolean
'An Outlook macro by Graham Mayor
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If (fso.FolderExists(fldr)) Then
        FolderExists = True
    Else
        FolderExists = False
    End If
lbl_Exit:
    Exit Function
End Function

Private Function CreateFolders(strPath As String)
'An Outlook macro by Graham Mayor
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
    vPath = Split(strPath, "\")
    strPath = vPath(0) & "\"
    For lngPath = 1 To UBound(vPath)
        strPath = strPath & vPath(lngPath) & "\"
        If Not FolderExists(strPath) Then MkDir strPath
    Next lngPath
lbl_Exit:
    Exit Function
End Function

[HowardC]

Thanks for your reply and code Graham


I am familiar with VBA in Excel , but have never used it in Outlook

I need to know where to copy the code to i.e do I create an email template or can I set this up in Excel and then run the macro from there?

[gmayor]

Outlook VBA is very similar to Excel VBA, once you open the VBA editor. Insert a module in Project1 and copy allo the code there. Then locate the line

Const strSaveFldr As String = "D:\Path\Reports\"

and change that to reflect where you want the attachments to be saved.

Copy a message with attachments to a new Outlook folder, select it and run the macro ProcessAttachment. This will demonstrate how it works. If you are happy with the outcome, run the ProcessFolder macro, which will give you a prompt to select the folder to process.

You cannot run the macro from Excel, without extensive modification to it, and it only adds another set of potential problems to do so.

[HowardC]

Hi Graham

I created a folder in my inbox called remove attachments and moved an email there with an attachment. I inserted you code into the module for Project1 and then run the macro and it worked perfectly. I then moved another macro to the folder and then run the macro again and attachment not removed

It would be appreciated if you would shed some light on this

[HowardC]

Hi Graham

Have attached a screen print of the VBA Module, which may help you identify that I am copying the data into an incorrect module and what I need to do to rectify this


Regards

Howard

[gmayor]

You have the macro code in ThisOutlookSession. I said you should create a new module - Module1 seems to be that new module. The code should go in there.

With respect to the second message (I assume that is what you meant) did you select it before running the first macro, or did you run the second macro? One runs with the selected message, the other with the contents of the folder selected from the dialog box offered by the macro.

However the second macro includes a userform progress indicator which I forgot to mention. Sorry about that.

You can download the userform from http://www.gmayor.com/Forum/frmProgress.zip and import it into the VBA editor.

[HowardC]

Thanks for all your input , help and patience

Your code works perfectly