none
Macro to save attachment

    Question

  • Hi,

    I'm looking forward to a makro which saves a csv-table automatically with the same name.

    The E-Mail is always from the same sender and comes everyday at the same time.

    I'm using Outlook 2007. Can you help me? Cause I'm a rookie in vba and the macros I find don't work.

    I want to please you to help me.

    Best regards

    Fabian

    Thursday, May 06, 2010 6:19 PM

All replies

  • See if some sample code can be found at http://www.outlookcode.com/
    Brian Tillman [MVP-Outlook]
    Thursday, May 06, 2010 7:30 PM
  • Hi,

    Based on my research, I find below code about how to Auto-Save attachments to hard drive.

    You can refer to it and hope it will be helpful.

    Sub SaveAllAttachments(objitem As MailItem)
        Dim objMessage As Object
        Dim objHighlighted As Outlook.Items
        Dim objAttachments As Outlook.Attachments
        Dim strName, strLocation As String
        Dim dblCount, dblLoop As Double
        ' If you are using this code you will need to edit this
        ' line so that it matches the location within outlook
        ' of the folder you intend to scan
        ' NOTE!! Only edit the "Personal Folders\Processing..."
       
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Set fld = GetFolder("Personal Folders\Processing...")
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    Set objHighlighted = fld.Items ' Tell it what to scan
        ' This is the location of the folder I want to save my attachments to
        ' You will most likely need to edit this to match the location of
        ' the folder you intend to save your attachments in.
        ' NOTE! Only edit C:\Documents and Settings\Administrator\Desktop\macro\
       
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        strLocation = "C:\Documents and Settings\Administrator\Desktop\macro\"
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
       
        On Error GoTo ExitSub
        ' Check each selected item for attachments.
        ' If attachments exist, save them to the Macro
        ' folder on the Desktop.
        For Each objMessage In objHighlighted   ' For each email in the folder
         If objMessage.Class = olMail Then  ' ONLY scan emails!!
                Set objAttachments = objMessage.Attachments
                ' Now to set my loop to the amount of attachments
                ' on the current email the script is processing.
                dblCount = objAttachments.Count
            If dblCount <= 0 Then GoTo 100  ' If no attachments exsist
                                            ' go to the next email.
                    ' I know this part looks weird...But If I counted
                    ' upwards, the script was not recognizing every
                    ' email and was skipping like half of them. By
                    ' counting downwards, this problem is resolved.
                    ' Thanks to Slovaktech.com for solving this one.
                For dblLoop = dblCount To 1 Step -1
                        ' This will be appended to the file name of each attachment to insure
                        ' that there are no duplicates, and therefor nothing gets overwritten
                        strID = " from " & Format(Date, "mm-dd-yy")           'Append the Date
                        strID = strID & " at " & Format(Time, "hh`mm`ss AMPM") 'Append the Time
                        ' These lines are going to retrieve the name of the
                        ' attachment, attach the strID to it to insure it is
                        ' a unique name, and then insure that the file
                        ' extension is appended to the end of the file name.
                        strName = objAttachments.Item(dblLoop).FileName 'Get attachment name
                        strExt = Right$(strName, 4)                     'Store file Extension
                        strName = Left$(strName, Len(strName) - 4)      'Remove file Extension
                        strName = strName & strID & strExt              'Reattach Extension
                        ' Tell the script where to save it and
                        ' what to call it
                        strName = strLocation & strName                 'Put it all together
                        ' Save the attachment as a file.
                        objAttachments.Item(dblLoop).SaveAsFile strName 'Save the attachment
                    ' This next line DELETES the email completly.
                    ' If you do not wish to delete the email
                    ' change this line to read  objMessage.Save
                   
                    '''''''''''''''''''
                    objMessage.Delete
                    '''''''''''''''''''
                   
                    ' This section of code is optional. It puts a 1 second
                    ' delay between file saves so that my strID is unique
                    ' for EVERY file. I do this because the script does
                    ' not confirm overwrites and this would be an issue for
                    ' the client I am writing this for. If this is not an
                    ' issue for you, just delete the entire section or
                    ' simply comment it out.
                   
                    ''''''''''''''''''''''''''''''''''''''''
                    Dim PauseTime, Start, Finish, TotalTime
                        PauseTime = 1
                        Start = Timer
                        Do While Timer < Start + PauseTime
                        Loop
                        Finish = Timer
                    ''''''''''''''''''''''''''''''''''''''''
                   
                Next dblLoop
             End If
    100
        Next
    ExitSub:
        Set objAttachments = Nothing
        Set objMessage = Nothing
        Set objHighlighted = Nothing
        Set objOutlook = Nothing
    End Sub

      ' This entire section of code was provided to me by Sue.
      ' This is NOT my work and I am NOT taking credit for it.
      '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Function GetFolder(FolderPath)
      ' folder path needs to be something like
      '   "Public Folders\All Public Folders\Company\Sales"
      Dim aFolders
      Dim fldr
      Dim i
      Dim objNS
      On Error Resume Next
      strFolderPath = Replace(FolderPath, "/", "\")
      aFolders = Split(FolderPath, "\")
      'get the Outlook objects
      ' use intrinsic Application object in form script
      Set objNS = Application.GetNamespace("MAPI")
      'set the root folder
      Set fldr = objNS.Folders(aFolders(0))
      'loop through the array to get the subfolder
      'loop is skipped when there is only one element in the array
      For i = 1 To UBound(aFolders)
        Set fldr = fldr.Folders(aFolders(i))
        'check for errors
        If Err <> 0 Then Exit Function
      Next
      Set GetFolder = fldr
      ' dereference objects
      Set objNS = Nothing
    End Function
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    Friday, May 07, 2010 7:17 AM
  • So I am using this exact script for 4 separate e-mails that I get every afternoon.  I am running it off of a rule and it always gets the first 3 but not the 4th.  It seems that the count is messed up.  It is grabbing the file from a message that is already in the folder but not the one that just came in.  That way it is getting the 1st 3 but not the last one until the next day when another e-mail comes into that folder.  When I tried to tell it to save the messages instead of deleting it saved 7 files, one of which was from the previous day.  Any ideas?

     

    Thanks,

    JL

    Wednesday, February 01, 2012 11:31 PM