Question

我一直在使用一段代码将选定的电子邮件保存为.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

我知道我需要更改 For Each objItem在ActiveExplorer.Selection 部分以包含所有项目，但我并不过分熟悉VB并且没有找到需要替换的内容

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

Answer 1

创建一个以MAPIFolder为参数并循环遍历MAPIFolder.Items集合中所有项目的函数。然后，该函数必须递归调用MAPIFOlder.Folders集合中的所有子文件夹。

上面的代码必须为Application.Session.Folders集合中的所有文件夹调用该函数（代表Outlook中的所有顶级文件夹）。

Answer 2

示例将是

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

Answer 3

以下是我用来做我需要的完整代码

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

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

3 个答案: