Send MAPI using alternate account.

I have an app that sends e-mails but needs to use different e-mail accounts for different e-mails.  I am currently using MAPI and have multiple accounts set up with the MAPI client.  Is there any way to specify which account is used when sending the e-mails?
MERCOMMSAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

dentabCommented:
how are you using MAPI?  
e.g. Outlook COM object, CDO, sockets

With CDO:
http://www.imt.net/~joe/matt/program/vb/Tutorials/Fun_With_Email/index.html

should help
0
David LeeCommented:
If you're using Outlook's object model and the accounts are all set up in Outlook, then this will do it.
Sub CreateNewMessage()
    Dim olkMessage As MailItem, _
        olkSendThroughBtn As Object, _
        olkSendAccount As Object
    Set olkMessage = Application.CreateItem(olMailItem)
    olkMessage.Display
    Set olkSendThroughBtn = Application.ActiveInspector.CommandBars("Standard").Controls(3)
    'Change (2) on the following line to the position in the list of accounts that this account occupies
    Set olkSendAccount = olkSendThroughBtn.Controls(2)
    olkSendAccount.Execute
    Set olkSendAccount = Nothing
    Set olkSendTrhoughBtn = Nothing
End Sub

Open in new window

0
MERCOMMSAuthor Commented:
Currently using MAPI session and MAPI Messages controls.
0
The Ultimate Tool Kit for Technolgy Solution Provi

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy for valuable how-to assets including sample agreements, checklists, flowcharts, and more!

dentabCommented:
You specify the sender when creating the session I think
http://msdn2.microsoft.com/en-us/library/aa227952(VS.60).aspx

Here is an example that uses it:
http://www.vb-helper.com/howto_excel_email_all_students.html
0
dentabCommented:
(you need the username & password)
0
MERCOMMSAuthor Commented:
0
dentabCommented:
No, sorry I diddn't see you mention Express.  Outlook Express does not use profiles, it must be Office Outlook.

It might be possible with a massive workaround...

I have a class that allows you to runAs.  Possibly, you could Compile a secondary EXE, which you could launch, running AS as specified username and password.  This would call the default profile for that user account.  This would require your main application to be an ActiveX executable so that the secondary exe could talk back to the first one.  This however seems a little overkill.

I assume that using Outlook is a license issue?
0
MERCOMMSAuthor Commented:
No.  Using Outlook is not an issue.  Working on that now.  But the solution in the previously mentioned question is not working.  Getting error "The Profile Name is not valid."

0
dentabCommented:
0
dentabCommented:
Does it need to be MAPI?

Its just I have made a class for sending via SMTP (without using CDO) that is much simpler.
0
MERCOMMSAuthor Commented:
dentab.

No the one at http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Controls/Q_21228945.html

Not married to MAPI.  The application just needs to send messages.  Some messages need to come from one account and others need to come from another account.  The messages need to be stored somewhere so that I can have documentation that they were sent.
0
dentabCommented:
Excellent, if the Exchange server has a pop interface then it may be easier this way.

My class needs the CSocket code from VBIP.com, it is available from here:
http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=69532&lngWId=1

