扫描 excel 个附件单元格以查找特定文本，并将邮件转发给正确的收件人

Question

我是 VBA 的新手，我改编了网上找到的代码。我正在尝试在电子邮件中搜索 Excel 附件，以查找特定单元格中的特定文本字符串，如果找到正确的文本，则将邮件转发给正确的人。

Sub CheckAttachments(olItem As MailItem)
Const strPath As String = "C:\Users\KoderM16\Desktop"
Const strFindText As String = "Car"
Const strFindText2 As String = "Toy"
Const strFindText3 As String = "Grass"
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
Dim Inbox As MAPIFolder
Dim MyItems As Items
Dim MyItem As MailItem

Set Inbox = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set MyItems = Inbox.Items
Set MyItem = Application.ActiveExplorer.Selection(1)   
Set MyItem = MyItem.Forward
If olItem.Attachments.Count > 0 Then
  For Each olAttach In olItem.Attachments
    If Right(LCase(olAttach.FileName), 3) = "xls" Or 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
        MyItem.Recipients.Add "emailaddress1"
        MyItem.Send
      ElseIf FindValue(strFindText2, xlSheet) Then
        MyItem.Recipients.Add "emailaddress2"
        MyItem.Send
      ElseIf FindValue(strFindText3, xlSheet) Then
        MyItem.Recipients.Add "emailaddress3"
        MyItem.Send
      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("B2")
        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

Answer 1

代码搜索 .xls 附件，如果它在 sheet 中找到数据，它就会转发邮件。但是，我希望能够指向多个单独的单元格。代码中可能有一些不必要的东西。我尝试指向代码底部附近的单元格 B2，但即使它在 A1 中找到文本，它也会发送邮件。

'Section 1

Sub CheckAttachments(olItem As MailItem)
    Const strPath As String = "Enter_Path_Here" 'Define a path for the temp file
    Dim strFilename As String
    Dim olAttach As Attachment
    Dim xlSheet As Object
    Dim bXStarted As Boolean
    Dim bFound As Boolean
    Dim Inbox As MAPIFolder
    Dim MyItems As Items

    'Section 2

    'A new MyItem is required per mutually exclusive recipient as below

    Dim MyItem As MailItem
    Dim MyItemTwo As MailItem
    Dim MyItemThree As MailItem
    Dim MyItemFour As MailItem
    Dim MyItemFive As MailItem
    Dim MyItemSix As MailItem

    'Section 3

    Set Inbox = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    Set MyItems = Inbox.Items

    'Section 4

    'A new MyItem is required per mutually exclusive recipient as below

    Set MyItem = Application.ActiveExplorer.Selection(1)
    Set MyItem = MyItem.Forward
    Set MyItemTwo = Application.ActiveExplorer.Selection(1)
    Set MyItemTwo = MyItemTwo.Forward
    Set MyItemThree = Application.ActiveExplorer.Selection(1)
    Set MyItemThree = MyItemTwo.Forward
    Set MyItemFour = Application.ActiveExplorer.Selection(1)
    Set MyItemFour = MyItemTwo.Forward
    Set MyItemFive = Application.ActiveExplorer.Selection(1)
    Set MyItemFive = MyItemTwo.Forward
    Set MyItemSix = Application.ActiveExplorer.Selection(1)
    Set MyItemSix = MyItemTwo.Forward

    'Section 5

    If olItem.Attachments.Count > 0 Then
        For Each olAttach In olItem.Attachments
            If Right(LCase(olAttach.FileName), 3) = "xls" Or Right(LCase(olAttach.FileName), 4) = "xlsx" Or Right(LCase(olAttach.FileName), 4) = "xlsm" Then 'Define the file types to search in
                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")

            'Section 6

            'A new xlSheet cell selection and If statement is required for mutually exclusive recipients as below. Multiple addresses can be added to one condition

            If xlSheet.Range("A1").Value = "Enter_Value_To_Find" Then
                MyItem.Recipients.Add "Enter_E-Mail_Address"
                MyItem.Send
            End If

            If xlSheet.Range("B1").Value = "Enter_Value_To_Find" Then
                MyItemTwo.Recipients.Add "Enter_E-Mail_Address"
                MyItemTwo.Send
            End If

            If xlSheet.Range("F1").Value = "Enter_Value_To_Find" Then
                MyItemThree.Recipients.Add "Enter_E-Mail_Address"
                MyItemThree.Send
            End If

            If xlSheet.Range("C10").Value = "Enter_Value_To_Find" Then
                MyItemFour.Recipients.Add "Enter_E-Mail_Address"
                MyItemFour.Send
            End If

            If xlSheet.Range("D5").Value = "Enter_Value_To_Find" Then
                MyItemFive.Recipients.Add "Enter_E-Mail_Address"
                MyItemFive.Send
            End If

            If xlSheet.Range("E7").Value = "Enter_Value_To_Find" Then
                MyItemSix.Recipients.Add "Enter_E-Mail_Addressa"
                MyItemSix.Send
            End If

            'Section 7

            xlWB.Close 0
            If bXStarted Then xlApp.Quit
            If Not bFound Then Kill strFilename
            Exit For
        End If
        Next olAttach
    End If
End Sub

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

扫描 excel 个附件单元格以查找特定文本，并将邮件转发给正确的收件人

Scan excel attachment cell(s) for specific text, and forward mail to correct recipient(s)

excel

outlook

vba

attachment