用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