自动保存新邮件内容及附件到本地文件夹

haishu79

新手，目的:接到一份新邮件自动保存到d盘邮件备份目录 下，按日期+邮件标题 保存 为msg或者 正文保存为 doc文件，附件也存出来
根据网上的例子改的，可是不行

Sub 邮件保存测试1(Item As Outlook.MailItem)
On Error Resume Next
    Dim oFso
    Set oFso = CreateObject("Scripting.FileSystemObject")
    Dim a, b  As String
a = Format(Date, "yyyy年m月d日")   '当前年月日
Dim P As String
P = "Y:\邮件\邮件备份\" & a
    oFso.CreateFolder (P)

MsgBox P


'On Error Resume Next
On Error GoTo EE:
Dim myOlApp As Outlook.Application
Dim myNameSpace As NameSpace
Dim myibox As MAPIFolder
Dim mydelitems As MAPIFolder
Dim olItem As Outlook.MailItem
Dim strname As String
Dim Strname2 As String
Dim Mdir As String
'Dim P As String
P = P & "\"
MsgBox P



Dim objItem As Outlook.MailItem
Dim Attachment As Outlook.Attachment
Dim myitem As MailItem

Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myibox = myNameSpace.GetDefaultFolder(olFolderInbox)





           strname = objItem.Subject '主题名字
           Strname2 = CDate(Format$(objItem.SentOn, "yyyy-mm-dd")) '.ReceivedTime 收件时间
           strname = Replace(strname, "*", "_")
           strname = Replace(strname, "\", "_")
           strname = Replace(strname, "/", "_")
           strname = Replace(strname, "$", "_")
           strname = Replace(strname, "%", "_")
           strname = Replace(strname, "!", "_")
           strname = Replace(strname, "~", "_")
           strname = Replace(strname, "(", "_")
           strname = Replace(strname, ")", "_")
           strname = Replace(strname, "+", "_")
           strname = Replace(strname, ":", "_")
           strname = Replace(strname, ".", "_")

           Strname2 = Replace(Strname2, "\", "-")
           Strname2 = Replace(Strname2, "/", "-")
           Strname2 = Replace(Strname2, ":", "-")
           Strname2 = Strname2 & " "

             Dim sr
              sr = Dir(P & Strname2 & strname, vbDirectory)
            If sr = "" Then
                MkDir (P & Strname2 & strname)
            Else
             ' re = MsgBox("已经有同名的文件夹,邮件将保存到该文件平内", vbOKCancel)
             If re = 2 Then Exit Sub
            End If

        objItem.SaveAs P & Strname2 & strname & "\" & strname & ".doc", olDoc
'遍历邮件中的所有附件
    For Each Attachment In objItem.Attachments
            '将附件保存在目录下
        Attachment.SaveAsFile P & Strname2 & strname & "\" & Attachment.FileName
    Next



EE:
If Err.Number = 75 Then
MsgBox Err.Number
'MsgBox "已经有同名的文件夹,邮件将保存到该文件平内"
'On Error Resume Next
End If
MsgBox "邮件已备份完毕"
End Sub
实现效果如下图：

自动保存邮件

求大神帮帮，谢谢

haishu79

新手，求一个可用源码，谢谢

闻启学

这个利用事件来触发 方便

haishu79

我是利用规则收到"张三"的邮件就保存到本地，需保存正文及附件

dwchung

这是outlook里用的VBA代码，在excel里是没有Outlook.MailItem这个类型的