none
Need help with OL2007 AdvancedSearch macro, please RRS feed

  • Question

  • I am pretty good with Word and Excel VBA, but brand new to Outlook. So this AdvancedSearch macro was cobbled together from various internet postings. It works, but returns different results than a manual advanced search.  (And it runs slower than a one-legged dog!!)

    The basic operation of the code is this: I paste a list of report numbers into an Excel worksheet; the code access the Excel range and iterates through the numbers to perform two AdvancedSearch operations - one to see if the report number shows up in my Sent Mail, and again to see if it shows up in my Inbox. The report number would exist in the body of any email. If the number is found in any Sent item, the code writes "Sent" in the worksheet next to the number; if it's found in my Inbox, it writes "Back".

    Unfortunately, when I checked my results by manually entering the report numbers into the Advanced Search bar, several items marked either "Sent" or "Back" were not actually found.


    This is all running in Outlook and Excel 2007 on a Windows Vista system.  Can someone help me refine this please?
    Ed


    Sub SearchForReports()

    Dim XLapp As Excel.Application
    Dim XLwkb As Excel.Workbook
    Dim XLwks As Excel.Worksheet
    Dim XLrng As Excel.Range
    Dim XLcll As Excel.Range

    Dim strFind As String
    Dim strBox As String
    Dim strTag As String
    Dim strOdin As String

    Dim objSch As Outlook.Search


    If MsgBox("Have you pasted the report numbers into an Excel worksheet " & _
              "in Column A beginning in A1?", vbYesNo) = vbNo Then Exit Sub
              
              
    On Error Resume Next
      Set XLapp = GetObject(, "Excel.Application")
    On Error GoTo 0
    If XLapp Is Nothing Then
      MsgBox "Can't get Excel"
      GoTo Cleanup
    End If

    Set XLwkb = XLapp.ActiveWorkbook
    Set XLwks = XLwkb.Worksheets("Sheet1")
    Set XLrng = XLwks.Range("A1:A100")

    strBox = "'" & Application.Session.GetDefaultFolder( _
      olFolderSentMail).FolderPath & "'"

    For Each XLcll In XLrng.Cells
      strOdin = XLcll.Value
      
        If strOdin = "" Then GoTo DoInBox
        
      strFind = "urn:schemas:httpmail:textdescription LIKE '%" & strOdin & "'"
      Set objSch = Application.AdvancedSearch(strBox, strFind, False, strTag)

      If Not objSch Is Nothing Then
        DoEvents
        XLcll.Offset(0, 1) = "Sent"
        DoEvents
      End If
      
      Next XLcll

    DoInBox:

    strBox = "'" & Application.Session.GetDefaultFolder( _
      olFolderInbox).FolderPath & "'"

    For Each XLcll In XLrng.Cells

      strOdin = XLcll.Value
      
        If strOdin = "" Then GoTo Cleanup
        
      strFind = "urn:schemas:httpmail:textdescription LIKE '%" & strOdin & "'"
      Set objSch = Application.AdvancedSearch(strBox, strFind, False, strTag)

      If Not objSch Is Nothing Then
        DoEvents
        XLcll.Offset(0, 2) = "Back"
        DoEvents
      End If

    Next XLcll

    Cleanup:
    MsgBox "Done!"

    Set XLcll = Nothing
    Set XLrng = Nothing
    Set XLwks = Nothing
    Set XLwkb = Nothing
    Set XLapp = Nothing

    End Sub

    Sunday, April 29, 2012 2:26 PM