• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 699
  • 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

Featured Post

Free tool for managing users' photos in Office 365

Easily upload multiple users’ photos to Office 365. Manage them with an intuitive GUI and use handy built-in cropping and resizing options. Link photos with users based on Azure AD attributes. Free tool!

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