Improve company productivity with a Business Account.Sign Up

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 700
  • Last Modified:

outlook macro save attachment to file

Hello,
I have a macro that saves an excel attachment of an e-mail to a specified folder on the harddisk. In this case, to "C:\Fixing Centa FXIP Index Report\FXIP1\".
I would also like to save it to another folder at the same time:
"C:\Fixing Centa FXIP Index Report\FXIP2\".

Can you help please?

Thanks,
Chris
Sub SaveAttachmentsToDiskRuleFXIP1(olkMessage As Outlook.MailItem)
    Dim olkAttachment As Outlook.Attachment, _
        objFSO As Object, _
        strRootFolderPath As String, _
        strFilename As String
    'Change the path on the following line to the folder you want the attachments save in
    strRootFolderPath = "C:\Fixing Centa FXIP Index Report\FXIP1\"
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set olkSourceFolder = Application.ActiveExplorer.CurrentFolder
    If olkMessage.Attachments.Count > 0 Then
        For Each olkAttachment In olkMessage.Attachments
            strFilename = olkAttachment.FileName
            intCount = 0
            Do While True
                If objFSO.FileExists(strRootFolderPath & strFilename) Then
                    intCount = intCount + 1
                    strFilename = "Copy (" & intCount & ") of " & olkAttachment.FileName
                Else
                    Exit Do
                End If
            Loop
            olkAttachment.SaveAsFile strRootFolderPath & strFilename
        Next
    End If
    Set objFSO = Nothing
    Set olkAttachment = Nothing
    Set olkMessage = Nothing
End Sub

Open in new window

0
CC10
Asked:
CC10
  • 2
1 Solution
 
David LeeCommented:
Hi, Chris.

If I've understood correctly you want the code to save to two folders simultaneously.  Assuming that's correct, then this should do it.
Sub SaveAttachmentsToDiskRuleFXIP1(olkMessage As Outlook.MailItem)
    'Change the path on the following line to the folder you want the attachments save in
    Const FOLDER_PATHS = "C:\Fixing Centa FXIP Index Report\FXIP1\,C:\Fixing Centa FXIP Index Report\FXIP2\"
    Dim olkAttachment As Outlook.Attachment, _
        objFSO As Object, _
        strRootFolderPath As String, _
        strFilename As String, _
        arrFolders As Variant, _
        varFolder As Variant
    arrFolders = Split(FOLDER_PATHS, ",")
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set olkSourceFolder = Application.ActiveExplorer.CurrentFolder
    If olkMessage.Attachments.count > 0 Then
        For Each olkAttachment In olkMessage.Attachments
            For Each varFolder In arrFolders
                strFilename = olkAttachment.FileName
                intCount = 0
                Do While True
                    If objFSO.FileExists(varFolder & strFilename) Then
                        intCount = intCount + 1
                        strFilename = "Copy (" & intCount & ") of " & olkAttachment.FileName
                    Else
                        Exit Do
                    End If
                Loop
                olkAttachment.SaveAsFile varFolder & strFilename
            Next
        Next
    End If
    Set objFSO = Nothing
    Set olkAttachment = Nothing
    Set olkMessage = Nothing
End Sub

Open in new window

0
 
CC10Author Commented:
Great. Thanks vm.
0
 
David LeeCommented:
You're welcome.  Glad I could help.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Get your problem seen by more experts

Be seen. Boost your question’s priority for more expert views and faster solutions

  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now