Vba 保存包含Outlook2007中字符串的Excel文件

我是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

选项显式
子检查附件（作为邮件项的邮件）
Const strPath As String=“C:\Users\PC2\Documents\Temp\u attachs”
Const strFindText As String=“已完成”
将strFilename设置为字符串
依附
将xlApp作为对象
作为对象的Dim xlWB
将图纸作为对象
Dim bx以布尔形式开始
Dim bfind为布尔值
如果m.Attachments.Count>0，则
对于olItem.附件中的每个olAttach
如果正确（LCase（olAttach.FileName），4）=“xlsx”，则
strFilename=strPath和Format（olItem.ReceivedTime，“yyyyymmdd HHMMSS”）&_
Chr（32）&olAttach.FileName
olAttach.SaveAsFile strFilename
出错时继续下一步
Set xlApp=GetObject（，“Excel.Application”）
如果错误为0，则
Application.StatusBar=“正在打开Excel源，请稍候…”
设置xlApp=CreateObject（“Excel.Application”）
bXStarted=True
如果结束
错误转到0
'打开工作簿以读取数据
设置xlWB=xlApp.Workbooks.Open（strFilename）
设置xlSheet=xlWB.Sheets（“Sheet1”）
如果是FindValue（strFindText，xlSheet），则
MsgBox“在中找到值”&strFilename
bFound=True
如果结束
xlWB.Close 0
如果bXStarted，则xlApp.Quit
如果未找到，则杀死strFilename
退出
如果结束
下一个奥拉塔
如果结束
端接头
函数FindValue（FindString作为字符串，iSheet作为对象）作为布尔值
作为对象的Dim Rng
如果修剪（FindString）“，则
带ISHET.范围（“A:J”）
Set Rng=.Find（What:=FindString_
之后：=.Cells（.Cells.Count）_
查找：=-4163_
看：=1_
搜索顺序：=1_
搜索方向：=1_
匹配案例：=假）
如果不是，那么Rng什么都不是
FindValue=True
其他的
FindValue=False
如果结束
以
如果结束
端函数
子测试（）
Dim olMsg作为邮件项
出错时继续下一步
设置olMsg=ActiveExplorer.Selection.Item（1）
checkolmsg
端接头
我想我发现了你的问题：

您仅在
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

选项显式
子检查附件（作为邮件项的邮件）
Const strPath As String=“C:\Users\PC2\Documents\Temp\u attachs”
Const strFindText As String=“已完成”
将strFilename设置为字符串
依附
将xlApp作为对象
作为对象的Dim xlWB
将图纸作为对象
Dim bx以布尔形式开始
Dim bfind为布尔值
如果m.Attachments.Count>0，则
对于olItem.附件中的每个olAttach
如果正确（LCase（olAttach.FileName），4）=“xlsx”，则
strFilename=strPath和Format（olItem.ReceivedTime，“yyyyymmdd HHMMSS”）&_
Chr（32）&olAttach.FileName
olAttach.SaveAsFile strFilename
出错时继续下一步
Set xlApp=GetObject（，“Excel.Application”）
如果错误为0，则
Application.StatusBar=“正在打开Excel源，请稍候…”
设置xlApp=CreateObject（“Excel.Application”）
bXStarted=True
如果结束
错误转到0
'打开工作簿以读取数据
设置xlWB=xlApp.Workbooks.Open（strFilename）
设置xlSheet=xlWB.Sheets（“Sheet1”）
如果是FindValue（strFindText，xlSheet），则
MsgBox“在中找到值”&strFilename
bFound=True
如果结束
xlWB.Close 0
如果bXStarted，则xlApp.Quit
如果未找到，则杀死strFilename
如果结束
下一个奥拉塔
如果结束
端接头
函数FindValue（FindString作为字符串，iSheet作为对象）作为布尔值
作为对象的Dim Rng
如果修剪（FindString）“，则
带ISHET.范围（“A:J”）
Set Rng=.Find（What:=FindString_
之后：=.Cells（.Cells.Count）_
查找：=-4163_
看：=1_
搜索顺序：=1_
搜索方向：=1_
匹配案例：=假）
如果不是，那么Rng什么都不是
FindValue=True
其他的
FindValue=False
如果结束
以
如果结束
端函数
子测试（）
Dim olMsg作为邮件项
出错时继续下一步
设置olMsg=ActiveExplorer.Selection.Item（1）
checkolmsg
端接头
您可以尝试下面的代码。如果发现任何错误，请进行注释。@Mikku Thx以获取帮助。我发现一个错误。。。看起来我有另一张
工作表
名称..因此，它现在正在保存文件并签入
已完成
。但仍然只保存了最后一个文件..请尝试我的代码。这可能会起作用，因为在你的循环中有一个额外的出口@GeorgI尝试了回答代码，并且它在我的系统中运行顺利。