Results 1 to 2 of 2
  1. #1
    New Lounger
    Join Date
    Feb 2002
    Posts
    3
    Thanks
    0
    Thanked 0 Times in 0 Posts

    text search within attachments (VBA Office 97)

    I need to carry out a search through a very large number of messages looking for keywords within either the message body or the any attachments. I'm not a VBA expert, but is there a way to search the attachments using VBA, or to Save them all out to a folder which I can then search using Explorer?
    I'm using Exchange 5.5, and Outlook 97.
    Any help much appreciated.
    Richard

  2. #2
    Plutonium Lounger
    Join Date
    Mar 2002
    Posts
    84,353
    Thanks
    0
    Thanked 29 Times in 29 Posts

    Re: text search within attachments (VBA Office 97)

    Here is a longish piece of code that does the following:
    <UL><LI>It looks at each e-mail message in a specified Inbox.
    <LI>It retrieves the body of the message.
    <LI>It checks whether the message contains any Excel attachment.
    <LI>If so, the attachment is saved to C:, processed and then deleted, and the e-mail is moved to an archive outlook folder.[/list]For this to work, you'll need to set a reference to the Microsoft Outlook xx Type Library. And of course, you'll need to adapt it for your own situation, e.g. process Word or Ascii attachments instead of Excel, substitute correct user names etc.

    <img src=/w3timages/blueline.gif width=33% height=2>

    Dim objOLApp As Outlook.Application

    ' Name of Outlook user (Inbox) to be used
    Const strUser = "Test"

    ' Name of Outlook archive folder
    Const strArchive = "Archive"

    Function ReadMailExcel()
    Dim objMI As Outlook.MailItem
    Dim objNamespace As Outlook.NameSpace
    Dim objFolder As Outlook.MAPIFolder
    Dim objArchiveFolder As Outlook.MAPIFolder
    Dim objRecipient As Outlook.Recipient
    Dim objAttachment As Outlook.Attachment
    Dim strFilename As String
    Dim strBody As String
    Dim intOutlook As Integer
    Dim intAttCount As Integer
    Dim i As Integer
    Dim intMessageCount As Integer
    Dim blnSuccess As Boolean

    DoCmd.Hourglass True

    ' Start Outlook
    intOutlook = StartOutlook
    If intOutlook = 0 Then
    MsgBox "Can't Open Outlook!", vbCritical
    GoTo Exit_Mail
    End If

    On Error GoTo Err_Mail
    ' Open Outlook folder
    Set objNamespace = objOLApp.GetNamespace("MAPI")
    Set objArchiveFolder = objNamespace.Folders(strArchive)
    ' Recipient = Outlook user
    Set objRecipient = objNamespace.CreateRecipient(strUser)
    objRecipient.Resolve
    If objRecipient.Resolved = True Then
    ' objFolder is the inbox
    Set objFolder = objNamespace.GetSharedDefaultFolder(objRecipient, olFolderInbox)
    intMessageCount = objFolder.Items.Count
    For i = intMessageCount To 1 Step -1
    Set objMI = objFolder.Items(i)
    SysCmd acSysCmdSetStatus, "Busy processing message '" & objMI.Subject & _
    "' from " & objMI.SenderName
    strBody = objMI.Body
    ' Do something with the body of the message
    ' (your own instructions here)
    ' Count attachments
    intAttCount = objMI.Attachments.Count
    If intAttCount = 0 Then
    ' ...
    Else
    blnSuccess = False
    For Each objAttachment In objMI.Attachments
    If UCase$(Right$(objAttachment.FileName, 3)) = "XLS" Then
    blnSuccess = True
    ' Save attachment
    strFilename = "C:" & objAttachment.FileName
    objAttachment.SaveAsFile strFilename
    ' Process File
    ' (your own instructions here)
    ' Delete saved attachment
    Kill strFilename
    End If
    Next
    If blnSuccess Then
    ' Success - move e-mail to archive
    objMI.UnRead = False
    objMI.Move objArchiveFolder
    End If
    End If
    Next i
    End If
    ReadMailExcel = True

    Exit_Mail:
    ' Release object memory and quit Outlook if necessary
    On Error Resume Next
    If Not (objMI Is Nothing) Then
    objMI.Close olDiscard
    End If
    Set objMI = Nothing
    ' Quit Outlook if we started it
    If intOutlook = 2 Then
    If Not objOLApp Is Nothing Then
    objOLApp.Quit
    End If
    End If
    Set objOLApp = Nothing
    SysCmd acSysCmdClearStatus
    DoCmd.Hourglass False
    Exit Function

    Err_Mail:
    MsgBox Err.Description, vbExclamation
    Resume Exit_Mail
    End Function

    Function StartOutlook() As Integer
    ' Returns:
    ' 0 = failed
    ' 1 = Outlook was already active
    ' 2 = Outlook started by this procedure

    On Error Resume Next

    ' Default return value
    StartOutlook = 1
    Set objOLApp = Nothing
    ' Check whether Outlook is already active
    Set objOLApp = GetObject(, "Outlook.Application")
    If objOLApp Is Nothing Then
    ' If not, start Outlook now
    Err.Clear
    Set objOLApp = CreateObject("Outlook.Application")
    StartOutlook = 2
    End If

    If objOLApp Is Nothing Then
    StartOutlook = 0
    End If
    End Function

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •