none
VBA Script for automatic foward message for more than one address mail located in the message body RRS feed

  • Question

  • Hi Everione, I'd one vba script for foward automaticaly all messages received for the mail adress located in the message body, but with that I'm just able to foward for the first mail adress and some messages have more than one adress.

    So does somebody can help me to improme the script below?

    Regards

    The body message is like:

    Customer Email ID:

    address1@mailserver.com

    address2@mailserver.com

    address3@mailserver.com

    

    Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    End Sub
    Private Sub Application_NewMail()
    Dim olOutMail As Outlook.MailItem
    Dim vText As Variant
    Dim sText As String
    Dim vAddr As Variant
    Dim sAddr As String
    Dim i As Long
    Set objOutlook = CreateObject("Outlook.Application")
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    Set objInbox = objNamespace.GetDefaultFolder(olFolderInbox)
    Set colItems = objInbox.Items
    For Each objItem In colItems
    sText = objItem.Body
    vText = Split(sText, Chr(13))
    For i = 1 To UBound(vText)
    If InStr(1, vText(i), "@") Then
    sAddr = vText(i)
    Exit For
    End If
    Next i
    If InStr(1, sAddr, "HYPERLINK") Then
    vText = Split(sAddr, Chr(34))
    For i = 1 To UBound(vText)
    If InStr(1, vText(i), "@") Then
    sAddr = vText(i)
    Exit For
    End If
    Next i
    End If
    sAddr = Replace(sAddr, "mailto:", "")
    Set olOutMail = objItem.Forward
    With olOutMail
    .To = sAddr
    .HTMLBody = "Customized Message" & vbCr & .HTMLBody
    .Send 'Change to .Send after testing'
    End With
    objItem.UnRead = False
    objItem.Delete
    Next objItem
    Set objItem = Nothing
    Set olOutMail = Nothing
    End Sub

    Wednesday, September 11, 2013 9:17 PM

Answers

  • Hi Marassa,

    Do you want to forward email to all mail addresses while receiving an email?

    If so, please look at code below, I have improved your code and it works fine.

    Private Sub Application_NewMail()
        Dim olOutMail As Outlook.MailItem
        Dim vText As Variant
        Dim sText As String
        Dim vAddr As Variant
        Dim sAddr As String
        Dim i As Long
        Set objInbox = Application.ActiveExplorer.Selection
        For Each objItem In objInbox
            sText = objItem.Body
            vText = Split(sText, Chr(13))
            For i = 1 To UBound(vText)
                If InStr(1, vText(i), "@") Then
                    vText(i) = Left(vText(i), InStr(vText(i), "<mailto:") - 1)
                    sAddr = sAddr & vText(i) & ";"
                End If
            Next i
            Set olOutMail = objItem.Forward
            With olOutMail
            .To = sAddr
            .HTMLBody = "Customized Message" & vbCr & .HTMLBody
            .Send 'Change to .Send after testing'
            End With
            objItem.UnRead = False
            objItem.Delete
        Next objItem
        Set objItem = Nothing
    End Sub

    And the result (See the figure below):


    <THE CONTENT IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, WHETHER EXPRESS OR IMPLIED>
    Thanks
    MSDN Community Support

    Please remember to "Mark as Answer" the responses that resolved your issue. It is a common way to recognize those who have helped you, and makes it easier for other visitors to find the resolution later.

    Sunday, September 15, 2013 3:15 PM
    Moderator