Saving file attachments
Hello,
I have a script that is supposed to read from a specific Public Folder to strip off file attachments on incoming emails. I am sure the scipt is correct but it does not run when Outlook starts. The script is supposed to run automatically when a new item shows up in that Public Folder. Here is the script.
Thanks.
JM
Dim WithEvents NewMailItems As Outlook.Items
Private Sub Application_Startup()
Set NewMailItems = Application.GetNamespace("MAPI").GetDefaultFolder( olFolderInbox).Items
End Sub
Private Sub NewMailItems_ItemAdd(ByVal msg As Object)
Dim myNS As NameSpace
Dim myInbox As MAPIFolder
Dim targetAttach As Attachment
Dim Dest As MAPIFolder
Dim f1 As MAPIFolder
Dim f2 As MAPIFolder
' Get a reference to the Inbox.
Set myNS = GetNamespace("MAPI")
Set myInbox = myNS.GetDefaultFolder(olFolderInbox)
Set Dest = Nothing
For Each f1 In myNS.Folders
For Each f2 In f1.Folders
If f2.Name = "Outgoing Messages" Then
Set Dest = f2
End If
Next
Next
'Process only mail messages.
If TypeOf msg Is MailItem Then
'Does this new message have any attachments?
For Each targetAttach In msg.Attachments
'Does this attachment have .oft in the filename?
If InStr(1, targetAttach.FileName, ".oft", vbTextCompare) > 0 Then
'Save off mail attachment and delete the message.
targetAttach.SaveAsFile "C:\DBUSAVE\" & targetAttach.DisplayName
msg.Delete
Exit For
End If
Next
End If
End Sub
|