Link to home
Create AccountLog in
Avatar of NO_CARRIER
NO_CARRIER

asked on

Save outlook attachments to hard drive & rename

I have an Outlook macro that currently saves all e-mail attachments to the hard drive in a specified folder.
Now what I need to do is scan the message body, and rename the file on the computer to the name contained in the message body with an astrisk (or similar marker) in front of it.

For example, I could have an attachment named:
HelloWorld.jpg

In the e-mail message body I would have:
*John_Doe_1234567.jpg
*Chris_Smith_2343213.jpg
*Jane_Thompson_3324832.jpg

I want to save the HelloWorld.jpg 3 times to the hard drive, each time the filename changing to the 3 lines listed in the message body (without the astrisk)
The message body can contain anywhere from 1 filename up to 20 filenames... the filenames can be contained anywhere in the message body unfortunately.  (if the e-mail is forwarded a few times, the filenames will end up somewhere in the middle of the document.)

I'll attach the VB code I have to save the files to the computer currently...

Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
    Declare Sub Sleep Lib "kernel32" _
   (ByVal dwMilliseconds As Long)
 
Sub SaveAttachments()
Dim olkSelectedItems As Object, _
olkItem As Object, _
objFile As Object, _
strFilename As String
strFilename = ""
Set olkSelectedItems = Application.ActiveExplorer.Selection
For Each olkItem In olkSelectedItems
For Each objFile In olkItem.Attachments
strFilename = "c:\OutlookTemp\" & objFile.FileName
objFile.SaveAsFile strFilename
Next
Next
Set objFile = Nothing
Set olkItem = Nothing
Set olkSelectedItems = Nothing
End Sub

Open in new window

Avatar of NO_CARRIER
NO_CARRIER

ASKER

any ideas?
Avatar of David Lee
Hi, NO_CARRIER.

Can we depend on the fact that those file names will always be on separate lines and that there will not be any other text on those lines?  If the answer to both of these is yes, then this is easily done.
My favorite member, BlueDevil!
Yes and Yes.
Each file name will be on a separate line, and there will not be any other text on those lines.

Also (I'll give more points), is it possible to do this same thing if the Attachment is a part of a Task (or list of tasks) instead of attached to an Email?

Thanks!
> My favorite member, BlueDevil!
Thanks!

Replace the SaveAttachments sub you have now with the one below.  

> Also (I'll give more points), is it possible to do this same thing if the Attachment is a part of a Task (or list of tasks) instead of attached to an Email?
It's not possible to give more points, 500 is the limit.  I appreciate the thought though.  It's not necessary anyway.  The code will work for any item type as is.  
Sub SaveAttachments()
    Dim olkSelectedItems As Object, _
        olkItem As Object, _
        objFile As Object, _
        objDict As Object, _
        strFilename As String, _
        arrLines As Variant, _
        varName As Variant, _
        varTemp As Variant
    strFilename = ""
    Set objDict = CreateObject("Scripting.Dictionary")
    Set olkSelectedItems = Application.ActiveExplorer.Selection
    For Each olkItem In olkSelectedItems
        If olkItem.Attachments.Count > 0 Then
            arrLines = Split(olkItem.Body, vbCrLf)
            For Each varName In arrLines
                varTemp = Trim(varName)
                If Left(varTemp, 1) = "*" Then
                    If Not objDict.Exists(varTemp) Then
                        objDict.Add Mid(varTemp, 2), Mid(varTemp, 2)
                    End If
                End If
            Next
            arrLines = objDict.Items()
            For Each objFile In olkItem.Attachments
                For Each varName In arrLines
                    strFilename = "c:\OutlookTemp\" & varName
                    objFile.SaveAsFile strFilename
                Next
            Next
        End If
    Next
    Set objDict = Nothing
    Set objFile = Nothing
    Set olkItem = Nothing
    Set olkSelectedItems = Nothing
End Sub

Open in new window

BlueDevil; That's incredible, can't believe how simple you made that look.  I spent the week trying to break your code, and couldn't do it...works flawlessly.

Only one question, is it possible to make a popup window for if an astrisk is NOT found in an email/task, with the subject of the email in the popup window? (every email should have both an attachment AND filenames listed in the body...)  I will make a form and put a textbox on it, so before the macro runs it will verify that all the emails have a filename in them, and for any emails that do not have a filename in them, the subject names will be listed in the textbox so it can be resolved before the macro is run on the entire folder.

If you wish, I can ask this as a new question, as you have already answered the initial question in full.
Thanks.

Yes, I can do that.  Do you want a separate popup for each item not containing the asterisk, or do you want to scan all the items and then display a popup showing all the items without asterisks?

I'll leave that up to you.
I'd like to scan all the items first, then display them all in a popup showing all the items that don't have an asterisk.. (so the items can be resolved / modified) before the macro will successfully run....

Thanks again!

NC
ASKER CERTIFIED SOLUTION
Avatar of David Lee
David Lee
Flag of United States of America image

Link to home
membership
Create an account to see this answer
Signing up is free. No credit card required.
Create Account
Man that is much more advanced than what I was thinking, and 100x more useful too.  I never thought about displaying the offending emails in an IE window, and being able to click on them to open in Outlook.

The only problem I've found is the PreCheck doesn't work with Tasks / Task Attachments.

It says Type Mismatch on the following line:
For Each olkItem In olkSelectedItems

Which is odd, because in the SaveAttachments sub, this line doesn't cause any errors... any ideas?

NC
Nevermind, I wrote that before I looked at the code... I just had to change
Dim olkItem As Outlook.MailItem
to
Dim olkItem As Object

Thanks again...
   
eech! ... I ran into a problem, I never noticed this before...

When multiple items (either e-mail or tasks) with attachments have been selected.
Only the last attachment is saved, but it is saved under the names of ALL the filenames selected.

For example, if there are 2 email messages:

Email one contains: WORD.DOC ATTACHMENT
*MyDocument.doc
*MyDocument2.doc

Email two contains: EXCEL.XLS ATTACHMENT
*MyWorkbook.xls
*MyWorkbook2.xls

If I run the macro on both emails, only EXCEL.XLS is saved.  But it is saved under ALL 4 filenames. (MyDocument.doc ; MyDocument2.doc ; MyWorkbook.xls ; MyWorkbook2.xls )
Try this version.
Sub SaveAttachments()
    Dim olkSelectedItems As Object, _
        olkItem As Object, _
        objFile As Object, _
        objDict As Object, _
        strFilename As String, _
        arrLines As Variant, _
        varName As Variant, _
        varTemp As Variant
    strFilename = ""
    Set olkSelectedItems = Application.ActiveExplorer.Selection
    For Each olkItem In olkSelectedItems
        Set objDict = CreateObject("Scripting.Dictionary")
        If olkItem.Attachments.Count > 0 Then
            arrLines = Split(olkItem.Body, vbCrLf)
            For Each varName In arrLines
                varTemp = Trim(varName)
                If Left(varTemp, 1) = "*" Then
                    If Not objDict.Exists(varTemp) Then
                        objDict.Add Mid(varTemp, 2), Mid(varTemp, 2)
                    End If
                End If
            Next
            arrLines = objDict.Items()
            For Each objFile In olkItem.Attachments
                For Each varName In arrLines
                    strFilename = "c:\OutlookTemp\" & varName
                    objFile.SaveAsFile strFilename
                Next
            Next
        End If
    Next
    Set objDict = Nothing
    Set objFile = Nothing
    Set olkItem = Nothing
    Set olkSelectedItems = Nothing
End Sub

Open in new window

That works!

But now, another issue has come up... I'm still tinkering with it, hopefully I'll figure it out.
It seems there is a limitation to how many e-mails can be checked, or saved, at one time.  It always crashes on email number 249 (regardless of which emails I have selected...)  it error it gives is:

Run-time error '-1647296507 (9dd04055)':
Method 'Attachments' of object 'MailItem' failed

It gives the error on this line:
If olkItem.Attachments.Count > 0 Then
Are you sure the item is a mail item?
Yes, there are only mail items in my archived e-mails (where I wanted to run a test on a larger number of e-mails).  I added a debug count and the subject of the email to test on.  The email it stops on changes, depending on which emails I highlight, but the count always stops on 249 before the error occurs.
I should clarify, it's not when the 249th email is searched...
it's when the 249th email WITH an attachment is searched, does the error appear.
I understand that they all look like mail items, but are they in fact mail items?  Tracking receipts, meeting acceptance messages, task status updates, etc. all look like mail items, but they are actually different object types.  Some of them don't have an attachment property.  

Here's a code snippet you can use to test the item type.  It'll display a popup telling you which items, if any, aren't mail items.  Simply select a bunch of messages and run this macro.
Sub TestItemType()
    Dim olkItem As Object
    For Each olkItem In Application.ActiveExplorer.Selection
        If olkItem.Class <> olMail Then
            MsgBox olkItem.Subject, vbExclamation + vbOKOnly, "Test Item Type - Not A Mail Item"
        End If
    Next
    Set olkItem = Nothing
End Sub

Open in new window

BlueDevil.. I ran the macro, indeed they are all mailitem types. :( ... was hoping some of them wouldn't be.  The messages in the archive folder come to a particular mailbox, only instructions, most with TIF attachments.  Though the email format can change (html, plain text, etc.)...

Regardless of which mailbox I run the macro in, it always stops at that magical number for some reason... could it be a limitation of declaring as Objects?
Ok.  Thanks for testing.  I'm not aware of any limit so I'll have to try and duplicate the problem.  I'll be back as soon as I've done that.
I copied 320 mail items to a folder and have run the code against that folder several times.  It never fails.  I researched the error message as best I could and found a reference suggesting that the cause might be an object declaration.  I don't think that's it, but it can't hurt to try using an explicit object type.  Change

    olkItem As Object

back to

    olkItem As Outlook.MailItem

then try it against some mail items.  
Just curious, did all 320 mailitems have an attachment?
I found it fails only on the 249th item which also has an attachment... (it'll search through regular mail items without any problems.)

Here's something odd though:

I changed the object type back to explicit.. (olkItem As Outlook.MailItem)

And, while it gives an error on the 250th e-mail with attachment.. (regardless of which 250+ emails I select), the error has changed a bit:

The new error is:
Run-time error '13':
Type mismatch

The error occurs on the following line of the code:

  If olkItem.Attachments.Count > 0 Then
            arrLines = Split(olkItem.Body, vbCrLf)
            For Each varLine In arrLines
                varTemp = Trim(varLine)
                If Left(varTemp, 1) = "*" Then
                    bolPass = True
                    Exit For
                End If
            Next
            If Not bolPass Then
                strMessage = strMessage & "<tr><td><a href=""outlook:" & olkItem.EntryID & """>" & olkItem.Subject & "</a></td></tr>" & vbCrLf
            End If
        End If
    Next  <---------- error here

... are there any workarounds you can think of?  Perhaps have the macro select only 240 e-mails with an attachment at a time, and once it has been processed, perhaps put a flag on the e-mail or task item?.. or something to that effect?... Just thinking out loud here.. .
Yes, all 320 items have attachments.  But, maybe I was looking at the wrong code.  I thought we were talking about SaveAttachments, but the code you posted is from PreCheck.  Are both suffering from the same problem?  If not, which one is having the problem?  

The error code you're getting goes along with what I said earlier about one of the items not being a mail item.  Type mismatch means that the item causing the error is NOT a mail item.  
Odd...

the problem occurs for both the check attachments and the saving attachments, the error always occurs at the same place for both macros.  I'm going to try experimenting a bit... try running the macro on items in a personal folder (instead of located on the exchange server), or perhaps running the macro on some other PC's I have around.  If the error is not occuring for you, then there has to be something about the way I'm set up that is different... hopefully I can figure out what it is...
Hey!.. so looks like we figured it out.

If I move all the e-mail messages to a Personal Folder (on the local hard drive) the macro runs flawlessly every time. (even on as many as 1100 emails w/ attachments)

It seems like the problem only occurs when running against a large number of e-mails which are located on the server.  Perhaps the macro simply runs quicker than the server can retrieve information and burps, then crashes.  So that's not a big deal then, just have to move the e-mails over to a personal folder first.  This macro is going to save me tonnes of manual work BlueDevil... the alternative was to save each attachment individually, for as many as 2500 emails per week! :|
I was testing from a Personal Folder, so I guess that explains why I didn't run into the problem.  I'll try testing from a Exchange server too just to see if I can replicate the problem.  Glad you got it sorted out.  
Yeah, I've been doing a lot more testing today, and it's definitely when I run from the exchange server.
I suppose the problem also lies with the attachment sizes.  Each e-mail attachment can be anywhere from 500k - 12MB, and when running through 500+ e-mails with attachments, I suppose it bogs the server down.

Thanks again BlueDevil, I really REALLY appreciate all your help, and sticking around to help me troubleshoot this even after collecting your points; not a lot of people would do that.

+++ath0
NO CARRIER
Yeah, I suppose that could be a problem.  

Thanks, NC, and you're welcome.