vba能否在outlook中实现这样的功能？

nickonline

请问各位高手，在outlook中用vba能否实现以下功能：

每个月自动在收件箱下建立一个目录，就用当前年月命名此文件夹，然后把当月收到的邮件自动移动到这个目录下？

我这有一台机器专门收邮件备份，想通过以上功能实现自动分类。

如果能实现，还请各位高手赐教一下给个code.

谢谢！！！！

magicqiang

关注

aaaaabbbbb

先做一半，你自己再思考一下。

Sub AddContactsFolder()
 Dim myOlApp As New Outlook.Application
 Dim myNameSpace As Outlook.NameSpace
 Dim myFolder As Outlook.Folder
 Dim myNewFolder As Outlook.Folder
 Dim MyMonth
 
 Set myNameSpace = myOlApp.GetNamespace("MAPI")
 Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
 MyMonth = Month(Date)
 Set myNewFolder = myFolder.folders.Add(MyMonth & "月份")
 
End Sub

有兴趣的朋友继续完成剩下的功能，我会加分滴！！！！

 

[此贴子已经被作者于2008-7-2 4:49:55编辑过]

hlightaaaa

aaaaabbbbb基本都作差不多了，最后几句我给添上。试了一下能运行。能给分吗？

Sub AddContactsFolder()
 Dim myOlApp As New Outlook.Application
 Dim myNameSpace As Outlook.NameSpace
 Dim myFolder 'As Outlook.Folder
 Dim myNewFolder 'As Outlook.Folder
 Dim MyMonth
 Dim myCopiedItem
 Dim mailtime
 
 On Error GoTo last
 
 Set myNameSpace = myOlApp.GetNamespace("MAPI")
 Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
 MyMonth = Month(Date)

Set myNewFolder = myFolder.Folders.Add(MyMonth & "月")

---------移动文件------------

For Each myItem In myFolder.Items
    mailtime = Month(myItem.ReceivedTime)
    If mailtime = MyMonth Then myItem.Copy.Move myNewFolder
Next
 
last:
 Set myNameSpace = Nothing
 Set myFolder = Nothing
 Set myCopiedItem = Nothing

End Sub

----------------------------------------------------------------------------------------------------------

感谢您的参与。我兑现承诺，楼主可以试试看。代码也可以增加对文件夹的判断，如已经有了8月份的就提示，不再重复创建。----aaaaabbbbb

-------------------------------------------------------------------------------------------------------------

[此贴子已经被aaaaabbbbb于2008-7-8 4:57:38编辑过]

zjg951025

强啊！
知道很强，只是没想到这么强！

cxzdd

太厉害了，而且这个很有用的说

xtpdcyga

如果有多个文件夹用下面的代码比较好
Sub AddContactsFolder()
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myFolder 'As Outlook.Folder
Dim myNewFolder 'As Outlook.Folder
Dim MyMonth
Dim myCopiedItem
Dim mailtime

On Error GoTo last

Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
MyMonth = Month(Date)
Set myNewFolder = myFolder.Folders.Add(MyMonth & "月")
For Each myItem In myFolder.Folders
    If myItem.Name <> myNewFolder.Name Then
       For Each myItemMail In myItem.Items
           mailtime = Month(myItemMail.ReceivedTime)
           If mailtime = MyMonth Then myItemMail.Copy.Move myNewFolder
       Next
    End If
Next
last:

Set myNameSpace = Nothing
Set myFolder = Nothing
Set myCopiedItem = Nothing

End Sub

jinzhong

谢谢分享，如想按年、月备份，改如何修改代码，我不懂VBA请大侠们赐教。

dell1400

太强大了，谢谢分享

dsd999

谢谢分享，顶起。