Vba 搜索特定的Outlook文件夹

我一直在互联网上搜寻一种宏搜索Outlook特定文件夹而不是收件箱的简便方法！使用activecell支架。我试过了，但没有用。首先，我在使用Outlook引用时遇到了问题，现在已经解决了。我能得到的最接近的结果是使用以下代码：

Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.MAPIFolder
Dim myitems As Outlook.Items
Dim myitem As Object
Dim Found As Boolean
Dim OutlookSearch as string

Outlooksearch = Cstr(Activecell.cells(1,4).Value)

Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myitems = myInbox.Items
Found = False

For Each myitem In myitems
    If myitem.Class = olMail Then
        If InStr(1, myitem.Subject, "sketch") > 0 Then
            Debug.Print "Found"
            Found = True
        End If
    End If
Next myitem

'If the subject isn't found:
If Not Found Then
    MsgBox "Cannot find"
End If

myOlApp.Quit
Set myOlApp = Nothing

---

现在，我要做的是使用Activecell.cells1，4中的字符串。作为主题的参数，并在收件箱中的特定outlook文件夹中进行搜索，以缩小范围。即使我用activecell发送了一封包含匹配值的电子邮件，我也只能得到MsgBox。

您可以使用.Folders属性在收件箱中指定要搜索的文件夹

Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("myFolder")

---

我玩了一番，想出了下面的代码。无需设置对Outlook的引用

Sub Test1()

    Dim oOutlook As Object 'Outlook.Application
    Dim nNameSpace As Object 'Outlook.Namespace
    Dim mFolderSelected As Object 'Outlook.MAPIFolder
    Dim cFolder As Object
    Dim oItem As Object
    Dim oMyItem As Object
    Dim sOutlookSearch As String
    Dim aFolders() As String
    Dim i As Long

    'sOutlookSearch needs to be something like:
    '"Mailbox - Darren Bartrup-Cook\Inbox"

    sOutlookSearch = ThisWorkbook.Worksheets("Sheet1").Cells(1, 4)
    sOutlookSearch = Replace(sOutlookSearch, "/", "\")
    aFolders() = Split(sOutlookSearch, "\")

    Set oOutlook = GetObject(, "Outlook.Application")
    Set nNameSpace = oOutlook.GetNamespace("MAPI")

    Set mFolderSelected = nNameSpace.Folders.Item(aFolders(0))
    If Not mFolderSelected Is Nothing Then
        For i = 1 To UBound(aFolders)
            Set cFolder = mFolderSelected.Folders
            Set mFolderSelected = Nothing
            Set mFolderSelected = cFolder.Item(aFolders(i))
            If mFolderSelected Is Nothing Then
              Exit For
            End If
        Next i
    End If

    'Set mFolderSelected = nNameSpace.PickFolder 'Alternative to above code block - just pick the folder.

    For Each oItem In mFolderSelected.items
        If oItem.class = 43 Then '43 = olmail
            If InStr(1, oItem.Subject, "sketch") > 0 Then
                Debug.Print "Found:  " & oItem.sendername
                Exit For
            End If
        End If
    Next oItem

End Sub

查找正确文件夹的代码块取自此处：

---

大家好，我今天刚上网。我现在就试试你的代码。对于这一行：设置myInbox=myNameSpace.GetDefaultFolderolFolderInbox.FoldersMyFolderFolderFolderFolderFolderFolderFolderFolderFolderFolderFolder。。。如果它在子文件夹中呢？这是@vockz给出的答案。要使用此方法获取子文件夹，请使用：设置myInbox=myNameSpace.GetDefaultFolderolFolderInbox.FoldersTemp.Foldersaa对于更多子文件夹，最好将以下内容放入循环中：Dim sInbox As String Dim sPath As String Dim i Long sInbox=Temp\aa sPath=SplitsInbox，\Set myInbox=myNameSpace.GetDefaultFolderolFolderInbox For i=LBoundsPath To UBoundsPath Set myInbox=myInbox.FoldersPathi Next i