More Outlook Resource Sites

Microsoft Developer Network (MSDN)

FAQs and other general resources

share code 23-May-2019 09:49

Looking for help with Outlook programming projects — VSTO, add-ins, VBA, custom Outlook forms, etc.? You′ve come to the right place!

NEW! >> Subscribe to this site via RSS. For more RSS options, see the complete list of feeds on our main news page.

Code level: intermediate    Code area: Basic Outlook Printer Friendly Version
Title: Auto-Save attachments to your hard drive.
Description: This script is fully functioning. I would like to think Sue Mosher for her help in solving some of my issues with it and especially for her GetFolder Function. This is designed to operate as an Outlook VB Script and will NOT run properly if used thru VB6 or .Net (or any other version!) This is also set up to be used as an action to be taken and must be configured through the Rules Wizard. Select the action "run a script" to use it. Here is the code, please let me know what you think.
Date: 19-Jan-2007  14:58
Code level: intermediate
Code area: Basic Outlook
Posted by: Steven Barker
This message is displayed as VB.NET
  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
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
All 99comments
Page [ 1 2 3 4 5 6 7 8 9 10 Next >>  
  19-Jan-2007  16:59   
If you want this to only run when you specifically run it, simply change

Sub SaveAllAttachments(objitem As MailItem)
                          TO
Sub SaveAllAttachments

and then you can run it as a macro using ALT + F8
 
  25-Feb-2007  00:46   
Will give this a try, im looking for a way to send torrent files to my home computer on email, then auto save the attachement to a specific location, so that the torrent client starts the download
  12-Mar-2007  08:14   
finally exactly what I was loking for...
but 'type mismatch error '- know what it means but not sure what to do about it any ideas?

 
  12-Mar-2007  08:17   
with ref to above

Set fld = GetFolder("Inbox\VCRTest\VCRin")

The getfolder function code is unchanged

Thanks to all

 
  19-Mar-2007  08:54   
Clare, that doesn't look like a complete folder path. It's missing the Inbox folder's parent folder.
  07-Jun-2007  10:01   
Without seeing your mailbox settings I cannot know for sure. But I think the line of code you need is actually written as so:

Set fld = GetFolder("Personal Folders\Inbox\VCRTest\VCRin")


If that does not work you need to post a screenshot of your mailboxes for me.
  12-Sep-2007  02:07   
Hi, I've got a problem with the script, it doesn't save my attachments (excel files).
  12-Sep-2007  08:29   
Loekes, if you comment the On Error statement, do you see errors?
  10-Oct-2007  04:53   
First of all i would like to thank his web and the guy who create VBA for this propose, so this is the VBA code i had modified and use with Rule.

Begin of Code =====

Sub SaveAllAttachments(objitem As MailItem)
    
    Dim objAttachments As Outlook.Attachments
    Dim strName, strLocation As String
    Dim dblCount, dblLoop As Double

    strLocation = "D:\Pools\"

    
    On Error GoTo ExitSub
     If objitem.Class = olMail Then
        Set objAttachments = objitem.Attachments
        dblCount = objAttachments.Count
        If dblCount <= 0 Then
          GoTo 100
        End If
        For dblLoop = 1 To dblCount
                strName = objAttachments.Item(dblLoop).FileName
                strName = strLocation & strName
                objAttachments.Item(dblLoop).SaveAsFile strName
         Next dblLoop
        objitem.Delete
    End If
100
ExitSub:
    Set objAttachments = Nothing
    Set objOutlook = Nothing
End Sub


End of Code =====

This script will start semiautomatic when out receive email.
  08-Dec-2007  23:59   
 Actually, you can do that without editing my script. You can set up a rule where when you "send/receive" it will automatically run the script and strip the attachments for you.
Page [ 1 2 3 4 5 6 7 8 9 10 Next >>