[VBnet Registry] RegEnumKeyEx: POP3, SMTP, NNTP and LDAP Account Info (Outlook Express)


	Visual Basic Registry Routines RegEnumKeyEx: POP3, SMTP, NNTP and LDAP Account Info (Outlook Express)

Posted:	Sunday July 07, 2002
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.

Under the registry key HKEY_CURRENT_USER\Software\Microsoft\Internet Account Manager resides all account information for all configured internet accounts for the current user of Outlook Express. This includes POP3 and SMTP (email) accounts, as well as NNTP (newsgroup) accounts. Following enumeration of the account names specifics of each account can be extracted.

Because some accounts have both POP3 and SMTP components, the code below attempts to retrieve both sets of information from each account. In addition, as shown as the first three items in the illustration, the code also retrieves the mail, news and LDAP default accounts, with the values returned representing the account names.

There can be considerably more information provided for a given account. In addition, not all accounts have the same information, even when the same account type. This is reflective of both the information requested when the account is created, and the extent of the information entered by the user.

If you're targeting systems using Outlook the registry info is stored in a different area and using a different syntax. Please see RegQueryValueEx: Retrieve Email Account Info (Outlook) for an Outlook-specific method that was developed and tested with Outlook 2003.

BAS Module Code

None.

Form Code

Add a single command button (Command1) and a listbox (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_CURRENT_USER = &H80000001
Private Const REG_SZ As Long = 1
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_INET_INFO
   RegistryName      As String
   
   NNTPDefAccount    As String
   DefaultNewsAcct    As String
   DefaultMailAcct    As String
   DefaultLDAPAcct    As String
   
   NNTPSignature     As String
   NNTPServer        As String
   NNTPAccountName   As String
   NNTPUserName      As String
   NNTPEmail         As String
   NNTPReplyEmail    As String
   
   SMTPSignature     As String
   SMTPServer        As String
   SMTPAccountName   As String
   SMTPEmail         As String
   SMTPUserName      As String
   SMTPReplyEmail    As String
   
   POP3Server        As String
   POP3AccountName   As String
   POP3UserName      As String
   POP3Email         As String
   POP3ReplyEmail    As String

   LDAPServer        As String
   LDAPAccountName   As String
   LDAPUrl           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 listbox 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"

End Sub


Private Sub Form_Resize()

   If Me.WindowState <> vbMinimized Then
   
      If List1.Width > 100 Then
      
         List1.Move List1.Left, List1.Top, Me.ScaleWidth - (List1.Left * 2)
      
      End If
   
   End If
End Sub  


Private Sub Command1_Click()

   Dim ft As FILETIME
   
   Dim dwIndex As Long
   Dim success As Long
   Dim sKey As String
   Dim hKey As Long
   
   Dim sName As String
   Dim cbName As Long
   Dim dwSubKeys As Long
   Dim dwMaxSubKeyLen As Long
   
   Dim acct As REG_INET_INFO
   
  'Call a helper function to obtain the user's
  'default account keys, returning the data in
  'the REG_INET_INFO 'acct' UDT
   sKey = "Software\Microsoft\Internet Account Manager"
   hKey = OpenRegKey(HKEY_CURRENT_USER, sKey)
   
  'if valid
   If hKey <> 0 Then
   
     'get default user data and close that
     'key as its no longer needed
      acct = GetInetDefaultAccountInfo(hKey)
      Call RegCloseKey(hKey)
      
     'show the default account data
      List1.AddItem "Default Mail account" & vbTab & acct.DefaultMailAcct
      List1.AddItem "Default News account" & vbTab & acct.DefaultNewsAcct
      List1.AddItem "Default LDAP account" & vbTab & acct.DefaultLDAPAcct
      List1.AddItem ""
      
      
     '-----------------
     'GET DATA FROM ALL INTERNET ACCOUNTS
     'now obtain a handle to the \Accounts
     'key under the key above
      sKey = "Software\Microsoft\Internet Account Manager\Accounts"
      hKey = OpenRegKey(HKEY_CURRENT_USER, sKey)
     
     'if valid
      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
               
                 'call a helper function to
                 'retrieve the data under each
                 'account, returning results to
                 'the UDT.
                  acct = GetInetAccountKeyInfo(sKey, TrimNull(sName))
                  
                 'show the data
                  With List1
                     .AddItem "Account  " & acct.RegistryName
                                 
                     If Len(acct.NNTPServer) > 0 Then
                     
                       'it's a news server
                        .AddItem "NNTP Type" & vbTab & acct.NNTPSignature
                        .AddItem "NNTP Name" & vbTab & acct.NNTPAccountName
                        .AddItem "NNTP User" & vbTab & acct.NNTPUserName
                        .AddItem "NNTP Server" & vbTab & acct.NNTPServer
                        .AddItem "NNTP Email" & vbTab & acct.NNTPEmail
                        .AddItem "NNTP ReplyTo" & vbTab & acct.NNTPReplyEmail
                       
                     ElseIf Len(acct.LDAPServer) <> 0 Then
                       
                        'it's a LDAP server
                        .AddItem "Name" & vbTab & acct.NNTPAccountName
                        .AddItem "LDAP Server" & vbTab & acct.LDAPServer
                        .AddItem "LDAP Url" & vbTab & acct.LDAPUrl
                        
                     Else
                     
                        'it's an email server
                        .AddItem "SMTP Type" & vbTab & acct.SMTPSignature
                        .AddItem "SMTP Name" & vbTab & acct.SMTPAccountName
                        .AddItem "SMTP Server" & vbTab & acct.SMTPServer
                        .AddItem "SMTP User" & vbTab & acct.SMTPUserName
                        .AddItem "SMTP Email" & vbTab & acct.SMTPEmail
                        .AddItem "SMTP ReplyTo" & vbTab & acct.SMTPReplyEmail
                        
                        .AddItem "POP3 Name" & vbTab & acct.POP3AccountName
                        .AddItem "POP3 Server" & vbTab & acct.POP3Server
                        .AddItem "POP3 User" & vbTab & acct.POP3UserName
                        .AddItem "POP3 Email" & vbTab & acct.POP3Email
                        .AddItem "POP3 ReplyTo" & vbTab & acct.POP3ReplyEmail
      
                     End If
                     
                  'just a blank entry to separate
                  .AddItem ""
                  
                  End With  'List1
               End If  'success
            Next  'dwIndex
         End If  'RegQueryInfoKey
         
         Call RegCloseKey(hKey)
         
      End If  'hKey <> 0  
   End If  'hKey <> 0
   
End Sub
  
  
Private Function GetInetDefaultAccountInfo(hKey As Long) As REG_INET_INFO

   If hKey <> 0 Then
   
      With GetInetDefaultAccountInfo
      
         .DefaultLDAPAcct = GetRegValue(hKey, "Default LDAP Account")
         .DefaultMailAcct = GetRegValue(hKey, "Default Mail Account")
         .DefaultNewsAcct = GetRegValue(hKey, "Default News Account")
         
      End With
      
   End If

End Function


Private Function GetInetAccountKeyInfo(ByVal sKey As String, _
                                        ByVal lpValueName As String) As REG_INET_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 & "\" & lpValueName)
                  
   If hSubKey <> 0 Then
      With GetInetAccountKeyInfo
      
         .RegistryName = lpValueName
         
         .NNTPAccountName = GetRegValue(hSubKey, "Account Name")
         .NNTPSignature = GetRegValue(hSubKey, "NNTP Signature")
         .NNTPServer = GetRegValue(hSubKey, "NNTP Server")
         .NNTPEmail = GetRegValue(hSubKey, "NNTP Email Address")
         .NNTPUserName = GetRegValue(hSubKey, "NNTP User Name")
         
         .SMTPSignature = GetRegValue(hSubKey, "SMTP Signature")
         .SMTPServer = GetRegValue(hSubKey, "SMTP Server")
         .SMTPAccountName = GetRegValue(hSubKey, "Account Name")
         .SMTPUserName = GetRegValue(hSubKey, "SMTP User Name")
         .SMTPEmail = GetRegValue(hSubKey, "SMTP Email Address")
         .SMTPReplyEmail = GetRegValue(hSubKey, "SMTP Reply To Email Address")
         
         .POP3Server = GetRegValue(hSubKey, "POP3 Server")
         .POP3AccountName = GetRegValue(hSubKey, "Account Name")
         .POP3UserName = GetRegValue(hSubKey, "POP3 User Name")
         .POP3Email = GetRegValue(hSubKey, "POP3 Email Address")
         .POP3ReplyEmail = GetRegValue(hSubKey, "POP3 Reply To Email Address")
         
         .LDAPServer = GetRegValue(hSubKey, "LDAP Server")
         .LDAPAccountName = GetRegValue(hSubKey, "Account Name")
         .LDAPUrl = GetRegValue(hSubKey, "LDAP URL")
         
      End With
   
      Call RegCloseKey(hSubKey)
      
   End If

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 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
   Dim result As Long

  '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