Copy attachement VBA problem

[danlod311]

Hello,

I have a VBA script running to copy the attachments on an email if the message subject is "Remote Transaction Files" the script is somewhat working. It will copy the first attachment to the directory but it wont copy the others, so if I have 4 attachments I only get the first 1 copied.

Can someone help me figure out what I'm doing wrong?


Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Folders("Automated Service").Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
'Only act if it's a MailItem
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set Msg = item
'Change variables to match need. Comment or delete any part unnecessary.
If (Msg.Subject = "Remote Transaction Files") And _
(Msg.Attachments.Count >= 1) Then

'Set folder to save in.
Dim olDestFldr As Outlook.MAPIFolder
Dim myAttachments As Outlook.Attachments
Dim Att As String

'location to save in. Can be root drive or mapped network drive.
Const attPath As String = "\\wtnas\public\AS-Recieve\"]\\wtnas\public\AS-Recieve\"


' save attachment
Set myAttachments = item.Attachments
Att = myAttachments.item(1).DisplayName
myAttachments.item(1).SaveAsFile attPath & Att

' mark as read
Msg.UnRead = False
End If
End If

[skatonni]

You need to loop through all attachments. Try this.


Dim attIndex As Long
Dim attCount As Long

' save attachment
Set myAttachments = Msg.Attachments
attCount = myAttachments.count

For attIndex = 1 To attCount
Att = myAttachments.item(attIndex).FileName
myAttachments.item(attIndex).SaveAsFile attPath & Att
Next

[danlod311]

This worked great! thank you!

I am hoping you can help me with one other thing, I don't want to copy any image files like JPG or Gif is there a way to limit this so that it wont copy certain file types?

[danlod311]

I'm trying to read through some tutorials but I'm lost... I just want the script to copy attachments that have the file extension of .REM and .PDF

Hopefully someone can help me out with this.

Thanks in advance

[skatonni]

This will work for extensions of any length


ext = (Right(Att, Len(Att) - InStrRev(Att, ".")))
If ext = "rem" Or ext = "pdf" Then
myAttachments.item(1).SaveAsFile attPath & Att

[danlod311]

Thanks for the help! :)

I have been playing with this but can't seem to get it to work, where would I add this to the existing code?

[SamT]

Replace all lines inside attindex Loop

[danlod311]

I'm not sure what I'm doing wrong.... I have been playing with this for quite some time now and it just gives me a compliance error after I replace the lines in the attindex loop. It gives me an error with the last "Next" saying "Next without For?

Can anyone show me what I have wrong, thanks in advance



Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Folders("Automated Service").Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
'Only act if it's a MailItem
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set Msg = item
'Change variables to match need. Comment or delete any part unnecessary.
If (Msg.Subject = "Remote Transaction Files") And _
(Msg.Attachments.Count >= 1) Then

'Set folder to save in.
Dim olDestFldr As Outlook.MAPIFolder
Dim myAttachments As Outlook.Attachments
Dim Att As String
Dim attIndex As Long
Dim attCount As Long

'location to save in. Can be root drive or mapped network drive.
Const attPath As String = "\\wtnas\public\AS-Recieve\"]\\wtnas\public\AS-Recieve\"


' save attachment
Set myAttachments = Msg.Attachments
attCount = myAttachments.Count


For attIndex = 1 To attCount
ext = (Right(Att, Len(Att) - InStrRev(Att, ".")))
If ext = "rem" Or ext = "pdf" Then
myAttachments.item(1).SaveAsFile attPath & Att

Next

' mark as read
Msg.UnRead = False
End If
End If
ProgramExit:
Exit Sub

ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub

[skatonni]

I'm not sure what I'm doing wrong.... I have been playing with this for quite some time now and it just gives me a compliance error after I replace the lines in the attindex loop. It gives me an error with the last "Next" saying "Next without For?



For attIndex = 1 To attCount
ext = (Right(Att, Len(Att) - InStrRev(Att, ".")))
If ext = "rem" Or ext = "pdf" Then
myAttachments.item(1).SaveAsFile attPath & Att
' something missing here
Next


An If statement of one line would be fine


If ext = "rem" Or ext = "pdf" Then myAttachments.item(1).SaveAsFile attPath & Att

More than one line and you need an End If.


If ext = "rem" Or ext = "pdf" Then
myAttachments.item(1).SaveAsFile attPath & Att
End If

[danlod311]

Great thanks! that makes complete sense, I get no errors now :)

However it doesn't copy any of the files either, any idea why? I read a few other threads and tried to change a few things but nothing has worked. It wont let me post the URL's yet though....

[skatonni]

Due to my inattention, copying and pasting, we are probably back to the original question.

' The index has to change to look at all attachments
myAttachments.item(attindex).SaveAsFile attPath & Att

To debug, mouse-click anywhere in the code. Press F8 repeatedly to step through the code.
http://www.cpearson.com/excel/DebuggingVBA.aspx