Excel VBA 用于在 Outlook 附件中搜索字符串，如果找到匹配项则标记电子邮件

Question

基本上，我在 Excel 电子表格中填充了 5000 个字符串的列表。我希望 VBA 浏览 Outlook 收件箱中的附件，如果找到字符串匹配，我希望标记特定的电子邮件。这是我到目前为止的代码

Sub attachsearch()
On Error GoTo bigerror
Dim ns As Namespace
Dim inbox As MAPIFolder
Dim subfolder As MAPIFolder
Dim item As Object
Dim atmt As Attachment
Dim filename As String
Dim i As Integer
Dim varresponse As VbMsgBoxResult
Dim workbk As Workbook
Dim SearchString As String
Set ns = GetNamespace("MAPI")
Set inbox = ns.GetDefaultFolder(olFolderInbox)
Set subfolder = inbox.Folders("test")
Set workbk = Workbooks.Open("C:\Users\John.Doe\Desktop\10 25 2016 Pricing Team Macro.xlsm")
i = 0
If subfolder.Items.Count = 0 Then
MsgBox "There are no emails to look at. Please stop wasting my time.", vbInformation, "Folder is Empty"
Exit Sub
End If
For Each item In subfolder.Items
For Each atmt In item.Attachments
For rwindex = 1 To 5000
SearchString = Workbooks("10 25 2016 Pricing Team Macro").Sheets("NDC Sort").Cells(rwindex, 1).Value

下面是问题代码，这里没有正确使用index proberty，但是我不确定用什么。我知道 Microsoft 会为附件中的单词编制索引，因为当我在 Outlook 中手动输入搜索字符串时，即使该字符串仅存在于附件中，它也会提取电子邮件。所以最终，我的问题是，如何在 VBA 中利用该附件索引？

If atmt.Index Like "*" & Workbooks("10 25 2016 Pricing Team Macro").Sheets("NDC Sort").Cells(rwindex, 1).Value & "*" Then
i = i + 1
With item
    .FlagRequest = "Follow up"
    .Save
End With
End If
Next rwindex
Next atmt
Next item
If i > 0 Then
MsgBox "I found " & i & " attached files with a specific name."
Else
MsgBox "I didn't find any files"
End If
Set atmt = Nothing
Set item = Nothing
Set ns = Nothing
workbk.Close savechanges:=False
Exit Sub
bigerror:
MsgBox "something went wrong"
End Sub

任何帮助将不胜感激，在此先感谢！

Answer 1

