|
|
|
|
|
|
|
|
|
|
|
 |
|
|||||||||||||||||||||||||||||||||||||||||||||||||||||||
|
||||||||||||||||||||||||||||||||||||||||||||||||||||||||
 |
||||||||||||||||||||||||||||||||||||||||||||||||||||||||
|
|
||
| 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. |
|
|
 ThisUnfortunately, 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 |
|
|
|
|
|
|||||
|
|||||
|
|
|||||
|
Copyright ©1996-2011 VBnet and Randy Birch. All Rights Reserved. |
 |
