Question

我很想知道如何将电子邮件从特定子文件夹移动到我的硬盘驱动器。基本上，我的收件箱有大约20个子文件夹。我希望能够将所有电子邮件从子文件夹1移动到我的硬盘驱动器。

是否有专门访问该文件夹的宏并将所有电子邮件移至我的硬盘上？当然，我确实希望将所有电子邮件保存在.msg而不是.txt文件中。

Answer 1

我很高兴你可以开发一个VBA宏或加载项来完成工作。请参阅Getting Started with VBA in Outlook 2010开始使用。

MailItem类的SaveAs方法将Microsoft Outlook项目保存到指定的路径并以指定的文件类型的格式保存。如果未指定文件类型，则使用MSG格式（.msg）。要保存的文件类型可以是以下 OlSaveAsType 常量之一：olHTML，olMSG，olRTF，olTemplate，olDoc，olTXT，olVCal，olVCard，olICal或olMSGUnicode。例如：

 Sub SaveAsMSG() 
  Dim myItem As Outlook.Inspector 
  Dim objItem As Object 

  Set myItem = Application.ActiveInspector 
  If Not TypeName(myItem) = "Nothing" Then 
   Set objItem = myItem.CurrentItem 
   strname = objItem.Subject 
   'Prompt the user for confirmation 
   Dim strPrompt As String 
   strPrompt = "Are you sure you want to save the item? " & _ 
   "If a file with the same name already exists, " & _ 
   "it will be overwritten with this copy of the file." 
   If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then 
    objItem.SaveAs Environ("HOMEPATH") & "\My Documents\" & strname & ".msg", olMSG 
   End If 
  Else 
   MsgBox "There is no current active inspector." 
  End If 
 End Sub

Answer 2

这应该允许您选择outlook文件夹和硬盘文件夹，该文件夹中的所有电子邮件和所有子文件夹将保存到您的HD

Option Explicit
Sub SaveMsgToFolders()
    Dim i, j, n As Long
    Dim sSubject As String
    Dim sName As String
    Dim sFile As String
    Dim sReceived As String
    Dim sPath As String
    Dim sFolder As String
    Dim sFolderPath As String
    Dim SaveFolder As String
    Dim Prompt As String
    Dim Title As String
    Dim iNameSpace As NameSpace
    Dim olApp As Outlook.Application
    Dim SubFolder As MAPIFolder
    Dim olmItem As MailItem
    Dim FSO, ChosenFolder As Object
    Dim Folders As New Collection
    Dim EntryID As New Collection
    Dim StoreID As New Collection

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

    Prompt = "Please enter the path to save all the emails to."
    Title = "Folder Specification"
    sPath = BrowseForFolder
    If sPath = "" Then
GoTo ExitSub:
    End If
    If Not Right(sPath, 1) = "\" Then
        sPath = sPath & "\"
    End If

    Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)

    For i = 1 To Folders.Count
        sFolder = StripIllegalChar(Folders(i))
        n = InStr(3, sFolder, "\") + 1
        sFolder = Mid(sFolder, n, 256)
        sFolderPath = sPath & sFolder & "\"
        SaveFolder = Left(sFolderPath, Len(sFolderPath) - 1) & "\"
        If Not FSO.FolderExists(sFolderPath) Then
            FSO.CreateFolder (sFolderPath)
        End If

        Set SubFolder = olApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
        On Error Resume Next
        For j = 1 To SubFolder.Items.Count
            Set olmItem = SubFolder.Items(j)
            sReceived = ArrangedDate(olmItem.ReceivedTime)
            sSubject = olmItem.Subject
            sName = StripIllegalChar(sSubject)
            sFile = SaveFolder & sReceived & "_" & sName & ".msg"
            sFile = Left(sFile, 256)
            olmItem.SaveAs sFile, 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


Function ArrangedDate(sDateInput)
    Dim sFullDate As String
    Dim sFullTime As String
    Dim sAMPM As String
    Dim sTime As String
    Dim sYear As String
    Dim sMonthDay As String
    Dim sMonth As String
    Dim sDay As String
    Dim sDate As String
    Dim sDateTime As String
    Dim RegX As Object

    Set RegX = CreateObject("vbscript.regexp")

    If Not Left(sDateInput, 2) = "10" And _
    Not Left(sDateInput, 2) = "11" And _
    Not Left(sDateInput, 2) = "12" Then
        sDateInput = "0" & sDateInput
    End If

    sFullDate = Left(sDateInput, 10)

    If Right(sFullDate, 1) = " " Then
        sFullDate = Left(sDateInput, 9)
    End If

    sFullTime = Replace(sDateInput, sFullDate & " ", "")

    If Len(sFullTime) = 10 Then
        sFullTime = "0" & sFullTime
    End If

    sAMPM = Right(sFullTime, 2)
    sTime = sAMPM & "-" & Left(sFullTime, 8)
    sYear = Right(sFullDate, 4)
    sMonthDay = Replace(sFullDate, "/" & sYear, "")
    sMonth = Left(sMonthDay, 2)
    sDay = Right(sMonthDay, Len(sMonthDay) - 3)
    If Len(sDay) = 1 Then
        sDay = "0" & sDay
    End If
    sDate = sYear & "-" & sMonth & "-" & sDay
    sDateTime = sDate & "_" & sTime
    RegX.Pattern = "[\:\/\ ]"
    RegX.IgnoreCase = True
    RegX.Global = True

    ArrangedDate = RegX.Replace(sDateTime, "-")

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(Optional OpenAt As String) As String
    Dim ShellApp As Object
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0

    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then
            BrowseForFolder = ""
        End If
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then
            BrowseForFolder = ""
        End If
    Case Else
        BrowseForFolder = ""
    End Select

ExitFunction:
    Set ShellApp = Nothing
End Function

将电子邮件从子文件夹移动到硬盘驱动器

2 个答案: