Question

每天我都会收到带有项目编号的电子邮件。我通常会突出显示并复制电子邮件中的项目编号，单击我的excel电子表格（WI_Design_Tracker），ctrl + F（查找），然后将项目编号粘贴到查找字段中，然后粘贴Find Next。我正在尝试创建一个宏，它将缩短该过程，因为我每天执行一百次。我发现了一个相反的宏（在Excel中找到一个突出显示的数字，并通过Outlook搜索以查找电子邮件。我试图对其进行修改以适应我的目的，但它超出了我的技能水平。任何帮助将不胜感激。这是代码我正在尝试转换为在Excel工作表中搜索在Outlook电子邮件中突出显示的项目编号。

'Code:
Option Explicit

Public Sub Search_Outlook_Emails()

    Dim outApp As Outlook.Application
    Dim outNs As Outlook.Namespace
    Dim outStartFolder As Outlook.MAPIFolder
    Dim foundEmail As Outlook.MailItem

    Set outApp = New Outlook.Application
    Set outNs = outApp.GetNamespace("MAPI")

    'Start at Inbox's parent folder
    Set outStartFolder = outNs.GetDefaultFolder(Outlook.olFolderInbox).Parent

    'Or start at folder selected by user
    'Set outStartFolder = outNs.PickFolder


    If Not outStartFolder Is Nothing Then

        Set foundEmail = Find_Email_In_Folder(outStartFolder, ActiveCell.Value)

        If Not foundEmail Is Nothing Then

            If MsgBox("Email subject: " & foundEmail.Subject & vbNewLine & vbNewLine & _
                      "Folder: " & foundEmail.Parent.FolderPath & vbNewLine & vbNewLine & _
                      "Open the email?", vbYesNo, "'" & ActiveCell.Value & "' found") = vbYes Then

                foundEmail.Display

            End If

        Else

            MsgBox "", vbOKOnly, "'" & ActiveCell.Value & "' not found"

        End If

    End If

End Sub

Private Function Find_Email_In_Folder(outFolder As Outlook.MAPIFolder, findText As String) As Outlook.MailItem

    Dim outItem As Object
    Dim outMail As Outlook.MailItem
    Dim outSubFolder As Outlook.MAPIFolder
    Dim i As Long

    Debug.Print outFolder.FolderPath

    Set Find_Email_In_Folder = Nothing

    'Search emails in this folder

    i = 1
    While i <= outFolder.Items.Count And Find_Email_In_Folder Is Nothing

        Set outItem = outFolder.Items(i)

        If outItem.Class = Outlook.OlObjectClass.olMail Then

            'Does the findText occur in this email's body text?

            Set outMail = outItem
            If InStr(1, outMail.Body, findText, vbTextCompare) > 0 Then Set Find_Email_In_Folder = outMail

        End If

        i = i + 1

    Wend

    DoEvents

    'If not found, search emails in subfolders

    i = 1
    While i <= outFolder.Folders.Count And Find_Email_In_Folder Is Nothing

        Set outSubFolder = outFolder.Folders(i)

        'Only check mail item folders

        If outSubFolder.DefaultItemType = Outlook.olMailItem Then Set Find_Email_In_Folder = Find_Email_In_Folder(outSubFolder, findText)

        i = i + 1

    Wend

End Function

Answer 1

感谢链接Tim。那要简单得多。我之前曾经看过该代码，但无法使其正常工作，因此我再次尝试。这就是我最后得到的。它仍然可以使用一些调整和错误处理，但这是目前正在起作用的：

Sub FindOutlookValue()

Dim OutApp As Object
Dim OutMail As Object
Dim olInsp As Object
Dim WdDoc As Object
Dim strText As String

On Error Resume Next

'Get Outlook if it's running
Set OutApp = GetObject(, "Outlook.Application")
Set OutMail = OutApp.ActiveExplorer.Selection.Item(1)

With OutMail
    Set olInsp = .GetInspector
    Set wdDoc = olInsp.WordEditor
    strText = WdDoc.Application.Selection.Range.Text
End With

'Find strText in Excel
Dim cl As Range
With Worksheets("MyWorksheet").Cells
    Set cl = .Find(strText, After:=.Range(A1), LookIn:=xlValues)
    If Not cl Is Nothing Then
       cl.Select
    End If
End With

End Sub

在Excel工作表中搜索Outlook电子邮件中突出显示的文本

1 个答案: