Plateforme Level Extreme
Abonnement
Profil corporatif
Produits & Services
Support
Légal
English
Stripping Attachments from incoming mail messages
Message
De
05/06/2007 18:35:59
 
 
À
Tous
Information générale
Forum:
Microsoft Office
Catégorie:
Outlook
Titre:
Stripping Attachments from incoming mail messages
Divers
Thread ID:
01230771
Message ID:
01230771
Vues:
54
I am trying to create (so far mostly copied from Teach Yourself Outlook in 24 Hours) some VBA code to strip attachments of a specific file type and move them to a specified location. However I want it to run as an event within rules so as to catch the attachments automatically. So far the code I found works except for one nagging detail; it checks all the pre-existing email but does not check and strip the incoming email attachment which triggered the event.
Below is the code in question:
Sub Application_NewMail(Item As Outlook.MailItem)
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String

' Path where documents will be stored
strFolderpath = "\\server\location\

On Error Resume Next

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

'MsgBox strFolderpath

' 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
    

    'MsgBox 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.
        For i = lngCount To 1 Step -1
        'Check attachment extension to grab only the desired file type.
        'to change the type of files grabbed to another file type change the
        '"csv" to the apprpriate extention
        'if it is desire to catch all the attachments just comment out
        'the below if statement and related end if statement
            If Right(objAttachments.Item(i).FileName, 3) = "csv" Then
                ' Save attachment before deleting from item.
                ' Get the file name.
                strFile = objAttachments.Item(i).FileName
                ' Combine with the path to the Temp folder.
                strFile = strFolderpath & strFile
                ' Save the attachment as a file.
                objAttachments.Item(i).SaveAsFile strFile
                ' Delete the attachment.
                objAttachments.Item(i).Delete
                'write the save as path to a string to add to the message
                'check for html and use html tags in link
                If objMsg.BodyFormat <> olFormatHTML Then
                    strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
                    Else
                        strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
                        strFile & "'>" & strFile & "</a>"
                End If
            End If
            'MsgBox strDeletedFiles

        Next i
        
        ' End If
        ' Adds the filename string to the message body and save it
        ' Check for HTML body

        If objMsg.BodyFormat <> olFormatHTML Then
            objMsg.Body = objMsg.Body & vbCrLf & _
            "The file(s) were saved to " & strDeletedFiles
            Else
                objMsg.HTMLBody = objMsg.HTMLBody & "<p>" & _
                "The file(s) were saved to " & strDeletedFiles
        End If

        objMsg.Save

    End If
Next

ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
Thank for all of your help
Répondre
Fil
Voir

Click here to load this message in the networking platform