邮件定时移动到公共文件夹

服务器的空间已经所剩无几了，只好把每天的传真邮件从邮箱里面移动到别的服务器上的公共文件夹。
考虑了很多方式无法访问传真账号的邮件，只能从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