Сохраните файл Excel, который содержит строку из Outlook2007 - PullRequest
Новая
       11

Сохраните файл Excel, который содержит строку из Outlook2007

0 голосов
/ 07 июня 2019

Я новичок в 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

1 Ответ

1 голос
/ 07 июня 2019

Я думаю, что нашел вашу проблему:

Вы использовали Exit For только в вашем For Loop. Так что только после сканирования 1-го файла цикл завершается.

Вам нужно удалить 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
...