Vba 在outlook中保存所有电子邮件和.msg文件

我已经使用一段代码将选定的电子邮件保存为.msg文件有一段时间了，但我不知道要修改什么才能保存所有电子邮件：

Option Explicit
Public Sub SaveMessageAsMsg()
  Dim oMail As Outlook.MailItem
  Dim objItem As Object
  Dim sPath As String
  Dim dtDate As Date
  Dim sName As String
  Dim enviro As String
  Dim strFolderpath As String




    enviro = CStr(Environ("USERPROFILE"))
    strFolderpath = BrowseForFolder(enviro & "\documents\")

   For Each objItem In ActiveExplorer.Selection

   If objItem.MessageClass = "IPM.Note" Then
    Set oMail = objItem

  sName = oMail.Subject
  ReplaceCharsForFileName sName, "-"

  dtDate = oMail.ReceivedTime
  sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
    vbUseSystem) & Format(dtDate, "-hhnnss", _
    vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"

  sPath = strFolderpath & "\"
  Debug.Print sPath & sName
  oMail.SaveAs sPath & sName, olMSG

  End If
  Next

End Sub

我知道我需要更改ActiveExplorer.Selection中每个objItem的，以包含所有项，但我对VB不太熟悉，也没有找到需要替换的项

---

我试过使用当前文件夹和一些其他选项

创建一个函数，该函数将

MAPIFolder

作为参数，并循环遍历

MAPIFolder.items

集合中的所有项。然后，该函数必须为

MAPIFOlder.Folders

集合中的所有子文件夹递归调用自身

上面的代码必须为

应用程序.Session.folders

集合中的所有文件夹调用该函数（表示Outlook中的所有顶级文件夹）。

示例如下

下面是我用来做我需要的事情的完整代码

选项显式
作为字符串的Dim StrSavePath
子SaveAllEmails\u ProcessAllSubFolders（）
我想我会坚持多久
Dim j尽可能长
长
作为字符串的Dim StrSubject
将StrName设置为字符串
作为字符串的Dim StrFile
接收为字符串的Dim STR
作为字符串的Dim StrFolder
将StrSaveFolder设置为字符串
将StrFolderPath设置为字符串
Dim iNameSpace作为名称空间
将myOLAP设置为Outlook.Application
将子文件夹变暗为MAPIFolder
Dim mItem作为邮件项
作为对象的Dim FSO
Dim Chosen文件夹作为对象
将文件夹暗显为新集合
Dim EntryID作为新集合
将StoreID设置为新集合
设置FSO=CreateObject（“Scripting.FileSystemObject”）
设置myOlApp=Outlook.Application
Set iNameSpace=myOlApp.GetNamespace（“MAPI”）
设置ChosenFolder=iNameSpace.PickFolder
如果ChosenFolder什么都不是，那么
后藤进出口银行：
如果结束
浏览文件夹StrSavePath
调用GetFolder（文件夹、EntryID、StoreID、ChosenFolder）
对于i=1到文件夹。计数
StrFolder=StripIllegalChar（文件夹（i））
n=仪表（3，标准件，“\”）+1
StrFolder=Mid（StrFolder，n，256）
StrFolderPath=StrSavePath&“\”&StrFolder&“\”
StrSaveFolder=Left（StrFolderPath，Len（StrFolderPath）-1）和“\”
如果不是FSO.FolderExists（StrFolderPath），则
FSO.CreateFolder（StrFolderPath）
如果结束
Set SubFolder=myOlApp.Session.GetFolderFromID（EntryID（i），StoreID（i））
出错时继续下一步
对于j=1到子文件夹.Items.Count
Set mItem=子文件夹项（j）
StrReceived=格式（mItem.ReceivedTime，“yyyyymmdd hhmm”）
StrSubject=mItem.Subject
StrName=StripIllegalChar（StrSubject）
StrFile=StrSaveFolder&StrReceived&“\u”&StrName&“.msg”
StrFile=Left（StrFile，256）
mItem.SaveAs StrFile，3
下一个j
错误转到0
接下来我
进出口银行：
端接头
函数StripIllegalChar（StrInput）
Dim RegX作为对象
设置RegX=CreateObject（“vbscript.regexp”）
RegX.Pattern=“[\”&Chr（34）和“\！\@\\\\\$\%\^\&\*\（\）\=\+\\\\\[\]\\\\\\\\\\\\\\\\\\？\/\，]”
RegX.IgnoreCase=True
RegX.Global=True
StripIllegalChar=RegX.Replace（StrInput，“”）
退出功能：
Set RegX=Nothing
端函数
子GetFolder（文件夹作为集合，EntryID作为集合，StoreID作为集合，Fld作为MAPIFolder）
将子文件夹变暗为MAPIFolder
文件夹。添加Fld.FolderPath
EntryID.Add Fld.EntryID
StoreID.Add Fld.StoreID
对于Fld.文件夹中的每个子文件夹
GetFolder文件夹、EntryID、StoreID、子文件夹
下一个子文件夹
进出口银行：
设置子文件夹=无
端接头
函数BrowseForFolder（StrSavePath作为字符串，可选OpenAt作为字符串）作为字符串
Dim objShell作为对象
Dim objFolder'作为文件夹
暗淡环境
enviro=CStr（环境（“用户档案”））
设置objShell=CreateObject（“Shell.Application”）
设置objFolder=objShell.BrowseForFolder（0，“请选择一个文件夹”，0，enviro&“\Documents\”）
StrSavePath=objFolder.self.Path
出错时继续下一步
错误转到0
退出功能：
Set objShell=Nothing
端函数

所有电子邮件在哪里？在特定的Outlook文件夹中？所有Outlook文件夹？某个文件夹中的邮件子集？我希望导出所有文件夹中的所有电子邮件。请给我一个示例，我不确定是否理解。我无法为您编写代码。你对哪一部分有问题？

Option Explicit
Public Sub Example()
    Dim olNs As Outlook.NameSpace
    Set olNs = Application.Session

    Dim Inbox As Outlook.MAPIFolder
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox) ' Inbox

