Microsoft KB Archive/171422

Knowledge Base

How to use CDO 1.21 to log on to a MAPI session by using the default profile of the current user

Article ID: 171422

Article Last Modified on 9/8/2005

---

APPLIES TO

• Microsoft Collaboration Data Objects 1.21

---

This article was previously published under Q171422

SUMMARY

In order to send mail using CDO (1.x), you need to establish and logon to a session. Logging onto a session requires that you provide a profile name. If you do not programmatically provide a profile you receive a dialog box asking the user to choose a profile.

This article describes how to logon to a CDO (1.1, 1.2, 1.21) session by using the default profile of the current user.

MORE INFORMATION

There are two ways to logon to a CDO (1.1, 1.2, 1.21) session using the current user's default profile:

1. If the user has a session running (for example, they have an Outlook client running), executing the following line of code will hook the already instantiated session using the profile they are currently logged on with:

         objSession.Logon ShowDialog:=False, NewSession:=False
                           

   Where "objSession" has been created as a MAPI.Session.

2. If the user does not have a session running, you need to find the default profile in the registry.

Since finding the default profile in the registry requires a fair amount of code, it makes sense to attempt to logon assuming that the user has a session running. Then, if the user did not have a session running, a trappable error results. You can then place the code for finding the default profile in the error handler.

1. Start a new Standard EXE Visual Basic Project.
2. Add a module.
3. Add a reference to the CDO library installed on your system. The file will be Olemsg32.dll, or CDO.DLL, and be either version 1.1, 1.2, or 1.21.

4. Copy and paste the following code to the General Declaration section of your Form (not Module):

         Private Sub Form_Load()
            Dim objOutBox As Folder
            Dim objNewMessage As Message
            Dim objRecipients As Recipients
            Dim objOneRecip As Recipient
   
            StartMessagingAndLogon
            Set objOutBox = objSession.Outbox
            Set objNewMessage = objOutBox.Messages.Add
            Set objRecipients = objNewMessage.Recipients
            Set objOneRecip = objRecipients.Add
            With objOneRecip
               'Fill in an appropriate alias here
               .Name = "MyName"
               .Type = CdoTo
               .Resolve ' get MAPI to determine complete e-mail address
            End With
            With objNewMessage
               .Subject = "Test CDO Message"
               .Text = "Text of CDO Message"
               .Send
            End With
         End Sub
   
         Sub StartMessagingAndLogon()
            Dim sKeyName As String
            Dim sValueName As String
            Dim sDefaultUserProfile As String
            Dim osinfo As OSVERSIONINFO
            Dim retvalue As Integer
   
            On Error GoTo ErrorHandler
            Set objSession = CreateObject("MAPI.Session")
   
            'Try to logon.  If it fails, the most likely reason is that you do
            'not have an open session.  Error -2147221231  MAPI_E_LOGON_FAILED 
            'will return.  Trap the error in the ErrorHandler 
            objSession.Logon ShowDialog:=False, NewSession:=False
            Exit Sub
         ErrorHandler:
            Select Case Err.Number
               Case -2147221231  'MAPI_E_LOGON_FAILED
                  'Need to find out what OS is in use, the keys are different
                  'for WinNT and Win95.
                  osinfo.dwOSVersionInfoSize = 148
                  osinfo.szCSDVersion = Space$(128)
                  retvalue = GetVersionEx(osinfo)
                  Select Case osinfo.dwPlatformId
                     Case 0   'Unidentified
                        MsgBox "Unidentified Operating System.  " & _
                           "Can't log onto messaging."
                        Exit Sub
                     Case 1   'Win95
                        sKeyName = "Software\Microsoft\" & _
                                   "Windows Messaging " & _
                                   "Subsystem\Profiles"
   
                     Case 2   'NT
                         sKeyName = "Software\Microsoft\Windows NT\" & _
                                    "CurrentVersion\" & _
                                    "Windows Messaging Subsystem\Profiles"
                  End Select
   
                  sValueName = "DefaultProfile"
                  sDefaultUserProfile = QueryValue(sKeyName, sValueName)
                  objSession.Logon ProfileName:=sDefaultUserProfile, _
                                   ShowDialog:=False
                  Exit Sub
               Case Else
                  MsgBox "An error has occured while attempting" & Chr(10) & _
                  "To create and logon to a new CDO (1.x) session." & _
                  Chr(10) & "Please report the following error to your " & _
                  "System Administrator." &  Chr(10) & Chr(10) & _
                  "Error Location: frmMain.StartMessagingAndLogon" & _
                  Chr(10) & "Error Number: " & Err.Number & Chr(10) & _
                  "Description: " & Err.Description
            End Select
         End Sub
                       

