Attachements of an email

  • Thread starter Thread starter Thorsten Witt
  • Start date Start date
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
 
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
 
Back
Top