Visual Basic Registry Routines
RegQueryValueEx: Retrieve Email Account Info (Outlook)
     
Posted:   Sunday March 06, 2005
Updated:   Monday December 26, 2011
     
Applies to:   VB4-32, VB5, VB6
Developed with:   VB6, Windows XP
OS restrictions:   None
Author:   VBnet - Randy Birch
     

Related:  

RegQueryValueEx: Retrieve Email Account Info (Outlook)
RegEnumKeyEx: POP3, SMTP, NNTP and LDAP Account Info (Outlook Express)

Retrieving the User's Default Email Address (Outlook Express)
RegQueryValueEx: Determine the User's Default Mail Client
     
 Prerequisites
None.

This

Unfortunately, Outlook stores account information in a different location than Outlook Express and other applications using the registry's \Internet Account Manager key.

For POP3 and SMTP accounts under Outlook 2003 on the Windows XP platform, account info resides under a key called \9375CFF0413111d3B88A00104B2A6676 residing under the primary key Software\ Microsoft\ Windows NT\ CurrentVersion\ Windows Messaging Subsystem\ Profiles. 

Note: This code has not been tested against earlier versions of Outlook, nor with Outlook on other Windows versions. Therefore if you find this code works (or doesn't) on a specific configuration I'd appreciate your dropping me a line.

If you're targeting systems using Outlook Express, see RegEnumKeyEx: POP3, SMTP, NNTP and LDAP Account Info (Outlook Express).  

 BAS Module Code
None.

 Form Code
Add a command button (Command1), two text boxes (Text1, Text2), and a list box (List1) to a form, along with the following code:

Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright 1996-2011 VBnet/Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
'               applications, but you may not reproduce 
'               or publish this code on any web site,
'               online service, or distribute as source 
'               on any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const HKEY_CURRENT_USER = &H80000001

Private Const OUTLOOK_PROFILE_PATH_NT As String = _
    "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles"

Private Const OUTLOOK_ACCOUNT_NAMES_NT As String = _
    "9375CFF0413111d3B88A00104B2A6676"

Private Const ERROR_MORE_DATA = 234
Private Const ERROR_SUCCESS As Long = 0
Private Const LB_SETTABSTOPS As Long = &H192
Private Const STANDARD_RIGHTS_READ As Long = &H20000
Private Const KEY_QUERY_VALUE As Long = &H1
Private Const KEY_ENUMERATE_SUB_KEYS As Long = &H8
Private Const KEY_NOTIFY As Long = &H10
Private Const SYNCHRONIZE As Long = &H100000
Private Const KEY_READ As Long = ((STANDARD_RIGHTS_READ Or _
                                   KEY_QUERY_VALUE Or _
                                   KEY_ENUMERATE_SUB_KEYS Or _
                                   KEY_NOTIFY) And _
                                   (Not SYNCHRONIZE))
                                   
'type holding data queried
Private Type REG_OUTLOOKACCOUNT_INFO

  'account info; most for email accounts
   OlAccountName As String
   OlDisplayName As String
   OlEmail As String
   OlSignature As String
   OlOrganization As String
   OlPop3Password As String
   OlPop3Server As String
   OlPop3User As String
   OlReplyEmail As String
   OlReplyForwardSignature As String
   OlSmtpServer As String
   OlSmtpServerUsesAuthentication As Long
   
  'other info, primarily for system settings
   OlRegistryName As String
   OlClsid As String
   OlAccountType As String
   OlServiceName As String

End Type

Private Type FILETIME
   dwLowDateTime As Long
   dwHighDateTime As Long
End Type

Private 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
   
Private Declare Function RegEnumKeyEx Lib "advapi32.dll" _
   Alias "RegEnumKeyExA" _
   (ByVal hKey As Long, _
   ByVal dwIndex As Long, _
   ByVal lpName As String, _
   lpcbName As Long, _
   ByVal lpReserved As Long, _
   ByVal lpClass As String, _
   lpcbClass As Long, _
   lpftLastWriteTime As FILETIME) As Long

Private Declare Function RegQueryValueEx Lib "advapi32.dll" _
   Alias "RegQueryValueExA" _
  (ByVal hKey As Long, _
   ByVal lpValueName As String, _
   ByVal lpReserved As Long, _
   lpType As Long, _
   lpData As Any, _
   lpcbData As Long) As Long
   
   
Private Declare Function RegQueryInfoKey Lib "advapi32.dll" _
   Alias "RegQueryInfoKeyA" _
  (ByVal hKey As Long, _
   ByVal lpClass As String, _
   lpcbClass As Long, _
   ByVal lpReserved As Long, _
   lpcSubKeys As Long, _
   lpcbMaxSubKeyLen As Long, _
   lpcbMaxClassLen As Long, _
   lpcValues As Long, _
   lpcbMaxValueNameLen As Long, _
   lpcbMaxValueLen As Long, _
   lpcbSecurityDescriptor As Long, _
   lpftLastWriteTime As FILETIME) As Long

Private Declare Function RegCloseKey Lib "advapi32.dll" _
  (ByVal hKey As Long) As Long

Private Declare Function SendMessage Lib "user32" _
   Alias "SendMessageA" _
  (ByVal hwnd As Long, _
   ByVal wMsg As Long, _
   ByVal wParam As Long, _
   lParam As Any) As Long

Private Declare Function lstrlenW Lib "kernel32" _
  (ByVal lpString As Long) As Long



Private Sub Form_Load()

  'Setup tabstops in the list box by first
  'clearing existing tabs, then setting the
  'new tabstop value.
   ReDim TabArray(0 To 0) As Long
   TabArray(0) = 100
   Call SendMessage(List1.hwnd, LB_SETTABSTOPS, 0&, ByVal 0&)
   Call SendMessage(List1.hwnd, LB_SETTABSTOPS, 1&, TabArray(0))
   List1.Refresh

   Command1.Caption = "Get Account Info"
   
   Label1.Caption = "Default Profile"
   Label2.Caption = "Account Info Path"
   
End Sub


Private Sub Command1_Click()

   Dim hKey As Long
   Dim sDefProfileName As String
   Dim sAccountList As String
   Dim dwIndex As Long
   Dim success As Long
   Dim sName As String
   Dim cbName As Long
   Dim dwSubKeys As Long
   Dim dwMaxSubKeyLen As Long
   Dim ft As FILETIME
   Dim olData As REG_OUTLOOKACCOUNT_INFO
   
  'retrieve default profile name
   sDefProfileName = GetOutlookUserProfileName()
  
   If Len(sDefProfileName) > 0 Then
  
      sAccountList = OUTLOOK_PROFILE_PATH_NT & "\" & _
                     sDefProfileName & "\" & _
                     OUTLOOK_ACCOUNT_NAMES_NT
  
     'update the display
      Text1.Text = sDefProfileName
      Text2.Text = sAccountList
      
     'locate 9375CFF0413111d3B88A00104B2A6676
     'key under the profile - this contains
     'the accounts - and get a handle to that key
      hKey = OpenRegKey(HKEY_CURRENT_USER, sAccountList)
      
      If hKey <> 0 Then

        'query registry for the number of
        'entries under that key
         If RegQueryInfoKey(hKey, _
                            0&, 0&, 0, _
                            dwSubKeys, _
                            dwMaxSubKeyLen&, _
                            0&, 0&, 0&, 0&, 0&, ft) = ERROR_SUCCESS Then

 
           'enumerate each item, pass it
           'to a helper function to retrieve
           'data for that key, and add to
           'the list
            For dwIndex = 0 To dwSubKeys - 1
            
               sName = Space$(dwMaxSubKeyLen + 1)
               cbName = Len(sName)
               
               success = RegEnumKeyEx(hKey, _
                                      dwIndex, _
                                      sName, _
                                      cbName, _
                                      0, 0, 0, ft)
               
               If success = ERROR_SUCCESS Or _
                  success = ERROR_MORE_DATA Then
                  
                  sName = TrimNull(sName)
                  olData = GetOutlookAccountInfo(sAccountList, sName)

                  With olData
                  
                    'valid for all accounts
                     List1.AddItem "Registry Name" & vbTab & .OlRegistryName
                     List1.AddItem "Account Clsid" & vbTab & .OlClsid
                     List1.AddItem "Account Type" & vbTab & .OlAccountType
                     List1.AddItem "Account Name" & vbTab & .OlAccountName
                  
                     If Len(.OlServiceName) = 0 Then
                        
                       'the data is account info so add to the list
                        List1.AddItem "Display Name" & vbTab & .OlDisplayName
                        List1.AddItem "Organization" & vbTab & .OlOrganization
                        List1.AddItem "Email" & vbTab & .OlEmail
                        List1.AddItem "Reply Email" & vbTab & .OlReplyEmail
                        List1.AddItem "Signature Name" & vbTab & .OlSignature
                        List1.AddItem "Reply Signature Name" & vbTab & .OlReplyForwardSignature
                        List1.AddItem "Pop3 User" & vbTab & .OlPop3User
                        List1.AddItem "Pop3 Server" & vbTab & .OlPop3Server
                        List1.AddItem "Smtp Server" & vbTab & .OlSmtpServer
                        List1.AddItem "Smtp Authentication" & vbTab & .OlSmtpServerUsesAuthentication

                     Else
                     
                       'the data is system info so this
                       'is the only other valid info returned
                        List1.AddItem "System: Service Name" & vbTab & .OlServiceName
                     
                     End If
                     
                     List1.AddItem ""

                  End With  'olData
            
               End If  'success
           
            Next  'dwIndex

         End If  'RegQueryInfoKey

         Call RegCloseKey(hKey)
  
      End If  'If hKey
   
   Else
      Text1.Text = "unable to determine user's profile name"
   End If  'Len(sDefProfileName)
  
End Sub


Private Function GetOutlookAccountInfo(sKey As String, _
                                       sAccountName As String) As REG_OUTLOOKACCOUNT_INFO

  'retrieve the available data
  'from a particular set of account keys
   Dim hSubKey As Long     'handle of the open subkey
   
   hSubKey = OpenRegKey(HKEY_CURRENT_USER, sKey & "\" & sAccountName)
                  
   If hSubKey <> 0 Then
   
   
      With GetOutlookAccountInfo
         .OlRegistryName = sAccountName
         .OlAccountName = GetRegBinaryValue(hSubKey, "Account Name")
         .OlClsid = GetRegValue(hSubKey, "clsid")
         
         If Len(.OlClsid) > 0 Then
            
            .OlAccountType = GetOutlookAccountType(.OlClsid)
         
         End If
         
         .OlDisplayName = GetRegBinaryValue(hSubKey, "Display Name")
         
         .OlEmail = GetRegBinaryValue(hSubKey, "Email")
         .OlOrganization = GetRegBinaryValue(hSubKey, "Organization")
         .OlPop3Server = GetRegBinaryValue(hSubKey, "POP3 Server")
         .OlPop3User = GetRegBinaryValue(hSubKey, "POP3 User")
         .OlReplyEmail = GetRegBinaryValue(hSubKey, "Reply Email")
         .OlSignature = GetRegBinaryValue(hSubKey, "New Signature")
         .OlReplyForwardSignature = GetRegBinaryValue(hSubKey, "Reply-Forward Signature")
         .OlServiceName = GetRegBinaryValue(hSubKey, "Service Name")
         .OlSmtpServer = GetRegBinaryValue(hSubKey, "SMTP Server")
         .OlSmtpServerUsesAuthentication = GetRegDwordValue(hSubKey, "SMTP Use Auth")
         
      End With

      Call RegCloseKey(hSubKey)
      
   End If

End Function


Private Function GetOutlookAccountType(clsid As String) As String

   Dim hKey As Long
   Dim buff As String
   
   hKey = OpenRegKey(HKEY_CLASSES_ROOT, "CLSID\" & clsid)
   
  'if valid
   If hKey <> 0 Then
   
     'get default profile for the current user
      buff = GetRegValue(hKey, vbNullString)
      Call RegCloseKey(hKey)

   End If
   
   GetOutlookAccountType = buff
   
End Function


Private Function GetOutlookUserProfileName() As String

   Dim hKey As Long
   Dim buff As String
   
   hKey = OpenRegKey(HKEY_CURRENT_USER, OUTLOOK_PROFILE_PATH_NT)
   
  'if valid
   If hKey <> 0 Then
   
     'get default profile for the current user
      buff = GetRegValue(hKey, "DefaultProfile")
      Call RegCloseKey(hKey)

   End If
   
   GetOutlookUserProfileName = buff

End Function


Private Function OpenRegKey(ByVal hKey As Long, _
                            ByVal lpSubKey As String) As Long

  Dim hSubKey As Long

  If RegOpenKeyEx(hKey, _
                  lpSubKey, _
                  0, _
                  KEY_READ, _
                  hSubKey) = ERROR_SUCCESS Then

      OpenRegKey = hSubKey

  End If

End Function


Private Function GetRegBinaryValue(hSubKey As Long, sKeyname As String) As String

   Dim cbData As Long
   Dim buff As String
   
   Dim dwKeyType As Long

   If RegQueryValueEx(hSubKey, _
                      sKeyname, _
                      0&, _
                      dwKeyType, _
                      ByVal 0&, _
                      cbData) = ERROR_SUCCESS Then
                        
      ReDim res(cbData) As Byte
      
      If RegQueryValueEx(hSubKey, _
                         sKeyname, _
                         0&, _
                         dwKeyType, _
                         res(0), _
                         cbData) = ERROR_SUCCESS Then
                                                      
         buff = res
         If Len(buff) Then
            GetRegBinaryValue = TrimNull(buff)
         Else
            GetRegBinaryValue = "(not defined for this account)"
         End If

      End If  'RegQueryValueEx
   
   End If  'RegQueryValueEx
   
   Erase res()
         
End Function


Private Function GetRegDwordValue(hSubKey As Long, sKeyname As String) As Long

   Dim lpValue As Long   'name of the value to retrieve
   Dim lpcbData As Long  'length of the retrieved value

  'if valid
   If hSubKey <> 0 Then
   
      lpcbData = 4  '4 bytes for a long
      
     'return the passed value if present
      If RegQueryValueEx(hSubKey, _
                               sKeyname, _
                               0&, _
                               0&, _
                               lpValue, _
                               lpcbData) = ERROR_SUCCESS Then
                               
         GetRegDwordValue = lpValue
         
      End If

   End If

End Function


Private Function GetRegValue(hSubKey As Long, sKeyname As String) As String

   Dim lpValue As String   'name of the value to retrieve
   Dim lpcbData As Long    'length of the retrieved value

  'if valid
   If hSubKey <> 0 Then
   
      lpValue = Space$(260)
      lpcbData = Len(lpValue)
      
     'find the passed value if present
      If RegQueryValueEx(hSubKey, _
                               sKeyname, _
                               0&, _
                               0&, _
                               ByVal lpValue, _
                               lpcbData) = ERROR_SUCCESS Then
                               
         GetRegValue = TrimNull(lpValue)
         
      End If

   End If

End Function


Private Function TrimNull(startstr As String) As String

   TrimNull = Left$(startstr, lstrlenW(StrPtr(startstr)))
   
End Function

 Comments

 
 

PayPal Link
Make payments with PayPal - it's fast, free and secure!

 
 
 
 

Copyright 1996-2011 VBnet and Randy Birch. All Rights Reserved.
Terms of Use  |  Your Privacy

 

Hit Counter