Saving attatchments into different HDD directories

[jif308]

Hi,
Very new to this wonderful thing called VBA and am needing some help.
I'm trying to save attatchments into two different folders on my hdd.
One email I recieve has a *.csv file and the other email has a *pdf file. Both are from the same sender but have different subjects
I want one to go to c:/temp and the other to go to h:/temp
At the moment Im using this which is sending all files to the same directory. I dont know how to seperate.


[vba]
Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "h:\temp"
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName
Set objAtt = Nothing
Next
End Sub
[/vba]

Any help would greatly be appriciated

Thanks

[BrianMH]

[VBA]Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String

For Each objAtt In itm.Attachments
If UCase(objAtt.DisplayName) Like "*.CSV" Then
saveFolder = "c:\temp"
ElseIf UCase(objAtt.DisplayName) Like "*.PDF" Then
saveFolder = "h:\temp"
Else
saveFolder = "c:\junk"
End If
objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName
Set objAtt = Nothing
Next
End Sub[/VBA]

Not sure how you wanted to handle files that are neither pdf or csv so I coded it to put it into c:/junk. The folders need to exist or this will fail. You can edit the paths as necessary.

[jif308]

Thankyou very much Brian, that has worked perfect.
Only problem I have now is that with the csv files I recieve they all have the same name. Can I rename them automaticaly aswell?
ie invoice1, invoice2 etc

Thanks Again

[BrianMH]

I already have something for myself that does what you ask. I have posted it below and you can use that with your sub calling.

[vba]
Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String

For Each objAtt In itm.Attachments
If UCase(objAtt.DisplayName) Like "*.CSV" Then
saveFolder = "c:\temp"
ElseIf UCase(objAtt.DisplayName) Like "*.PDF" Then
saveFolder = "h:\temp"
Else
saveFolder = "c:\junk"
End If
Call downloadmail(itm, saveFolder)

Next
End Sub[/vba]
[vba]Sub downloadmail(myMailItem, strpath As String)
Dim strFileName As String
Dim strNewName As String
Dim strPre As String
Dim strExt As String
Dim myolAttachments As Attachments
Dim myolAtt As Attachment
Dim intExtlen As Integer
Dim w As Integer

Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")

