|
功能：自动清除收件箱和已删除邮件中15天以前收到的邮件。遇到问题如下：
1。收件箱中含有邮件回执，（即OUTLOOK自动回复的邮件）则Set objMailItem = objMAPIFolder.Items(J)时会出错，这里只能用一个错误处理程序。请问，如何判断邮件是回执？
2。收件箱中没有邮件时，速度很慢！（断点发现程序执行End Sub一句时要等几十秒)该段代码有错吗？有其它办法可以优化吗？
代码如下：
Private Sub DelInbox()
Dim objApp As Outlook.Application
Dim objNameSpace As Outlook.NameSpace
Dim objMAPIFolder As Outlook.MAPIFolder
Dim objMailItem As Outlook.MailItem
Dim MailCounter As Integer
Dim totalNumber As Integer
Dim thisDay As Date, sTemp As String, sTemp2 As String
On Error GoTo err1
thisDay = CDate(Now) - 15 '清除接收时间在15天以前的邮件
Set objApp = New Outlook.Application
Set objNameSpace = objApp.GetNamespace(Type:="MAPI")
Set objMAPIFolder = objNameSpace.GetDefaultFolder(FolderType:=olFolderInbox)
Open "d:\mail\delmaillist.txt" For Output As #1
sTemp = Date & "/" & Time & "系统自动删除了接收时间在:[" & thisDay & "]以前的邮件!"
Print #1, sTemp
Print #1, "[第/共]/接收时间/发件人/主 题"
Print #1, "========================================="
totalNumber = objMAPIFolder.Items.Count
Dim I As Integer, J As Integer '因为每次删除邮件时, objMAPIFolder.Items的序号自动为1所以用了I,J两个变量!
J = 1
If totalNumber >= 1 Then
For I = 1 To totalNumber ' 清除收件箱中邮件!
' DoEvents
Set objMailItem = objMAPIFolder.Items(J)
If objMailItem.ReceivedTime <= thisDay And objMailItem.UnRead = False Then
sTemp = "[" & I & "/" & totalNumber & "]/" & objMailItem.ReceivedTime & "/" & objMailItem.SenderName & "/" & objMailItem.Subject
Print #1, sTemp
sTemp = "正在删除[收件箱]中邮件(" & "接收日期为:[" & thisDay & "]前的邮件!)...[第" & I & "封/共" & totalNumber & "封] "
lblStatus.Caption = sTemp
objMailItem.Close olDiscard
MailCounter = MailCounter + 1
objMailItem.Delete
Else
J = J + 1
lblStatus.Caption = "正在处理" & J & "接收日期为:[" & thisDay & "]前的邮件..."
End If
Next
End If
sTemp = "[收件箱]中:共删除了" & MailCounter & "封邮件!"
Print #1, sTemp
Print #1, "========================================="
'************************************************************************
MailCounter = 0
Set objMAPIFolder = objNameSpace.GetDefaultFolder(FolderType:=olFolderDeletedItems)
totalNumber = objMAPIFolder.Items.Count
J = 1
If totalNumber >= 1 Then
For I = 1 To totalNumber ' 清除已删除邮件中邮件!
' DoEvents
Set objMailItem = objMAPIFolder.Items(J)
If objMailItem.ReceivedTime <= thisDay And objMailItem.UnRead = False Then
sTemp2 = "[" & I & "/" & totalNumber & "]/" & objMailItem.ReceivedTime & "/" & objMailItem.SenderName & "/" & objMailItem.Subject
Print #1, sTemp2
sTemp2 = "正在删除[已删除邮件]中邮件(" & "接收日期为:[" & thisDay & "]前的邮件!)...[第" & I & "封/共" & totalNumber & "封] "
lblStatus.Caption = sTemp2
objMailItem.Close olDiscard
MailCounter = MailCounter + 1
objMailItem.Delete
Else
J = J + 1
lblStatus.Caption = "正在处理" & J & "接收日期为:[" & thisDay & "]前的邮件..."
End If
Next
End If
sTemp2 = "[已删除邮件]中:共删除了" & MailCounter & "封邮件!"
Print #1, sTemp2
Print #1, "========================================="
Close #1
'************************************************************************
lblStatus.Caption = sTemp & sTemp2
objApp.Quit
Set objMailItem = Nothing
Set objMAPIFolder = Nothing
Set objNameSpace = Nothing
Set objApp = Nothing
lblStatus_DblClick
On Error GoTo 0
Exit Sub
err1:
If Err.Number = 13 Then J = J + 1: Resume
Resume Next
End Sub
7dZ1M9sO.rar
(24.19 KB, 下载次数: 87)
| 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2004-7-11 16:19