My class code is in the code snippet below.  Let me know how you get on, or if you need some further explanation.
Private Declare Function GetTimeZoneInformation Lib "kernel32" (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long
 
Const TIME_ZONE_ID_INVALID = &HFFFFFFFF
Const TIME_ZONE_ID_UNKNOWN = &H0
Const TIME_ZONE_ID_STANDARD = &H1
Const TIME_ZONE_ID_DAYLIGHT = &H2
 
Private Type TIME_ZONE_INFORMATION
  Bias As Long
  StandardName(63) As Byte
  StandardDate(7) As Integer
  StandardBias As Long
  DaylightName(63) As Byte
  DaylightDate(7) As Integer
  DaylightBias As Long
End Type
 
Private propServer As String, propServerPort As String
Private propUsername As String, propPassword As String
Private propFrom As String, propTo As String
Private propCC As String, propBCC As String
Private propSubject As String, propBody As String
Private propErrors As String, propMailerApplication As String
 
Private WithEvents wSock As CSocket
Private strDataIn As String
Private Connect As Boolean
 
Private packetWait As Boolean
Private sendOK As Boolean
 
 
 
Private Function Floor(ByVal n As Double) As Double
  Dim a As Long
  a = CLng(n)
  If a > n Then a = a - 1
  Floor = a
End Function
 
 
Private Function getGlobalTime()
  Dim usrTZI As TIME_ZONE_INFORMATION
  Dim lngRetVal As Long, strGTime As String
  Dim thisDate As Date, strTemp As String
  Dim UTCbMin As Long, UTCbHours As Long
    
  thisDate = Now
  strGTime = Format(thisDate, "Ddd, dd Mmm HH:NN:SS")
  lngRetVal = GetTimeZoneInformation(usrTZI)
  
  UTCbMin = (usrTZI.Bias + usrTZI.DaylightBias) * -1
  
  If UTCbMin < 0 Then
    strGTime = strGTime & " -"
  Else
    strGTime = strGTime & " +"
  End If
  
  
  UTCbHours = Floor(UTCbMin / 60)
  UTCbMin = UTCbMin - (UTCbHours * 60)
  
  strTemp = CStr(UTCbHours)
  While Len(strTemp) < 2
    strTemp = "0" & strTemp
  Wend
  strGTime = strGTime & strTemp & ":"
  
  strTemp = CStr(UTCbMin)
  While Len(strTemp) < 2
    strTemp = "0" & strTemp
  Wend
  strGTime = strGTime & strTemp
 
  getGlobalTime = strGTime
End Function
 
Public Property Let Errors(ByVal vData As String)
    propErrors = vData
End Property
 
 
Public Property Get Errors() As String
    Errors = propErrors
End Property
 
Public Function send() As String
    Set wSock = New CSocket
    Dim strMessage As String
    Dim ccline As String
    Dim fromLine As String
    
    Dim SendList() As String
    Dim SendListCount As Long
    Dim strToAll As String
    Dim sLoop As Long
    Dim cPos As Long, strTemp As String
    Dim boolTemp As Boolean
    
    SendListCount = 0
    Connect = False
    propTo = Replace(propTo, ";", ",")
    propCC = Replace(propCC, ";", ",")
    propBCC = Replace(propBCC, ";", ",")
    
    strToAll = propTo & "," & propCC & "," & propBCC & ","
    ReDim SendList(Len(strToAll)) 'A row for each chars - way more than needed
    
    fromLine = propFrom
    cPos = InStr(fromLine, "<")
      If cPos > 0 Then
        fromLine = Mid(fromLine, cPos + 1)
        fromLine = Left(fromLine, InStr(fromLine & ">", ">") - 1)
      End If
    
    While strToAll <> ""
      cPos = InStr(strToAll, ",")
      strTemp = Trim(Left(strToAll, cPos - 1))
      strToAll = Mid(strToAll, cPos + 1)
      If strTemp <> "" Then
        cPos = InStr(strTemp, "<")
        If cPos > 0 Then
          strTemp = Mid(strTemp, cPos + 1)
          strTemp = Left(strTemp, InStr(strTemp & ">", ">") - 1)
        End If
       
        SendList(SendListCount) = strTemp
        SendListCount = SendListCount + 1
      End If
      'Stop
      
    Wend
    
    If (propServer = "") Or (propFrom = "") Or (propTo = "") Then
        send = "Please set AT LEAST Server/addressFrom/addressTo properties before calling..."
    Else
    
       'To and CC Is only for display purposes
       'multiple addresses seperate by comma
       'alias + email address should be presented as
       '                alias <email@domain.tld>
       
       If propCC = "" Then
         ccline = ""
       Else
         ccline = "CC: " & propCC & vbCrLf
       End If
        
        strMessage = "From: " & addressFrom & vbCrLf _
        & "To: " & propTo & vbCrLf _
        & ccline _
        & "Subject: " & Subject & vbCrLf _
        & "Date: " & getGlobalTime & vbCrLf _
        & "MIME-Version: 1.0" & vbCrLf _
        & "X-Mailer: " & """" & propMailerApplication & """" & vbCrLf _
        & "Content-Type: text/plain;" & vbCrLf _
        & vbTab & "charset=" & """" & "iso-8859-1" & """" & vbCrLf _
        & "Content-Transfer-Encoding: 7bit & vbCrLf" _
        & vbCrLf _
        & Body & vbCrLf _
        & vbCrLf & "." & vbCrLf
 
 
 
    wSock.RemoteHost = propServer
    wSock.RemotePort = propServerPort
    wSock.Protocol = sckTCPProtocol
    wSock.Connect
    
    
    If WaitForResponse("220") Then
        If Username <> "" Then
            sendPacket "USER " & Username
            sendPacket "PASSWORD " & Password
        End If
        If sendPacket("HELO " & Left(fromLine, InStr(1, fromLine & "@", "@") - 1) & vbCrLf, "250") Then
        'sendPacket "HELO " & Left(fromLine, InStr(1, fromLine & "@", "@") - 1) & vbCrLf, "250"
          If sendPacket("MAIL FROM: <" & fromLine & ">" & vbCrLf, "250") = False Then
            send = strDataIn
            GoTo DontSend
          End If
        
          boolTemp = False
          For sLoop = 0 To SendListCount - 1
            If sendPacket("RCPT TO: " & SendList(sLoop) & vbCrLf, "250") = True Then
              boolTemp = True
            End If
          Next sLoop
          
          If boolTemp = False Then
            If strDataIn = "" Then
              send = "No valid recipients"
            Else
              send = strDataIn
            End If
            GoTo DontSend
          End If
          
        
          If sendPacket("DATA" & vbCrLf, "354") = False Then
            send = strDataIn
            GoTo DontSend
          End If
          If sendPacket(strMessage, "250") = False Then
            send = strDataIn
            GoTo DontSend
          End If
  
          sendPacket "QUIT" & vbCrLf, "221"
        Else
          send = "Problem with server - did not accept ""HELO"""
        End If
    Else
        send = "Problem with server - did not detect 220 rfc response"
    End If
  End If
DontSend:
End Function
 
Private Function WaitForResponse(ByVal responseCode As String) As Boolean
    Dim wTime As Date, codeIn As String
    
    WaitForTransmissions
    packetWait = True
    wTime = DateAdd("s", 30, Now)
    WaitForResponse = False
    Do
      codeIn = Left(strDataIn, 3)
      Select Case codeIn
      Case responseCode
        Connect = True
        WaitForResponse = True
        Exit Do
      Case "500", "501", "554"
        Connect = False
        WaitForResponse = False
        Exit Do
      Case ""
        DoEvents
      Case Else
        DoEvents
      End Select
    Loop Until Now > wTime
    packetWait = False
    strDataIn = ""
End Function
 
Function WaitForTransmissions() As Boolean
  Dim timeOut As Date
  timeOut = DateAdd("S", 30, Now)
  DoEvents
  While packetWait And (Now < timeOut)
    DoEvents
  Wend
  WaitForTransmissions = Not packetWait
End Function
 
Private Function sendPacket(ByVal packateData As String, Optional ByVal reqResponseCode As String = "") As Boolean
  'This routine waits for all other transmissions to finish
  'Sends the data, and then waits again for transmissions to clear
  'This process should result with a single packet, containing the desired data
  WaitForTransmissions
  packetWait = True
  sendOK = False
  wSock.SendData packateData
  WaitForTransmissions
  If sendOK Then
    If reqResponseCode <> "" Then
      sendPacket = WaitForResponse(reqResponseCode)
    End If
  Else
    sendPacket = False
  End If
End Function
 
Public Property Let Body(ByVal vData As String)
    propBody = vData
End Property
 
 
Public Property Get Body() As String
    Body = propBody
End Property
 
 
 
Public Property Let Subject(ByVal vData As String)
    propSubject = vData
End Property
 
 
Public Property Get Subject() As String
    Subject = propSubject
End Property
 
 
 
Public Property Let addressTo(ByVal vData As String)
    propTo = vData
End Property
Public Property Get addressTo() As String
    addressTo = propTo
End Property
 
 
Public Property Let addressBCC(ByVal vData As String)
    propBCC = vData
End Property
Public Property Get addressBCC() As String
    addressBCC = propBCC
End Property
 
Public Property Let addressCC(ByVal vData As String)
    propCC = vData
End Property
Public Property Get addressCC() As String
    addressCC = propCC
End Property
 
 
Public Property Let addressFrom(ByVal vData As String)
    propFrom = vData
End Property
Public Property Get addressFrom() As String
    addressFrom = propFrom
End Property
 
 
 
Public Property Let Password(ByVal vData As String)
    propPassword = vData
End Property
 
 
Public Property Get Password() As String
    Password = propPassword
End Property
 
 
 
Public Property Let Username(ByVal vData As String)
    propUsername = vData
End Property
 
 
Public Property Get Username() As String
    Username = propUsername
End Property
 
 
 
Public Property Let Server(ByVal vData As String)
    propServer = vData
End Property
 
 
Public Property Get Server() As String
    Server = propServer
End Property
 
Public Property Let MailerApplication(ByVal vData As String)
    propMailerApplication = vData
End Property
 
 
Public Property Get MailerApplication() As String
    MailerApplication = propMailerApplication
End Property
 
 
Public Property Let ServerPort(ByVal vData As String)
    propServerPort = vData
End Property
 
 
Public Property Get ServerPort() As String
    ServerPort = propServerPort
End Property
 
 
Private Sub Class_Initialize()
  propServerPort = 25
  propMailerApplication = Replace(Trim(App.Title), " ", "_")
End Sub
 
Private Sub wSock_OnConnectionRequest(ByVal requestID As Long)
    wSock.CloseSocket '??
End Sub
 
Private Sub wSock_OnDataArrival(ByVal bytesTotal As Long)
    wSock.GetData strDataIn, vbString
'    Debug.Print strDataIn
End Sub
 
Private Sub wSock_OnError(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
  sendOK = False
  packetWait = False
  Errors = "Winsock error : " & Number & " " & Description
End Sub
 
Private Sub wSock_OnSendComplete()
  DoEvents
  sendOK = True
  packetWait = False
End Sub
 
Private Sub Class_Terminate()
    If wSock.State <> sckClosed Then wSock.CloseSocket
End Sub

Open in new window

0
MERCOMMSAuthor Commented:
Not using a local exchange server.  Using an internet POP/SMTP server.  Will that make a difference?
0
dentabCommented:
not really... unless it has to go via a proxy, I havent coded any kind of support for that.

Let me know how it goes.
0
MERCOMMSAuthor Commented:
dentab,

Looks like this will connect directly to the POP server and send message not using the local mail client at all.  Is that correct?
0
dentabCommented:
thats right...

If you want a local copy I would sugest adding the local sender as a CC, or you could log via a DB.
0
MERCOMMSAuthor Commented:
Think I have a solution.

Gonna try using AppActivate to activate the MAPI client then use SendKeys to change the default account.

Not pretty but I think that it will work.
0
dentabCommented:
yeuch...
but it would work.

The MAPI client being Outlook Express?  What happens if you runas a different user?
I could give you the code for that if it works...

Its late now anyway and my brain hurts... good luck!
0
MERCOMMSAuthor Commented:
I can do it as a RunAs but I think that the messages will just stack up in the outbox and never be sent until that user logs on.
0
dentabCommented:
really?

Well, try your solution.  Its not my favourite route to take but sometimes it's best.  Sorry I couldn't help more.
0
MERCOMMSAuthor Commented:
AppActivate and Send Keys is doing the trick.
0
Computer101Commented:
PAQed with points refunded (125)

Computer101
EE Admin
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Outlook

From novice to tech pro — start learning today.