Question

我必须计算在一定条件下每周报告收到的邮件数。邮件位于Outlook的各种文件夹和子文件夹中。

Dim objOutlook As Object, objnSpace As Object, objFolder As Outlook.MAPIFolder
Dim EmailCount As Integer

Sub HowManyDatedEmails()
    Set objOutlook = CreateObject("Outlook.Application")
    Set objnSpace = objOutlook.GetNamespace("MAPI")

    On Error Resume Next
    Set objFolder = objnSpace.GetDefaultFolder(olFolderInbox)
    If Err.Number <> 0 Then
        Err.Clear
        MsgBox "No such folder."
        Exit Sub
    End If

    Dim iCount As Integer, DateCount1 As Integer
    Dim myDate1 As Date
    Dim myDate2 As Date
    Dim DateCount2 As Integer

    EmailCount = objFolder.Items.Count
    DateCount1 = 0
    DateCount2 = 0
    myDate1 = Sheets("Sheet1").Range("A1").Value
    myDate2 = Sheets("Sheet1").Range("B1").Value

    For iCount = 1 To EmailCount
        With objFolder.Items(iCount)

            If DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) >= myDate1 And _
              DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) <= myDate2 And _
              .SenderEmailAddress Like "*kailash*" Then

                DateCount1 = DateCount1 + 1
            End If

            If DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) >= myDate1 And _
              DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) <= myDate2 And _
              .SenderEmailAddress Like "*soumendra*" Then

                DateCount2 = DateCount2 + 1
            End If

         End With
     Next iCount

    Set objFolder = Nothing
    Set objnSpace = Nothing
    Set objOutlook = Nothing
    Sheets("Sheet1").Range("B2").Value = DateCount1
    Sheets("Sheet1").Range("B3").Value = DateCount2

End Sub

我想要Excel VBA代码，以便工作表列表显示相对于标准编号的计数图。

我能够为一个文件夹做到这一点，但是我想在收件箱中递归地为所有文件夹和子文件夹实现它。

Answer 1

正如我在评论中所说，这是一个Outlook宏。如有必要，我可以向您展示如何将其转换为Excel宏。如果您需要更多帮助，则必须扩大问题范围。

Sub ListStoresAndAllFolders()

  ' Displays the name of every accessible store
  ' Under each store, displays an indented list of all its folders

  ' Technique for locating desktop from answer by Kyle:
  ' http://stackoverflow.com/a/17551579/973283

  ' Needs reference to Microsoft Scripting Runtime if "TextStream"
  ' and "FileSystemObject" are to be recognised

  Dim FileOut As TextStream
  Dim FldrCrnt As Folder
  Dim Fso As FileSystemObject
  Dim InxFldrChild As Long
  Dim InxStoreCrnt As Long
  Dim Path As String
  Dim StoreCrnt As Folder

  Path = CreateObject("WScript.Shell").specialfolders("Desktop")

  Set Fso = CreateObject("Scripting.FileSystemObject")
  Set FileOut = Fso.CreateTextFile(Path & "\ListStoresAndAllFolders.txt", True)

  With Application.Session
    For InxStoreCrnt = 1 To .Folders.Count
      Set StoreCrnt = .Folders(InxStoreCrnt)
      With StoreCrnt
        FileOut.WriteLine .Name
        For InxFldrChild = .Folders.Count To 1 Step -1
          Set FldrCrnt = .Folders(InxFldrChild)
          Call ListAllFolders(FldrCrnt, 1, FileOut)
        Next
      End With
    Next
  End With

  FileOut.Close

End Sub
Sub ListAllFolders(ByRef Fldr As Folder, ByVal Level As Long, ByRef FileOut As TextStream)

  ' This routine:
  '  1. Output name of Fldr
  '  2. Calls itself for each child of Fldr
  ' It is designed to be called by ListStoresAndAllFolders()

  Dim InxFldrChild As Long

  With Fldr
    FileOut.WriteLine Space(Level * 2) & .Name
    For InxFldrChild = .Folders.Count To 1 Step -1
      Call ListAllFolders(.Folders(InxFldrChild), Level + 1, FileOut)
    Next
  End With

End Sub

如何根据标准使用Excel VBA从Outlook中的所有文件夹和子文件夹计算电子邮件？

1 个答案: