用Outlook Exchange COM对象自动转发邮件

用Outlook Exchange COM对象自动转发邮件,然后使用windows定时任务每半个小时运行就可以实现邮件自动转发.

由于COM对象中可以得到邮件的所有数据(时间,收件人,发件人,标题,内容等),所以更高级的功能是还可以对转发的邮件进行过滤,类似于Outlook中的Rule,但用COM对象肯定更加灵活,同时转发的内容,标题等也可以按自己的规则修改. 需要注意的是Outlook的安全设置得修改一下:Programmatic Access设置为不弹出警告窗口.

具体代码如下(此代码也可以转为VBS脚本):

Option Explicit

Sub Main()
Dim strKey As String

strKey = Trim(Command) ;得到命令行参数也就是要转发的邮箱地址.
If Len(strKey) = 0 Then Exit Sub
If InStr(strKey, "@") = 0 Then Exit Sub
If InStr(strKey, ".") = 0 Then Exit Sub

Dim myApp As Object, tmpRule As Object
Set myApp = GetObject(, "Outlook.Application")

On Error Resume Next
If myApp Is Nothing Then
Set myApp = CreateObject("Outlook.Application")
End If

If Not myApp Is Nothing Then

myApp.Session.Logon , , True, False

Dim myOlItems As Object, Item As Object
Dim i As Integer, j As Integer
Dim tmpLogFile As Object, tmpObj As Object
Dim strPath As String

strPath = App.Path
If Right(strPath, 1) <> "/" Then strPath = strPath & "/"

Set tmpObj = CreateObject("Scripting.FileSystemObject")

If tmpObj.FileExists(strPath & "AutoFWEmail.log") Then
Set tmpLogFile = tmpObj.OpenTextFile(strPath & "AutoFWEmail.log", 8)
Else
Set tmpLogFile = tmpObj.CreateTextFile(strPath & "AutoFWEmail.log")
End If

tmpLogFile.WriteLine Now & " Auto FW Email Run..."

'收件箱:myApp.Session.GetDefaultFolder(6).Folders
'收件箱子文件夹:myApp.Session.GetDefaultFolder(6).Folders.Count

'得到收件箱中所有邮件(不包括子文件夹,如果要检查子文件夹用:myApp.Session.GetDefaultFolder(6).Folders(1..x).Items )
Set myOlItems = myApp.Session.GetDefaultFolder(6).Items
For i = myOlItems.Count To 1 Step -1

'只转发未读的
If myOlItems.Item(i).UnRead Then
Set Item = myOlItems.Item(i)
Set Item = Item.Forward

'转发邮件
Item.To = strKey

'邮件标题FW前加上AUTO-,结果就是'AUTO-FW:'开头
If Left(Item.Subject, "2") = "FW" Then
Item.Subject = "AUTO-" & Item.Subject
End If

'对邮件内容修改,删除转发邮件中的签名等信息,直接从邮件的From开始.
If (InStr(Item.body, "From:") > 0) Then
'Item.body = Replace(Space(40), " ", "_") & vbCrLf & Mid(Item.body, InStr(Item.body, "From:"))
Item.body = Mid(Item.body, InStr(Item.body, "From:"))
End If

'转发
Item.Send
j = j + 1

'标记已读
myOlItems.Item(i).UnRead = False
End If
DoEvents

'发送50个邮件或检查1000个邮件退出
If j > 50 Or Abs(myOlItems.Count - i) > 1000 Then
Exit For
End If
Next

'AutoFW Rule 这里是定时运行一个Outlook的一个Rule,把自动转发的邮件放到AutoFW文件夹中.
Set tmpRule = myApp.Session.DefaultStore.GetRules()
For i = 1 To tmpRule.Count
If tmpRule.Item(i).Name = "AutoFW" Then
tmpRule.Item(i).Execute False, myApp.Session.GetDefaultFolder(5)
Exit For
End If
Next

'写转发日志
tmpLogFile.WriteLine Now & " Auto FW Email End : " & j & " of " & myOlItems.Count

End If

End Sub