'   // Process Current Folder
    CURRENT_FOLDER Inbox

End Sub

Private Sub CURRENT_FOLDER(ByVal ParentFolder As Outlook.MAPIFolder)
    Dim SUBFOLDER As Outlook.MAPIFolder

    Dim Items As Outlook.Items
    Set Items = ParentFolder.Items
    Debug.Print ParentFolder.Name ' Print on Immediate Window

    Dim i As Long
    For i = Items.Count To 1 Step -1
        DoEvents
        Debug.Print Items(i).Subject ' Print on Immediate Window
    Next

'   // Recurse through subfolders
    If ParentFolder.Folders.Count > 0 Then
        For Each SUBFOLDER In ParentFolder.Folders
            CURRENT_FOLDER SUBFOLDER
        Next
    End If

End Sub

Option Explicit
       Dim StrSavePath     As String
Sub SaveAllEmails_ProcessAllSubFolders()

    Dim i               As Long
    Dim j               As Long
    Dim n               As Long
    Dim StrSubject      As String
    Dim StrName         As String
    Dim StrFile         As String
    Dim StrReceived     As String
    Dim StrFolder       As String
    Dim StrSaveFolder   As String
    Dim StrFolderPath   As String
    Dim iNameSpace      As NameSpace
    Dim myOlApp         As Outlook.Application
    Dim SubFolder       As MAPIFolder
    Dim mItem           As MailItem
    Dim FSO             As Object
    Dim ChosenFolder    As Object
    Dim Folders         As New Collection
    Dim EntryID         As New Collection
    Dim StoreID         As New Collection

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set myOlApp = Outlook.Application
    Set iNameSpace = myOlApp.GetNamespace("MAPI")
    Set ChosenFolder = iNameSpace.PickFolder
    If ChosenFolder Is Nothing Then
GoTo ExitSub:
    End If

BrowseForFolder StrSavePath

    Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)

    For i = 1 To Folders.Count
        StrFolder = StripIllegalChar(Folders(i))
        n = InStr(3, StrFolder, "\") + 1
        StrFolder = Mid(StrFolder, n, 256)
        StrFolderPath = StrSavePath & "\" & StrFolder & "\"
        StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"
        If Not FSO.FolderExists(StrFolderPath) Then
            FSO.CreateFolder (StrFolderPath)
        End If

        Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
        On Error Resume Next
        For j = 1 To SubFolder.Items.Count
            Set mItem = SubFolder.Items(j)
            StrReceived = Format(mItem.ReceivedTime, "YYYYMMDD-hhmm")
            StrSubject = mItem.Subject
            StrName = StripIllegalChar(StrSubject)
            StrFile = StrSaveFolder & StrReceived & "_" & StrName & ".msg"
            StrFile = Left(StrFile, 256)
            mItem.SaveAs StrFile, 3
        Next j
        On Error GoTo 0
    Next i

ExitSub:

End Sub

Function StripIllegalChar(StrInput)
    Dim RegX            As Object

    Set RegX = CreateObject("vbscript.regexp")

    RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
    RegX.IgnoreCase = True
    RegX.Global = True

    StripIllegalChar = RegX.Replace(StrInput, "")

ExitFunction:
    Set RegX = Nothing

End Function


Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As MAPIFolder)
    Dim SubFolder       As MAPIFolder

    Folders.Add Fld.FolderPath
    EntryID.Add Fld.EntryID
    StoreID.Add Fld.StoreID
    For Each SubFolder In Fld.Folders
        GetFolder Folders, EntryID, StoreID, SubFolder
    Next SubFolder

ExitSub:
    Set SubFolder = Nothing

End Sub


Function BrowseForFolder(StrSavePath As String, Optional OpenAt As String) As String
    Dim objShell As Object
    Dim objFolder '  As Folder

Dim enviro
enviro = CStr(Environ("USERPROFILE"))
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Please choose a folder", 0, enviro & "\Documents\")
StrSavePath = objFolder.self.Path

    On Error Resume Next
    On Error GoTo 0

ExitFunction:
    Set objShell = Nothing

End Function