Ytukyg

I have this code, it reads the new mail item and move it to another folder if it find some critical keywords in Body or attachments and it works well for Email Body as well as Word doc attachment. But when it reads Word doc it actually opens it for microseconds and it appears the screen is flashing with Word Document.

Do we have any other way so that the user won't know that a doc has been opened and still gets the work done i.e. move the mail item silently ?

Option Explicit 

Private WithEvents inboxItems_Billing As Outlook.Items 

Dim DestinationFolder As Outlook.Folder



Private Sub Application_Startup()

  Dim outlookApp As Outlook.Application

  Dim objectNS As Outlook.NameSpace

  Set outlookApp = Outlook.Application

  Set objectNS = outlookApp.GetNamespace("MAPI") 

  Set inboxItems_Billing = GetFolderPath("BillingInbox").Items   ''Shared MailBox 

End Sub





Private Sub inboxItems_Billing_ItemAdd(ByVal Item As Object)

On Error GoTo ErrorHandler

Dim Msg As Outlook.MailItem

Dim MessageInfo

Dim Result

If TypeName(Item) = "MailItem" Then

    Set DestinationFolder = GetFolderPath("BillingInboxTest")

    '''Read attachments and move

      ProcessMessages Item, DestinationFolder

End If

ExitNewItem:

    Exit Sub

ErrorHandler:

    MsgBox Err.Number & " - " & Err.Description

    Resume ExitNewItem

End Sub





Public Sub ProcessMessages(olItem As Outlook.MailItem, DestinationFolder As Outlook.Folder)

Dim criticalKeyWordsArr As String

Dim Counter As Integer

Dim SplitCatcher As Variant

Dim Item As Outlook.MailItem

criticalKeyWordsArr = "CVV,AMEX,VISA,Mastercard,Exp Date,Expiration Date,Merchant Code,Credit Card"

SplitCatcher = Split(criticalKeyWordsArr, ",")

Dim KeyWord As String

For Counter = 0 To UBound(SplitCatcher)

      KeyWord = SplitCatcher(Counter)

      ProcessMessagesWithCriticalKeywords olItem, KeyWord, DestinationFolder

Next

End Sub



''''Works Just for Word Docs right now and the Mail Body

Public Sub ProcessMessagesWithCriticalKeywords(olItem As Outlook.MailItem, strFindText As String, DestinationFolder As Outlook.Folder)

Const strFileType As String = "doc|docx|rtf"        'The document type

Const strPath As String = "C:tempPCI"        'The root folder

Dim vFileType As Variant

Dim strFilename As String

Dim strMailBody As String

Dim strName As String

Dim wdApp As Object

Dim wdDoc As Object

Dim olAttach As Outlook.Attachment

Dim strFolder As String

Dim bStarted As Boolean

Dim bFound As Boolean 

Dim i As Long, i_V As Long

    On Error Resume Next 



    bFound = False



    ''''Find in Body first

    strMailBody = olItem.Body

        'Check if the critical words present in the Email body

        If InStr(strMailBody, strFindText) Then 

            bFound = True        

            '''Move to diff folder

            olItem.Move DestinationFolder         

        End If



        If olItem.Attachments.Count > 0 & bFound = False Then

            Set wdApp = GetObject(, "Word.Application")

            If Err Then

                Set wdApp = CreateObject("Word.Application")

                bStarted = True

            End If

            On Error GoTo 0

            wdApp.Visible = True



            If Dir(strPath, vbDirectory) = "" Then

                MkDir strPath

            End If



            vFileType = Split(strFileType, "|")

            For Each olAttach In olItem.Attachments

                For i_V = 0 To UBound(vFileType)

                    If Right(LCase(olAttach.FileName), Len(vFileType(i_V))) = vFileType(i_V) Then

                        strFilename = strPath & Format(olItem.ReceivedTime, "yyyymmdd-HHMMSS") & _

                                      Chr(32) & olAttach.FileName

                        olAttach.SaveAsFile strFilename



                        Set wdDoc = wdApp.Documents.Open(strFilename)



                        With wdDoc.Content.Find

                            bFound = False

                            Do While .Execute(strFindText)

                                bFound = True

                                Exit Do

                            Loop

                            strName = wdDoc.Name

                            wdDoc.Close 0



                            If bFound Then



                                 '''''Delete all files in Temp folder

                                 Clear_All_Files_And_SubFolders_In_Folder strPath



                                  '''Move to diff folder

                                  olItem.Move DestinationFolder 



                            End If

                        End With

                    End If

                Next i_V

            Next olAttach

        End If



    If bStarted Then wdApp.Quit

    Set wdDoc = Nothing

    Set wdApp = Nothing 

End Sub





Sub Clear_All_Files_And_SubFolders_In_Folder(strPath As String)

'Delete all files and subfolders

'Be sure that no file is open in the folder

    Dim FSO As Object

    Dim MyPath As String

    Set FSO = CreateObject("scripting.filesystemobject")

    MyPath = strPath  

    If Right(MyPath, 1) = "" Then

        MyPath = Left(MyPath, Len(MyPath) - 1)

    End If

    If FSO.FolderExists(MyPath) = False Then

        MsgBox MyPath & " doesn't exist"

        Exit Sub

    End If

    On Error Resume Next

    'Delete files

    FSO.deletefile MyPath & "*.*", True

    'Delete subfolders

    FSO.deletefolder MyPath & "*.*", True

    On Error GoTo 0

End Sub





' Use the GetFolderPath function to find a folder in non-default mailboxes

Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder

    Dim oFolder As Outlook.Folder

    Dim FoldersArray As Variant

    Dim i As Integer

    On Error GoTo GetFolderPath_Error

    If Left(FolderPath, 2) = "\" Then

        FolderPath = Right(FolderPath, Len(FolderPath) - 2)

    End If

    'Convert folderpath to array

    FoldersArray = Split(FolderPath, "")

    Set oFolder = Application.Session.Folders.Item(FoldersArray(0))

    If Not oFolder Is Nothing Then

        For i = 1 To UBound(FoldersArray, 1)

            Dim SubFolders As Outlook.Folders

            Set SubFolders = oFolder.Folders

            Set oFolder = SubFolders.Item(FoldersArray(i))

            If oFolder Is Nothing Then

                Set GetFolderPath = Nothing

            End If

        Next

    End If

    'Return the oFolder

    Set GetFolderPath = oFolder

    Exit Function

GetFolderPath_Error:

    Set GetFolderPath = Nothing

    Exit Function

End Function