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?

[Webinar] Streamline your web hosting managementRegister Today

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
Easily manage email signatures in Office 365

Managing email signatures in Office 365 can be a challenging task if you don't have the right tool. CodeTwo Email Signatures for Office 365 will help you implement a unified email signature look, no matter what email client is used by users. Test it for free!

 
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
All Courses

From novice to tech pro — start learning today.