Announcement

Collapse
No announcement yet.

Unconfigured Ad Widget

Collapse

Saving excel attchements from microsoft outlook

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • Saving excel attchements from microsoft outlook

    I receive several email with a standard format attachment. I am trying to save the attachments to a folder on my desktop using a macro. I have used a code which I found on another post and it is not working. The code I used is shown below.
    Code:
    Public Sub SaveAttachments()
    Dim objOL As Outlook.Application
    Dim objMsg As Outlook.MailItem 'Object
    Dim objAttachments As Outlook.Attachments
    Dim objSelection As Outlook.Selection
    Dim I As Long
    Dim lngCount As Long
    Dim strFile As String
    Dim strFolderpath As String
    Dim strDeletedFiles As String
    
    
    ' Get the path to your My Documents folder
    strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
    On Error Resume Next
    
    
    ' Instantiate an Outlook Application object.
    Set objOL = CreateObject("Outlook.Application")
    
    
    ' Get the collection of selected objects.
    Set objSelection = objOL.ActiveExplorer.Selection
    
    
    ' Set the Attachment folder.
    strFolderpath = strFolderpath & "P:\Gestion de Congé\Congé Noel Concierge"
    
    
    ' Check each selected item for attachments. If attachments exist,
    ' save them to the strFolderPath folder and strip them from the item.
    For Each objMsg In objSelection
    
    
        ' This code only strips attachments from mail items.
        ' If objMsg.class=olMail Then
        ' Get the Attachments collection of the item.
        Set objAttachments = objMsg.Attachments
        lngCount = objAttachments.Count
        strDeletedFiles = ""
    
    
        If lngCount > 0 Then
    '        We need to use a count down loop for removing items
            ' from a collection. Otherwise, the loop counter gets
            ' confused and only every other item is removed.
    
    
            For I = lngCount To 1 Step -1
    
    
                ' Save attachment before deleting from item.
                ' Get the file name.
                strFile = objAttachments.Item(I).FileName
    
    
                ' Combine with the path to the Temp folder.
                strFile = strFolderpath & strFile
    
    
                ' Save the attachment as a file.
                objAttachments.Item(I).SaveAsFile strFile
    
    
                ' Delete the attachment.
                objAttachments.Item(I).Delete
    
    
                'write the save as path to a string to add to the message
                'check for html and use html tags in link
                If objMsg.BodyFormat <> olFormatHTML Then
                    strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
                Else
                    strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
                    strFile & "'>" & strFile & "</a>"
                End If
    
    
                'Use the MsgBox command to troubleshoot. Remove it from the final code.
                'MsgBox strDeletedFiles
    
    
            Next I
    
    
            ' Adds the filename string to the message body and save it
            ' Check for HTML body
            If objMsg.BodyFormat <> olFormatHTML Then
                objMsg.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body
            Else
                objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody
            End If
            objMsg.Save
        End If
    Next
    
    
    ExitSub:
    
    
    Set objAttachments = Nothing
    Set objMsg = Nothing
    Set objSelection = Nothing
    Set objOL = Nothing
    End Sub

  • #2
    Re: Saving excel attchements from microsoft outlook

    Thx for posting your code....
    It is not working
    Do you want to tell us what is not working, or do you want us to guess?

    What symptoms or errors are you seeing?

    Cheers
    Ger

    Check out our new reputation system. Click on the "star" under the post!
    _______________________________________________

    There are 10 types of people in the world. Those that understand Binary and those that dont.

    Why are Halloween and Christmas the same? Because Oct 31 = Dec 25...

    The BEST Lookup function of all time

    Dynamic Named Ranges are your bestest friend

    _______________________________________________

    Comment


    • #3
      Re: Saving excel attchements from microsoft outlook

      Hi,


      Sorry about that.The macro is giving me the message that it has saved the attachment in the file path I indicated. However when I go to the file path the attachments are not there. Also I don't want the attachment in outlook to be deleted.

      Comment


      • #4
        Re: Saving excel attchements from microsoft outlook

        Edited your code to this and it worked on my Outlook.
        (Added a folder to my desktop named "Outlook Attachments").
        Code:
        Public Sub SaveAttachments()
            Dim objOL As Outlook.Application
            Dim objMsg As Outlook.MailItem 'Object
            Dim objAttachments As Outlook.Attachments
            Dim objSelection As Outlook.Selection
            Dim I As Long
            Dim lngCount As Long
            Dim strFile As String
            Dim strFolderpath As String
            Dim strDeletedFiles As String
            
            
            ' Get the path to your My Documents folder
            strFolderpath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
            On Error Resume Next
            
            
            ' Instantiate an Outlook Application object.
            Set objOL = CreateObject("Outlook.Application")
            
            
            ' Get the collection of selected objects.
            Set objSelection = objOL.ActiveExplorer.Selection
            
            
            ' Set the Attachment folder.
            strFolderpath = strFolderpath & "\Outlook Attachments\"
            
            
            ' Check each selected item for attachments. If attachments exist,
            ' save them to the strFolderPath folder
            For Each objMsg In objSelection
                
                
                ' This code only strips attachments from mail items.
                ' If objMsg.class=olMail Then
                ' Get the Attachments collection of the item.
                Set objAttachments = objMsg.Attachments
                lngCount = objAttachments.Count
                strDeletedFiles = ""
                
                
                If lngCount > 0 Then
                    '        We need to use a count down loop for removing items
                    ' from a collection. Otherwise, the loop counter gets
                    ' confused and only every other item is removed.
                    
                    For I = lngCount To 1 Step -1
                        
                        ' Save attachment before deleting from item.
                        ' Get the file name.
                        strFile = objAttachments.Item(I).Filename
                        
                        ' Combine with the path to the Temp folder.
                        strFile = strFolderpath & strFile
                        
                        ' Save the attachment as a file.
                        objAttachments.Item(I).SaveAsFile strFile
                    Next I
                End If
            Next
            
            
        ExitSub:
            
            
            Set objAttachments = Nothing
            Set objMsg = Nothing
            Set objSelection = Nothing
            Set objOL = Nothing
        End Sub

        Comment


        • #5
          Re: Saving excel attchements from microsoft outlook

          [QUOTE=dangelor;783472]Edited your code to this and it worked on my Outlook.
          (Added a folder to my desktop named "Outlook Attachments").[CODE]Public Sub SaveAttachments()

          Hi,

          Thanks for your help. I have copied the code to my outlook and only cahnged the path for the folder on my desktop. It is still not working. The attachments are not saved in the path indicated. I am wondering whether it has something to do with my macro security set up or some other settings in microsoft outlook.

          Thank you for helping.


          Code:
           Public Sub SaveAttachmentsA()    Dim objOL As Outlook.Application
              Dim objMsg As Outlook.MailItem 'Object
              Dim objAttachments As Outlook.Attachments
              Dim objSelection As Outlook.Selection
              Dim I As Long
              Dim lngCount As Long
              Dim strFile As String
              Dim strFolderpath As String
              Dim strDeletedFiles As String
               
               
               ' Get the path to your My Documents folder
              strFolderpath = CreateObject("WScript.Shell").SpecialFolders("\C:\Users\sjugoo\Desktop")
              On Error Resume Next
               
               
               ' Instantiate an Outlook Application object.
              Set objOL = CreateObject("Outlook.Application")
               
               
               ' Get the collection of selected objects.
              Set objSelection = objOL.ActiveExplorer.Selection
               
               
               ' Set the Attachment folder.
              strFolderpath = strFolderpath & "\Outlook Attachements\"
               
               
               ' Check each selected item for attachments. If attachments exist,
               ' save them to the strFolderPath folder
              For Each objMsg In objSelection
                   
                   
                   ' This code only strips attachments from mail items.
                   ' If objMsg.class=olMail Then
                   ' Get the Attachments collection of the item.
                  Set objAttachments = objMsg.Attachments
                  lngCount = objAttachments.Count
                  strDeletedFiles = ""
                   
                   
                  If lngCount > 0 Then
                       '        We need to use a count down loop for removing items
                       ' from a collection. Otherwise, the loop counter gets
                       ' confused and only every other item is removed.
                       
                      For I = lngCount To 1 Step -1
                           
                           ' Save attachment before deleting from item.
                           ' Get the file name.
                          strFile = objAttachments.Item(I).FileName
                           
                           ' Combine with the path to the Temp folder.
                          strFile = strFolderpath & strFile
                           
                           ' Save the attachment as a file.
                          objAttachments.Item(I).SaveAsFile strFile
                      Next I
                  End If
              Next
               
               
          ExitSub:
               
               
              Set objAttachments = Nothing
              Set objMsg = Nothing
              Set objSelection = Nothing
              Set objOL = Nothing
          End Sub

          Comment


          • #6
            Re: Saving excel attchements from microsoft outlook

            Hello,

            I came across a macro which worked fine. It retrieves all my attachements which are in either excel, word or pdf and saves it on my desktop The macro is attached below. I am now trying to amend the macro so that it can open an outlook item (not an outlook attachment) whthin which is the attachement in excel format and save the file on my desktop. Thank you for helping.

            Code:
            Sub GetAttachments()
            On Error Resume Next
            'create the folder if it doesnt exists:
                Dim FSO, ttxtfile, txtfile, WheretosaveFolder
                Dim objFolders As Object
                Set objFolders = CreateObject("WScript.Shell").SpecialFolders
             
                'MsgBox objFolders("mydocuments")
                ttxtfile = objFolders("mydocuments")
                
                Set FSO = CreateObject("Scripting.FileSystemObject")
                Set txtfile = FSO.CreateFolder(ttxtfile & "\Email Attachments")
                ' Changes made by Andrew Davis ([email protected]) on October 28th 2015
                ' ------------------------------------------------------
                    ' Set fso = Nothing
                ' ------------------------------------------------------
                WheretosaveFolder = ttxtfile & "\Email Attachments"
                
            On Error GoTo GetAttachments_err
            ' Declare variables
                Dim ns As NameSpace
                Dim Inbox As MAPIFolder
                Dim Item As Object
                Dim Atmt As Attachment
                Dim FileName As String
                Dim i As Integer
                Set ns = GetNamespace("MAPI")
                'Set Inbox = ns.GetDefaultFolder(olFolderInbox)
                ' added the option to select whic folder to export
                Set Inbox = ns.PickFolder
                
                'to handle if the use cancalled folder selection
                If Inbox Is Nothing Then
                            MsgBox "You need to select a folder in order to save the attachments", vbCritical, _
                           "Export - Not Found"
                    Exit Sub
                End If
            
            
                ''''
                
            
            
                i = 0
            ' Check Inbox for messages and exit of none found
                If Inbox.Items.Count = 0 Then
                    MsgBox "There are no messages in the selected folder.", vbInformation, _
                           "Export - Not Found"
                    Exit Sub
                End If
            ' Check each message for attachments
                For Each Item In Inbox.Items
            ' Save any attachments found
                    For Each Atmt In Item.Attachments
                    ' This path must exist! Change folder name as necessary.
                    
                    ' Changes made by Andrew Davis ([email protected]) on October 28th 2015
                    ' ------------------------------------------------------
                        FileName = WheretosaveFolder & "\" & FSO.GetBaseName(Atmt.FileName) & i & "." & FSO.GetExtensionName(Atmt.FileName)
                    ' ------------------------------------------------------
                        Atmt.SaveAsFile FileName
                        i = i + 1
                     Next Atmt
                Next Item
            ' Show summary message
                If i > 0 Then
                    MsgBox "There were " & i & " attached files." _
                    & vbCrLf & "These have been saved to the Email Attachments folder in My Documents." _
                    & vbCrLf & vbCrLf & "Thank you for using Liron Segev - TheTechieGuy's utility", vbInformation, "Export Complete"
                Else
                    MsgBox "There were no attachments found in any mails.", vbInformation, "Export - Not Found"
                End If
                ' Changes made by Andrew Davis ([email protected]) on October 28th 2015
                ' ------------------------------------------------------
                    Set FSO = Nothing
                ' ------------------------------------------------------
            ' Clear memory
            GetAttachments_exit:
                Set Atmt = Nothing
                Set Item = Nothing
                Set ns = Nothing
                Exit Sub
            ' Handle errors
            GetAttachments_err:
                MsgBox "An unexpected error has occurred." _
                    & vbCrLf & "Please note and report the following information." _
                    & vbCrLf & "Macro Name: GetAttachments" _
                    & vbCrLf & "Error Number: " & Err.Number _
                    & vbCrLf & "Error Description: " & Err.Description _
                    , vbCritical, "Error!"
                Resume GetAttachments_exit
            End Sub

            Comment

            Trending

            Collapse

            There are no results that meet this criteria.

            Working...
            X