如果您只需要搜索内容 PDF、MSWord 和 Excel，这是一个解决方案。每个都有不同的程序。需要注意的是，您需要有一个付费的 Adob​​e 版本。这不适用于普通的 Adob​​e Reader。我已经对其进行了几次测试，它确实有效，但它在某些部分似乎有点笨拙，所以我愿意接受建议。

            Sub attachsearch()
            Dim ns As Namespace
            Dim inbox As MAPIFolder
            Dim subfolder As MAPIFolder
            Dim item As Object
            Dim atmt As Attachment
            Dim tempfilepath As String
            Dim tempfilename As String
            Dim i As Integer
            Dim workbk As Workbook
            Dim LastRow As Long
            Dim TextToFind  As String
            Dim Loc As Range
            Dim Sh As Worksheet
            Dim WS_Count As Integer
            Dim x As Integer
            Dim WS_Name As String

            Set ns = GetNamespace("MAPI")
            Set inbox = ns.GetDefaultFolder(olFolderInbox)
            Set subfolder = inbox.Folders("test")
            Set workbk = Workbooks.Open("C:\Users\John.Doe\Desktop\10 25 2016 Pricing Team Macro.xlsx")
            LastRow = Workbooks("10 25 2016 Pricing Team Macro").Worksheets("NDC Sort").Cells(Worksheets("NDC Sort").Rows.Count, "A").End(xlUp).Row
            i = 0
            If subfolder.Items.Count = 0 Then
            MsgBox "There are no emails to look at. Please stop wasting my time.", vbInformation, "Folder is Empty"
            Exit Sub
            End If

            For Each item In subfolder.Items
            For Each atmt In item.Attachments
            If item.FlagStatus = Empty Then
                If Right(atmt.Filename, 4) Like "xl**" Or Right(atmt.Filename, 3) Like "xl*" Then
                    tempfilepath = "O:\aaaTEST\"
                    tempfilename = Format(item.ReceivedTime, "yyyymmdd_hhnnss_") & item.SenderName & "_" & atmt.Filename
                    atmt.SaveAsFile tempfilepath & tempfilename
                    Workbooks.Open (tempfilepath & tempfilename)
                    Workbooks(tempfilename).Activate
                    WS_Count = Workbooks(tempfilename).Worksheets.Count
                    'Clearing any selections that may limit the search unintentionally
                    For x = 1 To WS_Count
                    With ActiveWorkbook.Worksheets(x)
                    .Select
                    .Cells(1, 1).Select
                    Application.CutCopyMode = False
                    End With
                    Next x
                For rwindex = 2 To LastRow
                    If item.FlagStatus = Empty Then
                    TextToFind = Workbooks("10 25 2016 Pricing Team Macro").Sheets("NDC Sort").Cells(rwindex, 1).Value
                        If TextToFind <> "" Then
                            Workbooks(tempfilename).Activate
                            For x = 1 To WS_Count
                            With ActiveWorkbook.Worksheets(x)
                                    .Select
                                    .UsedRange.Select
                                   Set Loc = .Cells.Find(TextToFind)
                            If item.FlagStatus = Empty Then
                                If Not Loc Is Nothing Then
                                 i = i + 1
                                 With item
                                .FlagRequest = "Follow up"
                                .Save
                                End With
                                End If
                            End If
                            Set Loc = Nothing
                            End With
                            Next x
                        End If
                     End If
                     Next rwindex
                     Workbooks(tempfilename).Close Savechanges:=False
                End If

            'PDF Check
                If Right(atmt.Filename, 3) = "pdf" Then
                    tempfilename = "O:\aaaTEST\" & _
                    Format(item.ReceivedTime, "yyyymmdd_hhnnss_") & item.SenderName & "_" & atmt.Filename
                    atmt.SaveAsFile tempfilename
                    PDFPath = tempfilename

                Set App = CreateObject("AcroExch.App", "")

                Set AVDoc = CreateObject("AcroExch.AVDoc")

                        If AVDoc.Open(PDFPath, "") = True Then
                          AVDoc.BringToFront
                          For rwindex = 2 To 3593
                            If item.FlagStatus = Empty Then
                            TextToFind = Workbooks("10 25 2016 Pricing Team Macro").Sheets("NDC Sort").Cells(rwindex, 1).Value
                                If AVDoc.FindText(TextToFind, False, True, False) = True Then
                                i = i + 1
                                With item
                                .FlagRequest = "Follow up"
                                .Save
                                End With
                                End If
                            AVDoc.Close True
                            App.Exit
                            End If
                        Next rwindex
                        End If
                End If

                'MSWord check
                If Right(atmt.Filename, 4) Like "doc*" Or Right(atmt.Filename, 3) Like "doc" Then
                    tempfilepath = "O:\aaaTEST\"
                    tempfilename = Format(item.ReceivedTime, "yyyymmdd_hhnnss_") & item.SenderName & "_" & atmt.Filename
                    atmt.SaveAsFile tempfilepath & tempfilename
                    Set wordapp = CreateObject("word.Application")
                    wordapp.Documents.Open Filename:=tempfilepath & tempfilename
                    wordapp.Visible = True
                    For rwindex = 2 To 5
                        If item.FlagStatus = Empty Then
                        TextToFind = Workbooks("10 25 2016 Pricing Team Macro").Sheets("NDC Sort").Cells(rwindex, 1).Value
                            If TextToFind <> "" Then
                                With wordapp.ActiveDocument.Content.Find
                                .ClearFormatting
                                .Execute FindText:=TextToFind
                                If .Found = True Then
                                    i = i + 1
                                    With item
                                        .FlagRequest = "Follow up"
                                        .Save
                                    End With
                                End If
                                End With
                            End If
                        End If
                    Next rwindex
                wordapp.ActiveDocument.Close Savechanges:=wdDoNotSaveChanges
                wordapp.Quit Savechanges:=wdDoNotSaveChanges
                End If
            End If
            Next atmt
            Next item
            Workbooks("10 25 2016 Pricing Team Macro").Close Savechanges:=False

            If i > 0 Then
            MsgBox "I found " & i & " attached files with a specific name."
            Else
            MsgBox "I didn't find any files"
            End If
            Set atmt = Nothing
            Set item = Nothing
            Set ns = Nothing
            Exit Sub

            End Sub