基本上我有一个包含在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
下面是问题代码，索引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
非常感谢任何帮助，提前谢谢！
答案 0 :(得分：0)
如果您只需要搜索PDF，MSWord和Excel内容，这就是一个解决方案。每种方法都有不同的程序。需要注意的是，您需要支付一个版本的Adobe。这不适用于普通的Adobe 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