VBA Outlook备份邮件

备份邮件

Sub SaveEmailsAsMsgFiles()
 
    Dim objOutlook As Object
    Dim objNamespace As Object
    Dim objInbox As Object
    Dim objMail As Object
    Dim savePath As String
    Dim fileName As String
    Dim i As Long
    Dim olRootFolder As Outlook.MAPIFolder
    Dim olStore As Outlook.Store
    
    Dim oExplorer As Explorer
    Dim oSelection As Selection
    Dim strFolderName As String
    
    'Set outlook application object
    Set objOutlook = CreateObject("Outlook.Application")
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    'Set objInbox = objNamespace.GetDefaultFolder(olFolderInbox)
    'Set objInbox = objNamespace.Folders("chunyu@xxxx.cn").Folders("JIPC")
    Set oExplorer = Application.ActiveExplorer
    ' ?取当前?中的?目
    Set oSelection = oExplorer.Selection
    
    ' ??是否有?目被?中
    If oSelection.Count > 0 Then
        Set oFolder = oSelection.Item(1).Parent
        strFolderName = oFolder.Name
        Set objInbox = objNamespace.Folders("chunyu@xxxx.cn").Folders(strFolderName)
    Else
        MsgBox "There are no selected folders."
    End If
    
'    Stop
    
    
    'Set save path
    savePath = "C:\Users\chunyu\Desktop\MailBk\" & strFolderName & "\"
    
    'Traverse every email in the specified inbox
    For i = 1 To objInbox.Items.Count
        If TypeOf objInbox.Items(i) Is MailItem Then
            Set objMail = objInbox.Items(i)
            'Set mail name
                toname = objMail.To
                If (Len(toname) > 16) Then
                toname = Left(toname, 16) & "_etc"
                End If
                
                'fileName = Format(objMail.ReceivedTime, "yyyymmdd_hhnnss") & "_" & objMail.SenderName & "_to_" & toname & "_主?：" & objMail.Subject
                'fileName = Format(objMail.ReceivedTime, "yyyymmdd_hhnnss") & "_"
                fileName = objMail.Subject
                
                
                
                
                fileName = Replace(fileName, "/", "_")
                fileName = Replace(fileName, "\", "_")
                fileName = Replace(fileName, "?", "_")
                fileName = Replace(fileName, "*", "_")
                fileName = Replace(fileName, """", "'")
                fileName = Replace(fileName, "<", "_")
                fileName = Replace(fileName, ">", "_")
                fileName = Replace(fileName, "|", "_")
                fileName = Replace(fileName, ";", "_")
                fileName = Replace(fileName, ":", "_")
                fileName = Replace(fileName, Chr(34), "'")
                fileName = Replace(fileName, Chr(10), "_") & ".msg"
            ' 注意：?里使用了SentOn属性，但如果想要保存接收??，?改用ReceivedTime
            ' fileName = objMail.SenderName & ":" & objMail.Subject & "," & Format(objMail.ReceivedTime, "yyyy-mm-dd_hhnnss") & ".msg"
                'Debug.Print (fileName)
            
            'Save mail
            objMail.SaveAs savePath & fileName, olMSG
             
            'Release memory
            Set objMail = Nothing
        End If
    Next i
    
    'Release memory
    Set objInbox = Nothing
    Set objNamespace = Nothing
    Set objOutlook = Nothing
    
    MsgBox "Success!" & vbNewLine & "All emails have been saved to the specified folder."
End Sub