Attachements of an email

T

Thorsten Witt

Hi,

please help me, I am trying to do the following:

If I receive an email with an attachement the attachement should be
saved automatically in a special file in a special path of the PC.

The file name has to be the same name as the 7 last letters of the subject.

I have no idea how to realize it but may be you? (OU2000)

MAny Thanks in advance

BR
Thorsten
 
E

Eric Legault [MVP - Outlook]

Here's some code that will do what you want. Modify it as you see fit.


Option Explicit
Dim WithEvents objNewMailItems As Outlook.Items
Dim objNS As Outlook.NameSpace

Private Sub Application_Quit()
Set objNewMailItems = Nothing
Set objNS = Nothing
End Sub

Private Sub Application_Startup()
Dim objInbox As Outlook.MAPIFolder

Set objNS = Application.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objNewMailItems = objInbox.Items
End Sub

Private Sub objNewMailItems_ItemAdd(ByVal Item As Object)
On Error Resume Next

Dim objAtts As Outlook.Attachments, objAtt As Outlook.Attachment

'THIS WILL FIRE FOR EVERY NEW E-MAIL; YOU CAN USE THE
'Item OBJECT TO WORK WITH THE PROPERTIES OF THE E-MAIL MESSAGE

Set objAtts = Item.Attachments

If objAtts.Count = 0 Or objAtts Is Nothing Then Exit Sub 'No attachments

For Each objAtt In objAtts
'Saves attachment as file using the last 7 characters of the subject
line,
'and retains the file extension from the original attachment
filename
If Len(Item.Subject) >= 7 Then
objAtt.SaveAsFile "C:\Temp\" & Right(Item.Subject, 7) & "." &
Right(objAtt.FileName, 3)
Else
'Subject is too short - use the whole Subject
objAtt.SaveAsFile "C:\Temp\" & Item.Subject & "." &
Right(objAtt.FileName, 3)
End If
Next
End Sub
 
Top