Saving new attachments only.

[LudoTheGreat]

Hey all,

Quick run down of what I am trying to do. Every day we get some new files sent to us via attachments. I am trying to take these attachments and place them in a folder so that we can insert them into Excel document. I have the excel side figured out and the saving the attachements figured out, but I can not figure out how to make it only grab the attachemtns that do not already exists in the directory I am saving them to. Anyone have any ideas as to how I can do this? Here is what I have so far.

Sub SaveAttachments()
    Dim myOlapp As Outlook.Application
    Dim myNameSpace As Outlook.NameSpace
    Dim myFolder As Outlook.MAPIFolder
    Dim myItem As Outlook.MailItem
    Dim myAttachment As Outlook.Attachment
 
    Set myOlapp = CreateObject("Outlook.Application")
    Set myNameSpace = myOlapp.GetNamespace("MAPI")
    Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
    Set myFolder = myFolder.Folders("000")
 
    For Each myItem In myFolder.Items
        If myItem.Attachments.Count <> 0 Then
            For Each myAttachment In myItem.Attachments
                myAttachment.SaveAsFile "C:\Attachments\" & myAttachment & ".htm"
            Next
        End If
 
    Next
End Sub

[Charlize]

When you save the attachments from your email you can add a categorie to the email, let's say "Attachments saved". When you do this you'll have to save the modifications to the email. Next time you run your code, check also on a categorie "Attachments saved", this way you don't save them again.

When you deal with the attachments in excel, you either delete the attachments or move them to a different directory (already excelled).

Charlize

ps. What's with the ".htm" for your attachments ?

[LudoTheGreat]

This could work, I will have to give it a try later today.

The .htm is the only way I could get the files to be saved as their proper file type. If I did not keep it there it would save the document with the filename, but nothing for a file extension.

I am extremely new to all of this if you can not tell so if there is an easier way to do this, please do not hesitate to inform me as all this code is taken from what I could find on the web.

Edit: I decided to take it a different route and move the messages to a sub directory within outlook after the attachments have been saved. I have since run into a couple new issues. I can not get the files in the original dir to delete as well as the script seems to take a while to run. Since this code would be running on someones computer and attached to a rule for when the emails comes in there will be a number of times that the users comptuer will "freeze" while its running. I am not sure how to make it so it won't. Any suggestions would be greatly apprecitated. Here is the code as of now (note the .htm is now gone as it for some reason started adding the files extention automagicly):

Sub SaveAttachments()
    Dim myOlapp As Outlook.Application
    Dim myNameSpace As Outlook.NameSpace
    Dim myFolder As Outlook.MAPIFolder
    Dim myItem As Outlook.MailItem
    Dim myAttachment As Outlook.Attachment
 
    Set myOlapp = CreateObject("Outlook.Application")
    Set myNameSpace = myOlapp.GetNamespace("MAPI")
    Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
    Set myFolder = myFolder.Folders("000")
 
    For Each myItem In myFolder.Items
        If myItem.Attachments.Count <> 0 Then
            For Each myAttachment In myItem.Attachments
                myAttachment.SaveAsFile "C:\Attachments\" & myAttachment
            Next
        End If
 
        Set targetFolder = myFolder.Folders("111")
        If myItem.Attachments.Count > 0 Then
            Set targetMsg = myItem.Copy
 
            With targetMsg
                .Save
                .Move targetFolder
            End With
        End If
     Next
End Sub

[Charlize]

To look at some ideas : http://www.vbaexpress.com/kb/getarticle.php?kb_id=953
Don't promise a thing but you could try this one. Use F8 to step through your coding to see what's going on.[VBA]Sub SaveAttachments()
Dim myOlapp As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myFolder As Outlook.MAPIFolder
'subfolder of inbox
Dim mySubFolder As Outlook.MAPIFolder
'the folder where the message needs to be copied to
Dim targetfolder As Outlook.MAPIFolder
Dim myItem As Outlook.MailItem
'the targetitem is a message
Dim TargetMsg As Outlook.MailItem
Dim myAttachment As Outlook.attachment
'path to save attachments to
Dim myPath As String

Set myOlapp = CreateObject("Outlook.Application")
Set myNameSpace = myOlapp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
'The folder 000 is a subfolder of your inbox and must be present
Set mySubFolder = myFolder.Folders("000")
'Directory where to save attachments of the mails.
'Must exist
myPath = "C:\Attachments\"
For Each myItem In myFolder.Items
'check if myitem is a mailitem (can be invitation, read receipt, ...)
If myItem.Class = olMail Then
If myItem.Attachments.Count <> 0 Then
'check if subject contains Att - stripped
'if result = 0 then mail must be processed
If InStr(1, myItem.Subject, "Att - stripped") = 0 Then
For Each myAttachment In myItem.Attachments
myAttachment.SaveAsFile myPath & myAttachment.Filename
Next myAttachment
'add the text - Att - stripped to the subject
myItem.Subject = myItem.Subject & " - Att - stripped"
'save the mail
myItem.Save
'if destinationfolder is subfolder of inbox
Set targetfolder = myFolder.Folders("111")
'if destinationfolder is subfolder of 000
'Set targetfolder = mySubFolder.Folders("111")
Set TargetMsg = myItem.Copy
'move the copied myitem to the new destination folder
'the original message stays in the inbox
TargetMsg.Move targetfolder
End If
End If
End If
Next myItem
End Sub[/VBA]

A variation of this is by using a selection of mails that needs to be processed. A first draft on this one :[VBA]Sub Example_Using_Selection()
'The message you want to process
Dim MyMessage As Outlook.MailItem
'a number
Dim myItem As Long
'if selection isn't present, don't do a thing
'you could build an extra check if the class
'of the selected item is a message
If ActiveExplorer.Selection.Count < 1 Then
MsgBox "Select at least one mailmessage", vbInformation
Exit Sub
End If
For myItem = 1 To ActiveExplorer.Selection.Count
Set MyMessage = ActiveExplorer.Selection.item(myItem)
If MyMessage.Attachments.Count > 0 Then
MsgBox "Message has attachments", vbInformation
Else
MsgBox "Message has no attachments", vbInformation
End If
'go to next selected mail
Next myItem
End Sub[/VBA]Charlize

[LudoTheGreat]

Charlize, thanks for your help on this. I was actually checking out that link you posted last night seeing what I could come up with. I'll be playing about with this a bit more later this evening. Thanks again!

[LudoTheGreat]

Charlize,

This works perfect. The one thing I need it to do is delete the original message when it is done. Is there a simple way to do this? I tried changing Set TargetMsg = myItem.Copy to Set TargetMsg = myItem.Move, but it did not like this. Any suggestions?