如何在excel中使用Outlook2003中的搜索文件夹数据

QandAandNB

在使用excel作数据统计的时候需要记录特定的邮件的数量。已经在Outlook2003中建立了搜索文件夹，但每次都需要向excel手动填写数量。怎样才能让excel自动读取到这些邮件的数量？

dsd999

Sub EnumSearchFolders()
    Dim cdo As MAPI.Session
    Dim store As MAPI.InfoStore
    Dim sfld As MAPI.Folder
    Dim fld As MAPI.Folder
    Dim f As MAPI.Field
    Dim strFinderID As String
    Dim strList As String
    Dim count As Integer
    Const PR_FINDER_ENTRYID = &H35E70102
    Const PR_IPM_PUBLIC_FOLDERS_ENTRYID = &H66310102
    Dim blnMayHaveSearches As Boolean
    On Error Resume Next
                 
    strFolderName = UCase(strFolderName)
    Set cdo = CreateObject("MAPI.Session")
    cdo.Logon "", "", False, False
    For Each store In cdo.InfoStores
        blnMayHaveSearches = True

        ' ignore if it's the Public Folders hierarchy
        ' don't have search folders in Public Folders
        If store.ProviderName = "Microsoft Exchange Server" Then
            Set f = store.Fields.Item(PR_IPM_PUBLIC_FOLDERS_ENTRYID)
            If Not f Is Nothing Then
                blnMayHaveSearches = False
            End If
            Set f = Nothing
        End If
         
        If blnMayHaveSearches Then
            strFinderID = _
                store.Fields.Item(PR_FINDER_ENTRYID).Value
            Set sfld = cdo.GetFolder(strFinderID, store.ID)
            If Not sfld Is Nothing Then
                count = sfld.Folders.count
                If count > 0 Then
                    strList = strList & vbCrLf & store.name & " has " & _
                            CStr(count) & " search " & _
                            IIf(count = 1, "folder:", "folders:")
                    For Each fld In sfld.Folders
                        If fld.name <> "" Then
                            strList = strList & vbCrLf & vbTab & fld.name
                        End If
                    Next
                    strList = strList & vbCrLf
                End If
            End If
            
        End If
    Next
    If Len(strList) > 2 Then
        strList = Mid(strList, 3)
        MsgBox strList
    Else
        MsgBox "No search folders found"
    End If

    cdo.Logoff
    Set cdo = Nothing
    Set store = Nothing
    Set fld = Nothing
    Set sfld = Nothing
End Sub

dsd999

Reference要增加CDO