Mapi Fowarding

I am trying to creat a small app that will Loop through my inbox in outlook and foward all messages to another address.  This is what I'm working with -
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" _
                                        (ByVal lpBuffer As String, nSize As Long) As Long

Private Sub main()
    Dim sUserName As String * 255
    Dim sRetName As String
    Dim lRetLen As Long
    Dim iLoc As Integer
    Dim sActUser As String
    Dim lRecipNum As Long
    Dim lLen As Long
    Dim lMsgCtr As Long
    Dim Mail1 As Object
    Dim Msg1 As Object
    Set Mail1 = New MAPISession
    Set Msg1 = New MAPIMessages
    On Error GoTo Eh
    If Mail1.SessionID <> 0 Then
        Exit Sub
    End If
    With Mail1
        'get user profile info
        sUserName = String(254, " ")
        sUserName = sUserName & vbNullChar
        lRetLen = GetUserName(sUserName, Len(sUserName))
        iLoc = InStr(sUserName, " ")
        sUserName = Left(sUserName, iLoc - 2)
        sActUser = Trim(sUserName)

        .NewSession = False
        .LogonUI = False
        .UserName = sActUser
        Msg1.SessionID = .SessionID
        For lMsgCtr = 0 To Msg1.MsgCount - 1
            Msg1.MsgIndex = lMsgCtr
            MsgBox Msg1.MsgType
            lRecipNum = Msg1.RecipCount
            Msg1.RecipIndex = lRecipNum
            Msg1.RecipType = 1
            Msg1.RecipAddress = "" 'email address
            Msg1.RecipDisplayName = Msg1.RecipAddress
            Msg1.Send (False)
        Next lMsgCtr

    End With

On Error GoTo 0
Exit Sub

    Select Case Err.Number
        Case Is = 32001
            Resume Next
        Case Is = 32050
            Resume Next
        Case Is = 32003
            On Error GoTo Eh
                    Mail1.UserName = ""
                    Mail1.NewSession = True
                    Mail1.LogonUI = True
            Resume Next
        Case Else
            MsgBox Err.Number & " Description: " & Err.Description
            Resume Next
    End Select
End Sub

- The code does attempt a send, but system always rejects it as undeliverable.  
This is the error I get in outlook for any address I try to foward to:

      '' on 04/07/2000 10:51 AM
            No transport provider was available for delivery to this recipient.

Anyone have any ideas?
Who is Participating?
hesConnect With a Mentor Commented:
Try changing the following:
Add Const vbExchange As String = "MS Exchange Settings"
Const vbMessageResolveName = 13

..UserName = sActUser   to
..UserName = vbExchange

and just before your send add

Msg1.AddressResolveUI = True

        Msg1.Action = vbMessageResolveName

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.