This code should do what you are looking for. I haven't included all the
code, but you should get the idea. Look under GetOutlookAccounts2003(). I
think that will get you specifically what you are looking for. You mentioned
that the key with the list of account is empty for you. I've never found
this to be the case if email accounts have been setup. Perhaps your registry
reading code is not working properly? Just a guess.
--
Tom Winter
(e-mail address removed)
Private Sub SetOutlookSignature2003(sSignature As String, sProfile As
String)
On Error GoTo ErrorHandler
Dim sRegistryPath As String
Dim lAccounts() As Long
Dim lAccountIterator As Long
Dim lAccount As Long
sRegistryPath = GetProfilesRegistryPath() & sProfile &
"\9375CFF0413111d3B88A00104B2A6676\"
lAccounts = GetOutlookAccounts2003(sProfile)
For lAccountIterator = LBound(lAccounts) To UBound(lAccounts)
lAccount = lAccounts(lAccountIterator)
If Not SetRegistryValue(HKEY_CURRENT_USER, sRegistryPath &
FormatLongToHex(lAccount), "New Signature", sSignature, REG_BINARY) Then
' Raise an error or something.
End If
Next
Exit Sub
ErrorHandler:
' Do something appropriate...
End Sub
Public Function GetOutlookAccounts2003(sProfile As String) As Long()
On Error GoTo ErrorHandler
' Outlook 2003 stores signature information separately for each
e-mail account
' defined, so we need to get a list of those accounts. This function
returns
' an array of longs, each of which is an account number.
Dim sRegistryPath As String
Dim vAccounts As Variant
' This path is where all of the account information is stored. Under
this path
' there is a sub-key for each account, directory (address book) and
data file.
sRegistryPath = GetProfilesRegistryPath() & sProfile &
"\9375CFF0413111d3B88A00104B2A6676\"
' Here, GetRegistryValue returns an array of longs, each of which is
an account number.
' This registry value contains a list of which sub-keys are e-mail
accounts.
vAccounts = GetRegistryValue(HKEY_CURRENT_USER, sRegistryPath,
"{ED475418-B0D6-11D2-8C3B-00104B2A6676}", Empty, vbLong)
If Not IsEmpty(vAccounts) Then
GetOutlookAccounts2003 = vAccounts
Else
' Raise an error or something. There are no accounts defined.
End If
Exit Function
ErrorHandler:
' Do something appropriate...
End Function
Public Function GetProfilesRegistryPath() As String
On Error GoTo ErrorHandler
' This returns the registry path where MAPI/Outlook store
information about
' profiles. Right under this path there is a sub-key for each
profile.
' This path is different for 95/98/ME versus NT/2000/XP/2003.
If IsWindowsNT() Then
GetProfilesRegistryPath = "Software\Microsoft\Windows
NT\CurrentVersion\Windows Messaging Subsystem\Profiles\"
Else
GetProfilesRegistryPath = "Software\Microsoft\Windows Messaging
Subsystem\Profiles\"
End If
Exit Function
ErrorHandler:
' Do something appropriate...
End Function
