保存包含 Outlook 2007 中的字符串的 Excel 文件答案

【问题标题】：Save an Excel file which contains a string from Outlook2007保存包含 Outlook 2007 中的字符串的 Excel 文件
【发布时间】：2019-10-22 16:47:12
【问题描述】：

我是 VBA 的新手，所以我需要一点帮助。

我的目标是制定 Outlook 规则，但我有一个问题：

我想将一个 Excel (xlsx) 文件从我的 Outlook 收件箱保存到我的电脑。但只有包含（在电子表格中）字符串的文件。但它保存（或不保存任何东西）最后一个 excel 文件..（不检查 MYSTRING）

使用此代码：

Option Explicit

Sub CheckAttachments(olItem As MailItem)

Const strPath As String = "C:\Users\PC2\Documents\Temp_attachs\" 
Const strFindText As String = "Completed"
Dim strFilename As String
Dim olAttach As Attachment
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim bXStarted As Boolean
Dim bFound As Boolean
 If olItem.Attachments.Count > 0 Then
     For Each olAttach In olItem.Attachments
         If Right(LCase(olAttach.FileName), 4) = "xlsx" Then

strFilename = strPath & Format(olItem.ReceivedTime, "yyyymmdd-HHMMSS") & _
                           Chr(32) & olAttach.FileName
             olAttach.SaveAsFile strFilename
             On Error Resume Next
             Set xlApp = GetObject(, "Excel.Application")
             If Err <> 0 Then
                 Application.StatusBar = "Please wait while Excel source is opened ... "
                 Set xlApp = CreateObject("Excel.Application")
                 bXStarted = True
             End If
             On Error GoTo 0
             'Open the workbook to read the data
             Set xlWB = xlApp.Workbooks.Open(strFilename)
             Set xlSheet = xlWB.Sheets("Sheet1")

             If FindValue(strFindText, xlSheet) Then
                 MsgBox "Value found in " & strFilename
                 bFound = True
             End If
             xlWB.Close 0
             If bXStarted Then xlApp.Quit
             If Not bFound Then Kill strFilename
             Exit For
         End If
     Next olAttach
  End If
 End Sub

 Function FindValue(FindString As String, iSheet As Object) As Boolean
 Dim Rng As Object
 If Trim(FindString) <> "" Then
     With iSheet.Range("A:J")
         Set Rng = .Find(What:=FindString, _
                         After:=.Cells(.Cells.Count), _
                         LookIn:=-4163, _
                         LookAt:=1, _
                         SearchOrder:=1, _
                         SearchDirection:=1, _
                         MatchCase:=False)
         If Not Rng Is Nothing Then
             FindValue = True
         Else
             FindValue = False
         End If
     End With
 End If
 End Function

Sub Test()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
CheckAttachments olMsg
End Sub

【问题讨论】：

你可以试试下面的代码。如果您发现任何错误，请发表评论。
@Mikku Thx 寻求帮助。我发现一个错误...看起来我有另一个Sheet 名称..所以，它现在正在保存文件并检查Completed。但仍然只保存最后一个文件..
试试我的代码。这可能会起作用，因为您的循环中的 Extra Exit For @Georg
我尝试了 Answer 中的代码，它在我的系统中运行良好。

标签： vba outlook email-attachments

【解决方案1】：

我想我找到了你的问题：

您只在For Loop 中使用了Exit For。所以只有在扫描第一个文件后，才会退出循环。

您需要删除Exit For，然后您的代码才能顺利运行。

Option Explicit

Sub CheckAttachments(olItem As MailItem)

Const strPath As String = "C:\Users\PC2\Documents\Temp_attachs\" 
Const strFindText As String = "Completed"
Dim strFilename As String
Dim olAttach As Attachment
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim bXStarted As Boolean
Dim bFound As Boolean
 If olItem.Attachments.Count > 0 Then
     For Each olAttach In olItem.Attachments
         If Right(LCase(olAttach.FileName), 4) = "xlsx" Then

strFilename = strPath & Format(olItem.ReceivedTime, "yyyymmdd-HHMMSS") & _
                           Chr(32) & olAttach.FileName
             olAttach.SaveAsFile strFilename
             On Error Resume Next
             Set xlApp = GetObject(, "Excel.Application")
             If Err <> 0 Then
                 Application.StatusBar = "Please wait while Excel source is opened ... "
                 Set xlApp = CreateObject("Excel.Application")
                 bXStarted = True
             End If
             On Error GoTo 0
             'Open the workbook to read the data
             Set xlWB = xlApp.Workbooks.Open(strFilename)
             Set xlSheet = xlWB.Sheets("Sheet1")

             If FindValue(strFindText, xlSheet) Then
                 MsgBox "Value found in " & strFilename
                 bFound = True
             End If
             xlWB.Close 0
             If bXStarted Then xlApp.Quit
             If Not bFound Then Kill strFilename

         End If
     Next olAttach
  End If
 End Sub

 Function FindValue(FindString As String, iSheet As Object) As Boolean
 Dim Rng As Object
 If Trim(FindString) <> "" Then
     With iSheet.Range("A:J")
         Set Rng = .Find(What:=FindString, _
                         After:=.Cells(.Cells.Count), _
                         LookIn:=-4163, _
                         LookAt:=1, _
                         SearchOrder:=1, _
                         SearchDirection:=1, _
                         MatchCase:=False)
         If Not Rng Is Nothing Then
             FindValue = True
         Else
             FindValue = False
         End If
     End With
 End If
 End Function

Sub Test()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
CheckAttachments olMsg
End Sub

【讨论】：