If myMailItem.Attachments.Count <> 0 Then
Set myolAttachments = myMailItem.Attachments
For Each myolAtt In myolAttachments
strFileName = myolAtt.DisplayName
'find out if the file exists in the download location already and if so rename
'to a filename including a number eg. file(1).xls
If fs.fileexists(strpath & "\" & strFileName) = True Then
strNewName = strFileName
'get the length of the extension including the .
intExtlen = Len(strFileName) - InStrRev(strFileName, ".") + 1
'check there is actually a file extension and if not set extension to blank
'and set strPre to the full file name
If InStrRev(strFileName, ".") > 0 Then
strExt = Right(strFileName, intExtlen)
strPre = Left(strFileName, Len(strFileName) - intExtlen)
Else
strExt = ""
strPre = strFileName
End If
'increase the file number (w) until the file name no longer exists file(1).ext to file(2).ext etc
'strpre = filename before extension strext = extension w=file number
While fs.fileexists(strpath & "\" & strNewName) = True
w = w + 1
strNewName = strPre & Chr(40) & w & Chr(41) & strExt
Wend
'set the new filename
strFileName = strNewName
w = 0
End If
myolAtt.SaveAsFile strpath & "\" & strFileName
AttachmentCount = AttachmentCount + 1
Set myolAtt = Nothing
Next
End If
myMailItem.UnRead = False
Set myolAttachments = Nothing
Set myMailItem = Nothing
End Sub
[/vba]

BTW this will also mark the email as read. Edit to your needs.

[jif308]

I may seem stupid, but what fields to I need to change?

[BrianMH]

You don't need to edit it unless you didn't want out to mark it at read.

[jif308]

I copied and pasted both of those and it didnt work.

This is how I have it setup.

[VBA]
Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String

For Each objAtt In itm.Attachments
If UCase(objAtt.DisplayName) Like "*.CSV" Then
saveFolder = "C:\Paccar"
ElseIf UCase(objAtt.DisplayName) Like "*.PDF" Then
saveFolder = "H:\PARTS\PACCAR PARTS INVOICES\2012"
Else
saveFolder = "C:\Temp"
End If
objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName
Set objAtt = Nothing
Next
End Sub

Sub downloadmail(myMailItem, strpath As String)
Dim strFileName As String
Dim strNewName As String
Dim strPre As String
Dim strExt As String
Dim myolAttachments As Attachments
Dim myolAtt As Attachment
Dim intExtlen As Integer
Dim w As Integer

Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")

If myMailItem.Attachments.Count <> 0 Then
Set myolAttachments = myMailItem.Attachments
For Each myolAtt In myolAttachments
strFileName = myolAtt.DisplayName
'find out if the file exists in the download location already and if so rename
'to a filename including a number eg. file(1).xls
If fs.fileexists(strpath & "\" & strFileName) = True Then
strNewName = strFileName
'get the length of the extension including the .
intExtlen = Len(strFileName) - InStrRev(strFileName, ".") + 1
'check there is actually a file extension and if not set extension to blank
'and set strPre to the full file name
If InStrRev(strFileName, ".") > 0 Then
strExt = Right(strFileName, intExtlen)
strPre = Left(strFileName, Len(strFileName) - intExtlen)
Else
strExt = ""
strPre = strFileName
End If
'increase the file number (w) until the file name no longer exists file(1).ext to file(2).ext etc
'strpre = filename before extension strext = extension w=file number
While fs.fileexists(strpath & "\" & strNewName) = True
w = w + 1
strNewName = strPre & Chr(40) & w & Chr(41) & strExt
Wend
'set the new filename
strFileName = strNewName
w = 0
End If
myolAtt.SaveAsFile strpath & "\" & strFileName
AttachmentCount = AttachmentCount + 1
Set myolAtt = Nothing
Next
End If
myMailItem.UnRead = False
Set myolAttachments = Nothing
Set myMailItem = Nothing
End Sub
[/VBA]

[BrianMH]

Ok. Your code looks like it is handling multiple attachments. In this situation do your mails have multiple attachments of differing file types per mail?

[jif308]

It is moving the *.pdf file correctly. But the *.csv is not working.
It moves them to the correct directory but it only moves one of them. I'm guessing it is overwriting whatever already exits

[jif308]

Ok. Your code looks like it is handling multiple attachments. In this situation do your mails have multiple attachments of differing file types per mail?

The mail I recieve is from the same sender but I get two different emails.
One is sent with the *.pdf and another is sent with the *.csv

The *.pdf has the subject of Your Invoices and the *.csv has the title of Your CSV Invoices.

Once again, I thankyou for your help. I'm a complete novice when it comes to this stuff

[BrianMH]

Assuming the subjects are always exactly as you posted above then the below works.

Just to explain the first section just defines the folder path. The second section is a sub that downloads all the files in an email to the specified path. So it is passing the mailitem object (itm) and the path (saveFolder). This code includes adding a number to the end of a file. So for instance

file.txt
file(1).txt
file(2).txt
etc.

So you can reuse that part to download files to a folder by passing the mailitem as an object and the path to that sub.

[vba]Public Sub saveAttachtoDisk(itm As Outlook.MailItem)

Dim saveFolder As String

If Trim(itm.Subject) = "Your CSV Invoices" Then
saveFolder = "C:\Paccar"
ElseIf Trim(itm.Subject) = "Your Invoices" Then
saveFolder = "H:\PARTS\PACCAR PARTS INVOICES\2012"
Else
saveFolder = "C:\Temp"
End If
If itm.Attachments.Count > 0 Then
Call downloadmail(itm, saveFolder)
End If
Set objAtt = Nothing
Next
End Sub

Sub downloadmail(myMailItem, strpath As String)
Dim strFileName As String
Dim strNewName As String
Dim strPre As String
Dim strExt As String
Dim myolAttachments As Attachments
Dim myolAtt As Attachment
Dim intExtlen As Integer
Dim w As Integer

Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")

If myMailItem.Attachments.Count <> 0 Then
Set myolAttachments = myMailItem.Attachments
For Each myolAtt In myolAttachments
strFileName = myolAtt.DisplayName
'find out if the file exists in the download location already and if so rename
'to a filename including a number eg. file(1).xls
If fs.fileexists(strpath & "\" & strFileName) = True Then
strNewName = strFileName
'get the length of the extension including the .
intExtlen = Len(strFileName) - InStrRev(strFileName, ".") + 1
'check there is actually a file extension and if not set extension to blank
'and set strPre to the full file name
If InStrRev(strFileName, ".") > 0 Then
strExt = Right(strFileName, intExtlen)
strPre = Left(strFileName, Len(strFileName) - intExtlen)
Else
strExt = ""
strPre = strFileName
End If
'increase the file number (w) until the file name no longer exists file(1).ext to file(2).ext etc
'strpre = filename before extension strext = extension w=file number
While fs.fileexists(strpath & "\" & strNewName) = True
w = w + 1
strNewName = strPre & Chr(40) & w & Chr(41) & strExt
Wend
'set the new filename
strFileName = strNewName
w = 0
End If
myolAtt.SaveAsFile strpath & "\" & strFileName
AttachmentCount = AttachmentCount + 1
Set myolAtt = Nothing
Next
End If
myMailItem.UnRead = False
Set myolAttachments = Nothing
Set myMailItem = Nothing
End Sub
[/vba]

Don't worry about being a complete novice. I learned all I know completely from the help files, looking at others code and asking questions.

[jif308]

Thanks, I'll give that a go

[BrianMH]

Did this resolve your issue?