[Outlook 2003 VBA] Help to save two attached files in different paths with VBA

Not open for further replies.


Hi everybody!

Some month ago I started to program Outlook VBA. Currently I am facing one issue I am not been able to find the solution by myself:

I am trying to save two files (attached in the same e-mail)to different disk drive paths. In addition of this issue, what makes this issue complicated is that files has only the mid part of their name always with the same label, changing the beginning and the end of the FileName.

I developed the code pasted below, but the problem is the Index of attachments: files could be saved in the wrong folder, according their attachment index in the e-mail.

Do you have any suggestions to save the file "A" always in the folder "A", and the file "B" always in the folder "B"?

Here you are the code:

Private WithEvents Items As Outlook.Items
Option Explicit

Private Sub Application_Startup()
Dim objNS As Outlook.NameSpace
Dim X As Integer
Set objNS = GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
Application.ActiveExplorer.WindowState = olMaximized
End Sub

Private Sub Items_ItemAdd(ByVal item As Object)

Dim objNS As Outlook.NameSpace
Set objNS = GetNamespace("MAPI")

If TypeOf item Is Outlook.MailItem Then
 Dim Msg8 As Outlook.MailItem
 Set Msg8 = item

If (Msg8.SenderName = "sendername") And (Msg8.Attachments.Count > 0) Then
   Dim olDestFldr8 As Outlook.MAPIFolder
   Dim myAttachments8 As Outlook.Attachments
   Dim Att8 As String

   Const attPath8 As String = "Path"

   Set olDestFldr8 = objNS.Folders("Archivio 2010").Folders("Posta in arrivo")

   ' save attachment
   Set myAttachments8 = item.Attachments

   Dim u As Integer

   For u = 1 To myAttachments8.Count

   Att8 = myAttachments8.item(u).DisplayName

   On Error Resume Next
   myAttachments8.item(u).SaveAsFile attPath8 & Att8

   If Mid(Msg8.Attachments.FileName, 7, 9) = "CC+GENIAL" Then
       Kill (attPath8 & Att8)

       Dim Att81 As String
       Att81 = myAttachments8.item(1).DisplayName

       Const attPath81 As String = "Path\A\"

       myAttachments8.item(1).SaveAsFile attPath81 & Att81 
   End If

   If Mid(Msg8.Attachments.FileName, 7, 9) = "Giornalie" Then
       Kill (attPath8 & Att8)

       Dim Att82 As String
       Att82 = myAttachments8.item(2).DisplayName

       Const attPath82 As String = "Path\B\"
       myAttachments8.item(2).SaveAsFile attPath82 & Att82
   End If

   Next u

  Msg8.UnRead = False
   Msg8.Move olDestFldr8
 End If
End If
End Sub

Thanks in advance for any help!
Not open for further replies.