代码之家 › 专栏 › 技术社区 › jol1234

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

outlook email vba

jol1234 · 技术社区 · 7 年前

一段时间以来,我一直在使用一段代码将选定的电子邮件另存为。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中的每个objItem。选择 部分包括所有项目,但我对VB不太熟悉,也没有找到需要替换的内容。

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

3 回复 | 直到 4 年前

0m3r 7 年前

例如

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

Dmitry Streblechenko 7 年前

创建一个 MAPIFolder 作为参数,并在 MAPIFolder.Items 收集然后,该函数必须为中的所有子文件夹递归调用自身 MAPIFOlder.Folders 收集

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

0m3r 7 年前

这是我用来做我所需要的事情的完整代码

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