This code may get you started manipulating signatures in Outlook. Each
version of Outlook does things differently. 2000 and 2003 store signatures
separetly for each profile. 2002 does not. 2003 requires a restart after
changing the registry setting before it will pick it up. I have not included
the code for setting/getting registry values, but you should get the idea.
Unfortunately Outlook often likes to store things in the registry using
REG_EXPAND_SZ and REG_BINARY, which can be a pain.
Private Sub SetOutlookSignature2000(sSignature As String, sProfile As
String)
On Error GoTo ErrorHandler
Dim sRegistryPath As String
sRegistryPath = GetProfilesRegistryPath() & sProfile &
"\0a0d020000000000c000000000000046"
If Not SetRegistryValue(HKEY_CURRENT_USER, sRegistryPath,
"001e0361", sSignature) Then
' Do something with the error...
End If
Exit Sub
ErrorHandler:
' Do something with the error...
End Sub
Private Sub SetOutlookSignature2002(sSignature As String)
On Error GoTo ErrorHandler
' Outlook 2002 stores the signature name as REG_EXPAND_SZ.
If Not SetRegistryValue(HKEY_CURRENT_USER,
"Software\Microsoft\Office\10.0\Common\MailSettings", "NewSignature",
sSignature, REG_EXPAND_SZ) Then
' Do something with the error...
End If
Exit Sub
ErrorHandler:
' Do something with the error...
End Sub
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
' Do something with the error...
End If
Next
Exit Sub
ErrorHandler:
' Do something with the error...
End Sub
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 with the error...
End Function
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
' Do something with the error...
End If
Exit Function
ErrorHandler:
' Do something with the error...
End Function