5. Copy and paste the following code to your Module (not Form):

         Public objSession As MAPI.Session
         Public objNewMessage As Message
   
         Public Type OSVERSIONINFO
            dwOSVersionInfoSize As Long
            dwMajorVersion As Long
            dwMinorVersion As Long
            dwBuildNumber As Long
            dwPlatformId As Long
            szCSDVersion As String * 128
         End Type
   
         Global Const REG_SZ As Long = 1
         Global Const REG_DWORD As Long = 4
         Global Const HKEY_CURRENT_USER = &H80000001
         Global Const ERROR_NONE = 0
         Global Const ERROR_BADDB = 1
         Global Const ERROR_BADKEY = 2
         Global Const ERROR_CANTOPEN = 3
         Global Const ERROR_CANTREAD = 4
         Global Const ERROR_CANTWRITE = 5
         Global Const ERROR_OUTOFMEMORY = 6
         Global Const ERROR_INVALID_PARAMETER = 7
         Global Const ERROR_ACCESS_DENIED = 8
         Global Const ERROR_INVALID_PARAMETERS = 87
         Global Const ERROR_NO_MORE_ITEMS = 259
   
         Global Const KEY_ALL_ACCESS = &H3F
   
         Global Const REG_OPTION_NON_VOLATILE = 0
   
         Declare Function GetVersionEx Lib "kernel32" _
            Alias "GetVersionExA" _
                  (ByRef lpVersionInformation As OSVERSIONINFO) As Long
   
   
         Public Declare Function RegCloseKey Lib "advapi32.dll" _
                  (ByVal hKey As Long) As Long
   
         Public Declare Function RegOpenKeyEx Lib "advapi32.dll" _
            Alias "RegOpenKeyExA" _
                  (ByVal hKey As Long, _
                  ByVal lpSubKey As String, _
                  ByVal ulOptions As Long, _
                  ByVal samDesired As Long, _
                  phkResult As Long) As Long
   
         Public Declare Function RegQueryValueExString Lib "advapi32.dll" _
            Alias "RegQueryValueExA" _
                  (ByVal hKey As Long, _
                  ByVal lpValueName As String, _
                  ByVal lpReserved As Long, _
                  lpType As Long, _
                  ByVal lpData As String, _
                  lpcbData As Long) As Long
   
         Public Declare Function RegQueryValueExLong Lib "advapi32.dll" _
            Alias "RegQueryValueExA" _
                  (ByVal hKey As Long, _
                  ByVal lpValueName As String, _
                  ByVal lpReserved As Long, _
                  lpType As Long, lpData As Long, _
                  lpcbData As Long) As Long
   
         Public Declare Function RegQueryValueExNULL Lib "advapi32.dll" _
            Alias "RegQueryValueExA" _
                  (ByVal hKey As Long, _
                  ByVal lpValueName As String, _
                  ByVal lpReserved As Long, _
                  lpType As Long, _
                  ByVal lpData As Long, _
                  lpcbData As Long) As Long
   
   
         Public Function QueryValue _
                  (sKeyName As String, _
                  sValueName As String)
   
         Dim lRetVal As Long     'result of the API functions
         Dim hKey As Long        'handle of opened key
         Dim vValue As Variant   'setting of queried value
   
         lRetVal = RegOpenKeyEx(HKEY_CURRENT_USER, _
                              sKeyName, _
                              0, _
                              KEY_ALL_ACCESS, _
                              hKey)
   
         lRetVal = QueryValueEx(hKey, _
                              sValueName, _
                              vValue)
         QueryValue = vValue
         RegCloseKey (hKey)
   
         End Function
         Function QueryValueEx _
               (ByVal lhKey As Long, _
               ByVal szValueName As String, _
               vValue As Variant) As Long
   
            Dim cch As Long
            Dim lrc As Long
            Dim lType As Long
            Dim lValue As Long
            Dim sValue As String
   
            On Error GoTo QueryValueExError
   
            ' Determine the size and type of data to be read
            lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
            If lrc <> ERROR_NONE Then Error 5
   
            Select Case lType
               ' For strings
               Case REG_SZ:
                  sValue = String(cch, 0)
                  lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, _
                     sValue, cch)
                  If lrc = ERROR_NONE Then
                     vValue = Left$(sValue, cch)
                  Else
                     vValue = Empty
                  End If
               ' For DWORDS
               Case REG_DWORD:
                  lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, _
                     lValue, cch)
                  If lrc = ERROR_NONE Then vValue = lValue
               Case Else
                  'all other data types not supported
                  lrc = -1
            End Select
   
         QueryValueExExit:
            QueryValueEx = lrc
            Exit Function
         QueryValueExError:
            Resume QueryValueExExit
         End Function
                       

6. Run the project. You will send mail to the "Recipient" that you entered in Form_Load.

REFERENCES

For more information about how to obtain the CDO (1.x) Libraries, click the following article number to view the article in the Microsoft Knowledge Base:

171440 Where to acquire the CDO Libraries (all versions)

Keywords: kbhowto kbmsg kbfaq KB171422

---

Send feedback to Microsoft

© Microsoft Corporation. All rights reserved.