?
Solved

Send MAPI using alternate account.

Posted on 2008-01-28
23
Medium Priority
?
1,031 Views
Last Modified: 2012-05-05
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?
0
Comment
Question by:MERCOMMS
22 Comments
 
LVL 5

Expert Comment

by:dentab
ID: 20765992
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
 
LVL 76

Expert Comment

by:David Lee
ID: 20766534
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
 

Author Comment

by:MERCOMMS
ID: 20768013
Currently using MAPI session and MAPI Messages controls.
0
The new generation of project management tools

With monday.com’s project management tool, you can see what everyone on your team is working in a single glance. Its intuitive dashboards are customizable, so you can create systems that work for you.

 
LVL 5

Expert Comment

by:dentab
ID: 20768123
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
 
LVL 5

Expert Comment

by:dentab
ID: 20768129
(you need the username & password)
0
 

Author Comment

by:MERCOMMS
ID: 20866783
0
 
LVL 5

Expert Comment

by:dentab
ID: 20867500
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
 

Author Comment

by:MERCOMMS
ID: 20867614
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
 
LVL 5

Expert Comment

by:dentab
ID: 20867632
0
 
LVL 5

Expert Comment

by:dentab
ID: 20867659
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
 

Author Comment

by:MERCOMMS
ID: 20867819
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
 
LVL 5

Expert Comment

by:dentab
ID: 20867907
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
 

Author Comment

by:MERCOMMS
ID: 20868014
Not using a local exchange server.  Using an internet POP/SMTP server.  Will that make a difference?
0
 
LVL 5

Expert Comment

by:dentab
ID: 20870384
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
 

Author Comment

by:MERCOMMS
ID: 20975594
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
 
LVL 5

Expert Comment

by:dentab
ID: 20976641
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
 

Author Comment

by:MERCOMMS
ID: 20976857
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
 
LVL 5

Expert Comment

by:dentab
ID: 20981041
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
 

Author Comment

by:MERCOMMS
ID: 20989107
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
 
LVL 5

Expert Comment

by:dentab
ID: 20992318
really?

Well, try your solution.  Its not my favourite route to take but sometimes it's best.  Sorry I couldn't help more.
0
 

Author Comment

by:MERCOMMS
ID: 21253884
AppActivate and Send Keys is doing the trick.
0
 
LVL 1

Accepted Solution

by:
Computer101 earned 0 total points
ID: 22535502
PAQed with points refunded (125)

Computer101
EE Admin
0

Featured Post

Get expert help—faster!

Need expert help—fast? Use the Help Bell for personalized assistance getting answers to your important questions.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Are you looking for the options available for exporting EDB files to PST? You may be confused as they are different in different Exchange versions. Here, I will discuss some options available.
Office 365 has multiple features and services which are specially designed to help businesses to reduce their dependence on on-premises IT resources. It also offers great flexibility and enhanced security. But like any other data, Office 365 mailbo…
To add imagery to an HTML email signature, you have two options available to you. You can either add a logo/image by embedding it directly into the signature or hosting it externally and linking to it. The vast majority of email clients display l…
Is your OST file inaccessible, Need to transfer OST file from one computer to another? Want to convert OST file to PST? If the answer to any of the above question is yes, then look no further. With the help of Stellar OST to PST Converter, you can e…
Suggested Courses

593 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question