caxa自动保存的文件在哪里_002.自动保存邮件到指定文件夹

本文使用 Zhihu On VSCode 创作并发布

使用步骤

1. 在outlook 2010客户端上设置好登录邮箱，将下面代码复制到模块中。

   
   Image
   • 需要在工具-引用 中勾选 Microsoft Outlook 14.0 Object Library
     
     Image
     
     Image

   代码如下：

Option Explicit
    '大前提：
    '需要在工具-引用 中勾选 Microsoft Outlook 14.0 Object Library
    '如没有14.0版本，可选别的版本进行尝试
    
'Sub SaveToNewFolder(MyMail As MailItem)
Sub SaveToNewFolder(MyMail)
    '将邮件保存至指定位置
    Dim strID As String
    Dim objNS As Outlook.NameSpace
    Dim objMail As Outlook.MailItem
    Dim objAtt As Outlook.Attachment
    Dim c As Integer
    'Dim save_name As String
    Dim save_path As String
    Dim save_path1 As String
    Dim mail_time As String
    
    '！！！请修改下行" "中间的内容为你需要保存邮件的目录！！！
    'save_path1 = "10.123.1.222部门共享企业技术中心7-公司来文"
    save_path1 = "C:saveMail"
    
    '-------------------------------------------------------------------------
    
    On Error Resume Next
    VBA.MkDir (save_path1)
    strID = MyMail.EntryID '返回对象的唯一项目标识。String 类型，只读。
    Set objNS = Application.GetNamespace("MAPI") '返回指定类型的 NameSpace 对象。
    Set objMail = objNS.GetItemFromID(strID) '返回一个由指定条目 ID（如果有效）标识的 Microsoft Outlook 项目。
    
    
    mail_time = Format(objMail.ReceivedTime, "yyyy-mm-dd")
    
    
    save_path = save_path1 & Split(mail_time, "-")(0) & "年" & Split(mail_time, "-")(1) & "月"
    VBA.MkDir (save_path1 & Split(mail_time, "-")(0) & "年")
    VBA.MkDir (save_path1 & Split(mail_time, "-")(0) & "年" & Split(mail_time, "-")(1) & "月")
    save_path = save_path & Format(objMail.ReceivedTime, "yyyy-mm-dd_hhmm") & "_" & objMail.ConversationTopic & ""
    VBA.MkDir (save_path)
    
    '保存邮件
    objMail.SaveAs save_path & objMail.ConversationTopic & ".msg"
    
    '保存附件
    If objMail.Attachments.Count > 0 Then
        For c = 1 To objMail.Attachments.Count
            Set objAtt = objMail.Attachments(c)
            objAtt.SaveAsFile save_path & objAtt.FileName
        Next
    End If
    
    Set objAtt = Nothing
    Set objMail = Nothing
    Set objNS = Nothing
End Sub

Sub save()

'    On Error Resume Next    '出现错误时下一句代码继续运行
'    Dim objItem As Outlook.MailItem
    Dim startTime
    Dim objItem
    Dim Attachment As Outlook.Attachment
    
    startTime = Now
    
    '遍历所有选中的项
    For Each objItem In Application.ActiveExplorer.Selection
    '如果选中的是邮件
        If objItem.Class = olMail Then
            Call SaveToNewFolder(objItem)
    '遍历邮件中的所有附件
    '        For Each Attachment In objItem.Attachments
    '            '将附件保存在c盘根目录下
    ''            Attachment.SaveAsFile "c:" & Attachment.FileName
    '        Next
        End If
    Next
    
    MsgBox "邮件已保存在指定位置，共用时 " & Format((Now - startTime) * 24 * 60 * 60, "0.0") & " 秒"
End Sub

1. 修改保存路径

   • 修改23行，save_path1 = "D:saveMail"为需要保存的路径。

2. 创建自动规则

   • 开始-规则-创建规则
     
     Image
   • 在选择条件步骤中，根据自己情况制定条件，我选择的是我的姓名在“收件人”或“抄送框”中，就是所有的邮件了。
   • 在选择操作步骤中，选择运行脚本，将脚本选择为Project1.SaveToNewFolder，确定，一直下一步，直至完成即可。