我可以在 Outlook 2013 中使用此 vba 宏在文件夹名称旁边添加电子邮件数量吗？

Question

我有这个宏来打印选定 Outlook 文件夹的文件夹树，但我需要在每个文件夹名称旁边添加电子邮件数量（每个文件夹分别不包括子文件夹）：

Dim MyFile, Structured, Base

Call ExportFolderNamesSelect()

Public Sub ExportFolderNamesSelect()
  Dim objOutlook
  Set objOutlook = CreateObject("Outlook.Application")

  Dim F, Folders
  Set F = objOutlook.Session.PickFolder

  If Not F Is Nothing Then
    Set Folders = F.Folders

    Dim Result
    Result = MsgBox("Do you want to structure the output?", vbYesNo+vbDefaultButton2+vbApplicationModal, "Output structuring")
    If Result = 6 Then
      Structured = True
    Else
      Structured = False
    End If

    MyFile = GetDesktopFolder() & "\outlookfolders.txt"
    Base = Len(F.FolderPath) - Len(Replace(F.FolderPath, "\", "")) + 1

    WriteToATextFile (StructuredFolderName(F.FolderPath, F.Name))

    LoopFolders Folders

    Set F = Nothing
    Set Folders = Nothing
    Set objOutlook = Nothing
  End If
End Sub

Private Function GetDesktopFolder()
  Dim objShell
  Set objShell = CreateObject("WScript.Shell")
  GetDesktopFolder = objShell.SpecialFolders("Desktop")
  Set objShell = Nothing
End Function

Private Sub LoopFolders(Folders)
  Dim F

  For Each F In Folders
    WriteToATextFile (StructuredFolderName(F.FolderPath, F.Name))
    LoopFolders F.Folders
  Next
End Sub

Private Sub WriteToATextFile(OLKfoldername)
  Dim objFSO, objTextFile
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  Set objTextFile = objFSO.OpenTextFile (MyFile, 8, True)
  objTextFile.WriteLine (OLKfoldername)
  objTextFile.Close
  Set objFSO = Nothing
  Set objTextFile = Nothing
End Sub

Private Function StructuredFolderName(OLKfolderpath, OLKfoldername)
  If Structured = False Then
    StructuredFolderName = Mid(OLKfolderpath, 3)
  Else
    Dim i, x, OLKprefix
    i = Len(OLKfolderpath) - Len(Replace(OLKfolderpath, "\", ""))

    For x = Base To i
      OLKprefix = OLKprefix & "-"
    Next

    StructuredFolderName = OLKprefix & OLKfoldername
  End If
End Function

你能帮我吗？

Answer 1

我找到了解决方案，将.Items.Count添加到文件夹名称，如下所示：

Dim MyFile, Structured, Base

Call ExportFolderNamesSelect()

Public Sub ExportFolderNamesSelect()
  Dim objOutlook
  Set objOutlook = CreateObject("Outlook.Application")

  Dim F, Folders
  Set F = objOutlook.Session.PickFolder

  If Not F Is Nothing Then
    Set Folders = F.Folders

    Dim Result
    Result = MsgBox("Do you want to structure the output?", vbYesNo+vbDefaultButton2+vbApplicationModal, "Output structuring")
    If Result = 6 Then
      Structured = True
    Else
      Structured = False
    End If

    MyFile = GetDesktopFolder() & "\outlookfolders.txt"
    Base = Len(F.FolderPath) - Len(Replace(F.FolderPath, "\", "")) + 1

    WriteToATextFile (StructuredFolderName(F.FolderPath, F.Name) & " " & F.Items.Count)

    LoopFolders Folders

    Set F = Nothing
    Set Folders = Nothing
    Set objOutlook = Nothing
  End If
End Sub

Private Function GetDesktopFolder()
  Dim objShell
  Set objShell = CreateObject("WScript.Shell")
  GetDesktopFolder = objShell.SpecialFolders("Desktop")
  Set objShell = Nothing
End Function

Private Sub LoopFolders(Folders)
  Dim F

  For Each F In Folders
    WriteToATextFile (StructuredFolderName(F.FolderPath, F.Name) & " " & F.Items.Count)
    LoopFolders F.Folders
  Next
End Sub

Private Sub WriteToATextFile(OLKfoldername)
  Dim objFSO, objTextFile
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  Set objTextFile = objFSO.OpenTextFile (MyFile, 8, True)
  objTextFile.WriteLine (OLKfoldername)
  objTextFile.Close
  Set objFSO = Nothing
  Set objTextFile = Nothing
End Sub

Private Function StructuredFolderName(OLKfolderpath, OLKfoldername)
  If Structured = False Then
    StructuredFolderName = Mid(OLKfolderpath, 3)
  Else
    Dim i, x, OLKprefix
    i = Len(OLKfolderpath) - Len(Replace(OLKfolderpath, "\", ""))

    For x = Base To i
      OLKprefix = OLKprefix & "-"
    Next

    StructuredFolderName = OLKprefix & OLKfoldername
  End If
End Function

谢谢你帮我...