Looking for specific attachments in Outlook

In reference to this question ...

http://www.experts-exchange.com/Applications/MS_Office/Outlook/Q_22047080.html

Is it possible to make this go thru all the sub folders too?
LVL 18
kjanickeAsked:
Who is Participating?

Improve company productivity with a Business Account.Sign Up

x
 
David LeeConnect With a Mentor Commented:
Try this, Karyl.  I recommend putting this in a module by itself.

'Change the file name and path as needed.
Const strFilename = "C:\eeTesting\Attachment Search Results.htm"
Dim objFSO As Object, _
    objFile As Object, _
    colExtensions As New Collection, _
    objIE As Object

Sub FindSpecificAttachmentType()
    Dim varExtensions As Variant, _
        arrExtensions As Variant, _
        varExtension As Variant
    varExtensions = InputBox("Enter one or more extensions to search for." & vbCrLf _
        & "Separate multiple extensions with spaces." & vbCrLf _
        & "Example: jpg tif tiff", "Attachment Type Search")
    arrExtensions = Split(varExtensions, " ")
    If IsArray(arrExtensions) Then
        For Each varExtension In arrExtensions
            colExtensions.Add LCase(varExtension), LCase(varExtension)
        Next
    Else
        colExtensions.Add LCase(varExtensions)
    End If
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFile = objFSO.CreateTextFile(strFilename)
    SearchFolder Application.ActiveExplorer.CurrentFolder
    objFile.Close
    Set objFile = Nothing
    Set objFSO = Nothing
    Set colExtensions = Nothing
    Set objIE = CreateObject("InternetExplorer.Application")
    objIE.Navigate2 "file://" & strFilename
    Do While objIE.readyState <> 4
        DoEvents
    Loop
    objIE.Visible = True
    Set objIE = Nothing
End Sub

Sub SearchFolder(olkFolder As Outlook.MAPIFolder)
    Dim olkSubFolder As Outlook.MAPIFolder, _
        olkItem As Object, _
        olkAttachment As Outlook.Attachment
    For Each olkItem In olkFolder.Items
        If olkItem.Attachments.Count > 0 Then
            On Error Resume Next
            For Each olkAttachment In olkItem.Attachments
                varExtension = objFSO.GetExtensionName(LCase(olkAttachment.FileName))
                varItem = colExtensions.Item(varExtension)
                If Err.Number = 0 Then
                    strPath = olkItem.Parent.Path
                    objFile.WriteLine "<a href=""Outlook:" & olkItem.EntryID & """>" & olkItem.Subject & "</a><br>"
                    Exit For
                End If
            Next
            On Error GoTo 0
        End If
    Next
    For Each olkSubFolder In olkFolder.Folders
        SearchFolder olkSubFolder
    Next
    Set olkAttachment = Nothing
    Set olkItem = Nothing
    Set olkSubFolder = Nothing
End Sub
0
 
David LeeCommented:
Sure.  I'll make that change and get it posted as quick as I can (next 3-4 hours).
0
 
kjanickeAuthor Commented:
Have I told you before how much I love your code bits?

In the middle of a server crash so I'll have to try it later.

With my luck ... the next question i post will be "How do I recover testing all these code bits?"

THANKS!!!  You are awesome.
0
Free Tool: Path Explorer

An intuitive utility to help find the CSS path to UI elements on a webpage. These paths are used frequently in a variety of front-end development and QA automation tasks.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

 
David LeeCommented:
You're far too kind, but thanks!  Hope the server crash doesn't turn ugly.
0
 
kjanickeAuthor Commented:
It works!!!  Thank you!!!

Of course the other sysadmin had to try it at the root level of the mailbox or on their PST's right away and it errored.

But if they want other functionaility ... well ... we both need to learn to code.

You are awesome.  Thanks.  
0
 
David LeeCommented:
Hmmm, it shouldn't matter what level it's started at or what folder it starts in.  I'll run some test and see what's going on.
0
 
David LeeCommented:
Ok, I found a problem.  An error occurs when the code hits a Notes folder since notes don't support attachments.  I've adjusted the code to ignore everything but messages.  Replace the FindSpecificAttachmentType subroutine you have now with the one below.

Sub FindSpecificAttachmentType()
    Dim varExtensions As Variant, _
        arrExtensions As Variant, _
        varExtension As Variant
    varExtensions = InputBox("Enter one or more extensions to search for." & vbCrLf _
        & "Separate multiple extensions with spaces." & vbCrLf _
        & "Example: jpg tif tiff", "Attachment Type Search")
    arrExtensions = Split(varExtensions, " ")
    If IsArray(arrExtensions) Then
        For Each varExtension In arrExtensions
            colExtensions.Add LCase(varExtension), LCase(varExtension)
        Next
    Else
        colExtensions.Add LCase(varExtensions)
    End If
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFile = objFSO.CreateTextFile(strFilename)
    SearchFolder Application.ActiveExplorer.CurrentFolder
    objFile.Close
    Set objFile = Nothing
    Set objFSO = Nothing
    Set colExtensions = Nothing
    Set objIE = CreateObject("InternetExplorer.Application")
    objIE.Navigate2 "file://" & strFilename
    Do While objIE.readyState <> 4
        DoEvents
    Loop
    objIE.Visible = True
    Set objIE = Nothing
End Sub
0
 
kjanickeAuthor Commented:
People usually get paid for this sort of thing.  Shouldn't you compile it into some sort of outlook add-on and post it for sale someplace?
0
 
David LeeCommented:
Yeah, I probably should.  I don't for a couple of reasons.  One of those is that I've found lots and lots of functional sample code on the internet.  Code that's helped me a lot.  I enjoy the challenge of solving problems, and this is my way of giving something back.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.