Consulting

Results 1 to 2 of 2

Thread: VBA Macros for Outlook 2013 for save attached files on hard drive

  1. #1
    VBAX Newbie
    Joined
    Oct 2014
    Posts
    1
    Location

    VBA Macros for Outlook 2013 for save attached files on hard drive

    Hi!
    I have found macros for Outlook to auto save attachments on disk C:\ from Outlook emails, but it doesn't work.
    Seems like this code was for early version of Outlook (I use 2013).
    Please help me to adapt this code for Outlook 2013:

    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("Index\Omniture")
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    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:\Omniture"
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    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.Save
    '''''''''''''''''''

    ' 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
    Sub Save_att()


    End Sub

  2. #2
    VBAX Mentor skatonni's Avatar
    Joined
    Jun 2006
    Posts
    347
    Location
    There is a lot to fix here. Once you get this working you can delete any unwanted comments. The green lines.

    Option Explicit ' <--- Important
    
    Sub SaveAllAttachments()
    ' In the original code, Sub Save_att() was likely what passed objitem
    '  to 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 strName As String, strLocation As String
    
    'Dim dblCount, dblLoop As Double
    Dim dblCount As Double, dblLoop As Double
    
    Dim Fld As Folder ' *** New line due to Option Explicit
    Dim strID As String ' *** New line due to Option Explicit
    Dim strExt As String ' *** New line due to Option Explicit
    
    ' 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..."
    On Error Resume Next
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Set Fld = GetFolder("Index\Omniture")
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    On Error GoTo 0
    If Fld Is Nothing Then
        MsgBox "Invalid Outlook folder location passed to GetFolder.", , "SaveAllAttachments"
        GoTo ExitSub
    End If
    
    On Error GoTo ErrorHandler
    '  If you do not see the errors then
    '  "I have found macros for Outlook to auto save attachments
    '    on disk C:\ from Outlook emails, but it doesn't work."
    
    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:\Omniture"
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
    ' New line ***
    If Right(strLocation, Len(strLocation)) <> "\" Then strLocation = strLocation & "\"
    
    ' Check each selected item for attachments.
    ' If attachments exist, save them to strLocation
    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
                ' New line *** The extension including the period can be either 4 or 5 characters long
                strExt = Mid$(strName, InStrRev(strName, ".")) 'Store file Extension including period
                
                'strName = Left$(strName, Len(strName) - 4) 'Remove file Extension
                ' Revised line ***
                strName = Left$(strName, Len(strName) - Len(strExt)) '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.Save    ' *** Not needed. objMessage was not changed
                '''''''''''''''''''
                ' 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
                
                Dim PauseTime, Start
                PauseTime = 1 / 86400 ' ( 1 day divided by 86400 seconds in a day =  1 second)
                Start = Now
                Do While Now < Start + PauseTime
                Loop
                ''''''''''''''''''''''''''''''''''''''''
            Next dblLoop
        End If
    100
    Next
    
    GoTo ExitSub
    
    ErrorHandler:
        MsgBox "ErrorHandler:" & vbCr & vbCr _
            & "Error Code: " & Err.Number & vbCr & vbCr & Err.Description, , "SaveAllAttachments"
        Err.Clear
    
    ExitSub:
        Set objAttachments = Nothing
        Set objMessage = Nothing
        Set objHighlighted = Nothing
        'Set objOutlook = Nothing
    End Sub
    To debug, mouse-click anywhere in the code. Press F8 repeatedly to step through the code. http://www.cpearson.com/excel/DebuggingVBA.aspx

    If your problem has been solved in your thread, mark the thread "Solved" by going to the "Thread Tools" dropdown at the top of the thread. You might also consider rating the thread by going to the "Rate Thread" dropdown.

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •