考虑了很多方式无法访问传真账号的邮件,只能从Outlook中登陆后访问。2种方法可以移动邮件,1、使用规则,但是没有办法做到自动改变时间。2、vba程序,但是无法自动启动。
不过还是vba可以由点希望。
大概思路:
1、使用vba监测邮件的时间,一个月内的邮件保留,其他的作出动作,转移到公共文件夹,做好计数,然后发出日志邮件,最后退出。
2、如果是vba必须是进入outlook之后才能够启动的。那么需要做一个自动启动outlook和启动outlook后立即触发vba程序的2个启动程序。因此,使用一个计划任务,定时启动outlook。然后再applation starup 的session事件中启动vba的过程,这样便可以定时启动outlook的vba勒。
3、最后不要忽略一点再applation starup 的session事件一定要检测当前时间时候与计划任务的启动时间相符,否则每次人工启动的时候也会进行vba的任务的。考虑到实际情况,可能机器运行计划任务的时候会很慢,那么当启动applation starup 的session事件的时候的时间不是里面检测的时间,vba也就不会启动,因此应该在时间检测的时候给定一个时间范围而不是一个时间点。
Sub movefax() Dim emaildate As Date mytime = DateAdd("m", -1, Date) i = 0 Set myOlApp = CreateObject("Outlook.Application") Set myNameSpace = myOlApp.GetNamespace("MAPI") Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox) Set myItems = myInbox.Items Set faxbox = myNameSpace.GetDefaultFolder(olPublicFoldersAllPublicFolders) Set myDestFolder = faxbox.Folders("Fax Tianjin") Set myItem = myItems.Find("[SenderName] = 'The HylaFAX Receive Agent'") While TypeName(myItem) <> "Nothing" thistime = myItem.SentOn emaildate = DateValue(Year(thistime) & "-" & Month(thistime) & "-" & Day(thistime)) If emaildate < mytime Or emaildate = mytime Then i = i + 1 myItem.Move myDestFolder End If Set myItem = myItems.FindNext Wend Dim myMail As Outlook.MailItem Set myMail = Application.CreateItem(olMailItem) With myMail .To = "it@fax.cn" .Subject = "TJ Fax Move" .Body = i & " Items have been moved" End With myMail.Send End Sub Private Sub Application_Startup() thistime = Time Dim runtime1 As Date Dim runtime2 As Date runtime1 = "01:09:00" runtime2 = "01:11:00" If thistime > runtime1 And thistime < runtime2 Then Call movefax Me.Quit End If End Sub
取得邮件的另一种办法:
For i = 1 To myItems.Count Set myItem = myItems(i) thistime = myItem.CreationTime emaildate = DateValue(Year(thistime) & "-" & Month(thistime) & "-" & Day(thistime)) If emaildate < mytime Or emaildate = mytime Then m = m + 1 mysub = myItem.Subject myItem.Delete 'myItem.UnRead = False 'Debug.Print i & ":" & emaildate & "Deleted" Else k = k + 1 'Debug.Print k & ":------" & myItem.Subject End If Set myItem = myItems.GetNext Next