保存OUTLOOK邮件到指定文件夹，含所有邮件及新邮件自动保存
本帖最后由 苏紫方璇 于 2024-9-23 13:16 编辑以下代码放到类模块里，注意类模块。
'类模块
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
'以下为保存所有文件（手动运行保存），放哪里运行都行
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里，不要放模块里
保存邮件：
'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
留用，用outlook的人不多 保存一下，指不定哪天会用上 代码插入可以参考这个帖子
【公告】发帖代码插入以及添加链接教程（有福利）
https://www.52pojie.cn/thread-713042-1-1.html
(出处: 吾爱破解论坛)
苏紫方璇 发表于 2024-9-23 13:14
代码插入可以参考这个帖子
【公告】发帖代码插入以及添加链接教程（有福利）
https://www.52pojie.cn/thr ...
谢谢，我清楚，就是偷懒了，被你发现了：） 学习下，说不定哪天用的上 请问这个VBA怎么运行了 小哥哥outlook 怎么运行
页:
[1]