用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