保存OUTLOOK邮件到指定文件夹，含所有邮件及新邮件自动保存

etkane

以下代码放到类模块里，注意类模块。

[Visual Basic] 纯文本查看 复制代码

'类模块
Public WithEvents objInboxItems As Outlook.Items

Private Sub Class_Initialize()
    Dim objOutlook As Outlook.Application
    Set objOutlook = Outlook.Application
    Set objInboxItems = objOutlook.Session.GetDefaultFolder(olFolderInbox).Items
End Sub

'以下为保存所有文件（手动运行保存），放哪里运行都行

[Visual Basic] 纯文本查看 复制代码

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
   
    ' 设置Outlook应用程序对象
    Set objOutlook = CreateObject("Outlook.Application")
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    Set objInbox = objNamespace.GetDefaultFolder(olFolderInbox)
   
    ' 设置邮件保存的路径
    ' 注意：确保这个路径是存在的，并且你有写入权限
    savePath = "D:\1001-项目\1097-01-邮件副本\"
   
    ' 检查收件箱中的每一封邮件
    For i = 1 To objInbox.Items.Count
        If TypeOf objInbox.Items(i) Is MailItem Then
            Set objMail = objInbox.Items(i)
            '替换特殊字符
           ' fileName =  '& ":" & objMail.Subject
            
'                n = n + 1
'                If (n = 4) Then
'                   Exit For
'                End If
            
            
               

                'fileName = Left(fileName, 15)
               
            ' 构建文件名  & "_" & Format(objMail.ReceivedTime, "yyyy-mm-dd_hhnnss") & ".msg"
                toname = objMail.To
                If (Len(toname) > 16) Then
                toname = Left(toname, 16) & "_etc"
                End If
               
                 fileName = Format(mail.ReceivedTime, "yyyymmdd_hhnnss") & "_" & mail.SenderName & "_to_" & toname & "_主题：" & mail.Subject
                'fileName = objMail.SenderName & "_to_" & toname & "_主题：" & objMail.Subject & "_" & Format(objMail.ReceivedTime, "yyyymmdd_hhnnss")
                'fileName = Left(fileName, 50)
               
                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)
            ' 保存邮件
            objMail.SaveAs savePath & fileName, olMSG
            
            ' 释放对象
            Set objMail = Nothing
        End If
    Next i
   
    ' 清理
    Set objInbox = Nothing
    Set objNamespace = Nothing
    Set objOutlook = Nothing
   
    MsgBox "所有邮件已保存到指定文件夹。"
End Sub

‘以下为自动保存新邮件，特别注意，如果想随着OUTLOOK开机就用，放到 this outlooksession里，不要放模块里


保存邮件：

[Visual Basic] 纯文本查看 复制代码

'this outlook session
Private WithEvents myOlItems As Outlook.Items





Private Sub Application_Startup()
    Set myOlItems = Outlook.Session.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub myOlItems_ItemAdd(ByVal Item As Object)
    Dim msg As Outlook.MailItem
    If TypeName(Item) = "MailItem" Then
        Set msg = Item
        SaveMailToFolder msg, "D:\1001-项目\1097-01-邮件副本\"
    End If
End Sub

Sub SaveMailToFolder(mail As Outlook.MailItem, folderPath As String)
    Dim savePath As String
    Dim extension As String
   
    ' 确定保存路径和文件扩展名
                toname = mail.To
                If (Len(toname) > 16) Then
                toname = Left(toname, 16) & "_etc"
                End If
               
               
                fileName = Format(mail.ReceivedTime, "yyyymmdd_hhnnss") & "_" & mail.SenderName & "_to_" & toname & "_主题：" & mail.Subject
                'fileName = Left(fileName, 50)
               
                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"

   
    savePath = folderPath & fileName
    Debug.Print (savePath)
        
    ' 保存邮件到指定路径
    mail.SaveAs savePath, olMSG
End Sub

tian780127

留用，用outlook的人不多

kcuye

保存一下，指不定哪天会用上

苏紫方璇

代码插入可以参考这个帖子
【公告】发帖代码插入以及添加链接教程（有福利）
https://www.52pojie.cn/thread-713042-1-1.html
(出处: 吾爱破解论坛)

etkane

苏紫方璇 发表于 2024-9-23 13:14
代码插入可以参考这个帖子
【公告】发帖代码插入以及添加链接教程（有福利）
https://www.52pojie.cn/thr ...

谢谢，我清楚，就是偷懒了，被你发现了：）

RabbitBearLove

学习下，说不定哪天用的上

wangsheng518

请问这个VBA怎么运行了 小哥哥  outlook 怎么运行