Xtreme Visual Basic Talk

Xtreme Visual Basic Talk (http://www.xtremevbtalk.com/)
-   .NET Office Automation (http://www.xtremevbtalk.com/-net-office-automation/)
-   -   Problem automating Outlook 2013 to save attachments (http://www.xtremevbtalk.com/-net-office-automation/327915-automating-outlook-2013-save-attachments.html)

Qwanta 11-11-2015 07:30 AM

Problem automating Outlook 2013 to save attachments
 
Hi all!

I am trying to make a script that saves all attachments of a certain selection of emails in a specified directory. I have found the following code, it works perfect until it hits the 200st email then the script stops and displays an error:

Error -2147220731 (80040305) during runtime:
The server administrator has limited the amount of opened items. Try closing opened messages or try to remove attachments.

Ofcourse the administrator denies there being a limit set. I thought the problem may occur because the objects are loaded in memory and being kept in memory, so i tried putting the "Object" = Nothing in the loop instead of at the end of the code, to no avail. If anyone had any cleu i would be really happy :)


Code:

Option Explicit

Public Sub ExportAttachments()
    Dim objOL As Outlook.Application
    Dim objMsg As Object
    Dim objAttachments As Outlook.Attachments
    Dim objSelection As Outlook.Selection
    Dim i As Long, lngCount As Long
    Dim filesRemoved As String, fName As String, strFolder As String, saveFolder As String, savePath As String
    Dim alterEmails As Boolean, overwrite As Boolean
    Dim result
    Dim teller As Long
    Dim vraag As String
   
    saveFolder = BrowseForFolder("Select the folder to save attachments to.")
    If saveFolder = vbNullString Then Exit Sub
   
    Rem result = MsgBox("Do you want to remove attachments from selected file(s)? " & vbNewLine & _
    rem "(Clicking no will export attachments but leave the emails alone)", vbYesNo + vbQuestion)
    Rem alterEmails = (result = vbYes)
    alterEmails = "Onwaar"
   
    Set objOL = CreateObject("Outlook.Application")
    Set objSelection = objOL.ActiveExplorer.Selection
   
    vraag = InputBox("saveFolder='" & saveFolder & "' | alterEmails='" & alterEmails & "'")
   
    For Each objMsg In objSelection
        If objMsg.Class = olMail Then
            Set objAttachments = objMsg.Attachments
            lngCount = objAttachments.Count
            If lngCount > 0 Then
                teller = teller + 1
                filesRemoved = ""
                For i = lngCount To 1 Step -1
                    fName = objAttachments.Item(i).FileName
                    savePath = saveFolder & "\" & fName
                    overwrite = False
                    While Dir(savePath) <> vbNullString And Not overwrite
                        Dim newFName As String
                        newFName = fName & "_" & CStr(teller)
                        Rem newFName = InputBox("The file '" & fName & _
                        rem "' already exists. Please enter a new file name, or just hit OK overwrite.", _
                        rem "Confirm File Name", fName)
                        Rem If newFName = vbNullString Then GoTo skipfile
                        Rem If newFName = fName Then overwrite = True Else fName = newFName
                        savePath = saveFolder & "\" & newFName
                    Wend
                   
                    objAttachments.Item(i).SaveAsFile savePath
                   
                    If alterEmails Then
                        filesRemoved = filesRemoved & "<br>""" & objAttachments.Item(i).FileName & """ (" & _
                                                                formatSize(objAttachments.Item(i).size) & ") " & _
                            "<a href=""" & savePath & """>[Location Saved]</a>"
                        objAttachments.Item(i).Delete
                    End If
skipfile:
                Next i
               
                If alterEmails Then
                    filesRemoved = "<b>Attachments removed</b>: " & filesRemoved & "<br><br>"
                   
                    Dim objDoc As Object
                    Dim objInsp As Outlook.Inspector
                    Set objInsp = objMsg.GetInspector
                    Set objDoc = objInsp.WordEditor

                    objMsg.HTMLBody = filesRemoved + objMsg.HTMLBody
                    objMsg.Save
                End If
            End If
        End If
    Next
   
ExitSub:
    Set objAttachments = Nothing
    Set objMsg = Nothing
    Set objSelection = Nothing
    Set objOL = Nothing
End Sub

Function formatSize(size As Long) As String
    Dim val As Double, newVal As Double
    Dim unit As String
   
    val = size
    unit = "bytes"
   
    newVal = Round(val / 1024, 1)
    If newVal > 0 Then
        val = newVal
        unit = "KB"
    End If
    newVal = Round(val / 1024, 1)
    If newVal > 0 Then
        val = newVal
        unit = "MB"
    End If
    newVal = Round(val / 1024, 1)
    If newVal > 0 Then
        val = newVal
        unit = "GB"
    End If
   
    formatSize = val & " " & unit
End Function

'Function purpose:  To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE:  If invalid, it will open at the Desktop level
Function BrowseForFolder(Optional Prompt As String, Optional OpenAt As Variant) As String
    Dim ShellApp As Object
    Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, Prompt, 0, OpenAt)

    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
    Set ShellApp = Nothing
   
    'Check for invalid or non-entries and send to the Invalid error handler if found
    'Valid selections can begin L: (where L is a letter) or \\ (as in \\servername\sharename.  All others are invalid
    Select Case Mid(BrowseForFolder, 2, 1)
        Case Is = ":": If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
        Case Is = "\": If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
        Case Else: GoTo Invalid
    End Select
   
    Exit Function
Invalid:
    'If it was determined that the selection was invalid, set to False
    BrowseForFolder = vbNullString
End Function

Function BrowseForFile(Optional Prompt As String, Optional OpenAt As Variant) As String
    Dim ShellApp As Object
    Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, Prompt, 16 + 16384, OpenAt)
   
    On Error Resume Next
    BrowseForFile = ShellApp.self.Path
    On Error GoTo 0
    Set ShellApp = Nothing
   
    'Check for invalid or non-entries and send to the Invalid error handler if found
    'Valid selections can begin L: (where L is a letter) or \\ (as in \\servername\sharename.  All others are invalid
    Select Case Mid(BrowseForFolder, 2, 1)
        Case Is = ":": If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
        Case Is = "\": If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
        Case Else: GoTo Invalid
    End Select
   
    Exit Function
Invalid:
    'If it was determined that the selection was invalid, set to False
    BrowseForFile = vbNullString
End Function


Cerian Knight 11-11-2015 04:18 PM

Perhaps you should try issuing an explicit .Close before setting to Nothing. Since I'm not sure about the handshaking details before the object is actually disposed, you might need to delay between those two actions.

Let us know if that helps or not.

Qwanta 11-12-2015 03:27 AM

Hi Cerian Knight!

First off thank you for your swift reply, unfortunately the object doesnt support a .close property, nor does a delay in the code make a difference. The amount of items that is processed before the error is displayed is 247, it is stuck there everytime which suggest a memory issue.

Maybe you could give me an example based on the code i previously posted?

What i tried until now:
Adding a calculation in a loop for delay purposes.
Adding .close to various objects all gave an error about the syntax.

Flyguy 11-12-2015 07:46 AM

Maybe handle it in steps of 100.
So step out of the ExportAttachments method if you have processed 100 emails.
Then everything is closed, including the Outlook session.

Call the ExportAttachments routine in a loop until it doesn't find any unsaved attachments anymore.


All times are GMT -6. The time now is 02:07 AM.

Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2017, vBulletin Solutions, Inc.
Search Engine Optimisation provided by DragonByte SEO v2.0.15 (Lite) - vBulletin Mods & Addons Copyright © 2017 DragonByte Technologies Ltd.
All site content is protected by the Digital Millenium Act of 1998. Copyright©2001-2011 MAS Media Inc. and Extreme Visual Basic Forum. All rights reserved.
You may not copy or reproduce any portion of this site without written consent.