在MS-Outlook中使用VBA读取Word文档

我有这段代码,它读取新邮件项目并将其移动到另一个文件夹,如果它在正文或附件中找到一些关键关键字,它可以很好地用于电子邮件正文和Word文档附件。但当它读到Word doc时,它实际上会打开它几微秒,屏幕上似乎闪烁着Word Document。

我们是否有其他方法可以让用户不知道文档已打开,但仍然可以完成工作(即无提示地移动邮件项)?

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("Billing\Inbox").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("Billing\Inbox\Test")
    '''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