We help IT Professionals succeed at work.
Get Started

Acitve Directory based Outlook Signature

2,396 Views
Last Modified: 2012-06-21
This login script sets a Outlook 2003 Signature, based on the users attributes in active dirctory. We sometimes get the error message from Outlook "L2-Signature Missing" when replying to an email. The intent of the script however is that there should be no 'reply signature', only signatures on new messages.

One clue is that the script doesn't always appear to complete - the signature options in Outlook 2003 (Tools>Options>Mail Format) is not grayed out - the script is supposed to block the user from changing any signature settings within Outlook.
'====================
'
' VBScript: <Signatures.vbs>
' AUTHOR: Peter Aarts
' Contact Info: peter.aarts@l1.nl
' Modified: 6/30/09 by Matt Sayre
' Version 6 Includes FWS formatting, dutch removal, text line deleted, dynamic company, font black, font arial,and no reply.
'==================== 
'Option Explicit
On Error Resume Next 
Dim qQuery, objSysInfo, objuser
Dim FullName, EMail, Title, PhoneNumber, MobileNumber, FaxNumber, Office, Department
Dim web_address, FolderLocation, HTMFileString, StreetAddress, Town, State, Company
Dim ZipCode, PostOfficeBox, UserDataPath 
' Read LDAP(Active Directory) information to asigns the user's info to variables.
'====================
Set objSysInfo = CreateObject("ADSystemInfo")
objSysInfo.RefreshSchemaCache
qQuery = "LDAP://" & objSysInfo.Username
Set objuser = GetObject(qQuery) 
FullName = objuser.displayname
EMail = objuser.mail
Title = objuser.title
PhoneNumber = objuser.TelephoneNumber
FaxNumber = objuser.FaxNumber
Office = objuser.physicalDeliveryOfficeName
StreetAddress = objuser.streetaddress
PostofficeBox = objuser.postofficebox
Department = objUser.Department
ZipCode = objuser.postalcode
Town = objuser.l
MobileNumber = objuser.TelephoneMobile
web_address = "http://www.farweststeel.com/"  
' This section creates the signature files names and locations.
'====================
' Corrects Outlook signature folder location. Just to make sure that
' Outlook is using the purposed folder defined with variable : FolderLocation
' Example is based on Dutch version.
' Changing this in a production enviremont might create extra work
' all employees are missing their old signatures
'====================
Dim objShell, RegKey, RegKeyParm
Set objShell = CreateObject("WScript.Shell")
RegKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\11.0\Common\General"
RegKey = RegKey & "\Signatures"
objShell.RegWrite RegKey , "Signature"
UserDataPath = ObjShell.ExpandEnvironmentStrings("%appdata%")
FolderLocation = UserDataPath &"\Microsoft\Signature\"
HTMFileString = FolderLocation & "L1-Signature.htm"  
' This section disables the change of the signature by the user.
'====================
objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\11.0\Common\MailSettings\NewSignature" , "L1-Signature"
objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\11.0\Common\MailSettings\ReplySignature" , "L2-Signature"
objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\11.0\Outlook\Options\Mail\EnableLogging" , "0", "REG_DWORD" 
' This section checks if the signature directory exits and if not creates one.
'====================
Dim objFS1
Set objFS1 = CreateObject("Scripting.FileSystemObject")
If (objFS1.FolderExists(FolderLocation)) Then
Else
Call objFS1.CreateFolder(FolderLocation)
End if 
' The next section builds the signature file
'====================
Dim objFSO
Dim objFile,afile
Dim aQuote
aQuote = chr(34) 
' This section builds the HTML file version
'====================
Set objFSO = CreateObject("Scripting.FileSystemObject") 
' This section deletes to other signatures.
' These signatures are automaticly created by Outlook 2003.
'====================
Set AFile = objFSO.GetFile(Folderlocation&"L1-Signature.rtf")
aFile.Delete
Set AFile = objFSO.GetFile(Folderlocation&"L1-Signature.txt")
aFile.Delete 
Set AFile = objFSO.GetFile(Folderlocation&"L2-Signature.htm")
aFile.Delete 
 
Set objFile = objFSO.CreateTextFile(HTMFileString,True)
objFile.Close
Set objFile = objFSO.OpenTextFile(HTMFileString, 2) 
objfile.write "<!DOCTYPE HTML PUBLIC " & aQuote & "-//W3C//DTD HTML 4.0 Transitional//EN" & aQuote & ">" & vbCrLf
objfile.write "<HTML><HEAD><TITLE>Microsoft Office Outlook Signature</TITLE>" & vbCrLf
objfile.write "<META http-equiv=Content-Type content=" & aQuote & "text/html; charset=windows-1252" & aQuote & ">" & vbCrLf
objfile.write "<META content=" & aQuote & "MSHTML 6.00.3790.186" & aQuote & " name=GENERATOR></HEAD>" & vbCrLf
objfile.write "<BODY link=#FFFFFF alink=#FFCC00 vlink=#FFFFFF>" & vbCrLf
objfile.write "<BR>" & vbCrLf
objfile.write "<B><FONT size=2 color=black face=arial>"& FullName & "</B><BR>" & vbCrLf
objfile.write "<B><FONT size=2 color=black face=arial>"& title & "</B><BR>" & vbCrLf  
objfile.write "<FONT size=2 color=black face=arial>Phone:<FONT size=2 color=black> " & PhoneNumber & "<BR>" & vbCrLf
objfile.write "<FONT size=2 color=black face=arial>Fax:<FONT size=2 color=black> " & FaxNumber & "<BR><BR>" & vbCrLf 
if Instr(objuser.physicalDeliveryOfficeName, "Corporate") then 
objfile.write "<a href=" & aQuote & "http://www.farweststeel.com" & aQuote & ">" & "<img src=" & aQuote & "http://eudc1.farweststeel.com/sig/corporation.jpg" & aQuote & " width=" & aQuote & "150" & aQuote &  " height=" & aQuote & "40" & aQuote  & " border=" & aQuote & "0" & aQuote & "></a>" & vbCrLf 
elseif Instr(objuser.physicalDeliveryOfficeName,"Fabrication") then 
objfile.write "<a href=" & aQuote & "http://www.farweststeel.com" & aQuote & ">" & "<img src=" & aQuote & "http://eudc1.farweststeel.com/sig/fabrication.jpg" & aQuote & " width=" & aQuote & "150" & aQuote &  " height=" & aQuote & "37" & aQuote  & " border=" & aQuote & "0" & aQuote & "></a>" & vbCrLf 
elseif Instr(objuser.physicalDeliveryOfficeName, "Rebar") then 
objfile.write "<a href=" & aQuote & "http://www.farweststeel.com" & aQuote & ">" & "<img src=" & aQuote & "http://eudc1.farweststeel.com/sig/reinforcing.jpg" & aQuote & " width=" & aQuote & "150" & aQuote &  " height=" & aQuote & "40" & aQuote  & " border=" & aQuote & "0" & aQuote & "></a>" & vbCrLf 
elseif Instr(objuser.physicalDeliveryOfficeName, "Contracting") then 
objfile.write "<a href=" & aQuote & "http://www.farweststeel.com" & aQuote & ">" & "<img src=" & aQuote & "http://eudc1.farweststeel.com/sig/contracting.jpg" & aQuote & " width=" & aQuote & "150" & aQuote &  " height=" & aQuote & "40" & aQuote  & " border=" & aQuote & "0" & aQuote & "></a>" & vbCrLf
end if 
objfile.write "</FONT></BODY></HTML>" & vbCrLf
objFile.Close 
' ===========================
' This section readsout the current Outlook profile and then sets the name of the default Signature
' ===========================
' Use this version to set all accounts
' in the default mail profile
' to use a previously created signature 
Call SetDefaultSignature("L1-Signature","L2-Signature") 
' Use this version (and comment the other) to
' modify a named profile.
'Call SetDefaultSignature _
' ("Signature Name", "Profile Name") 
Sub SetDefaultSignature(strSigName, strProfile)
Const HKEY_CURRENT_USER = &H80000001
strComputer = "." 
If Not IsOutlookRunning Then
Set objreg = GetObject("winmgmts:" & _
"{impersonationLevel=impersonate}!\\" & _
strComputer & "\root\default:StdRegProv")
strKeyPath = "Software\Microsoft\Windows NT\" & _
"CurrentVersion\Windows " & _
"Messaging Subsystem\Profiles\"
' get default profile name if none specified
If strProfile = "" Then
objreg.GetStringValue HKEY_CURRENT_USER, _
strKeyPath, "DefaultProfile", strProfile
End If
' build array from signature name
myArray = StringToByteArray(strSigName, True)
strKeyPath = strKeyPath & strProfile & _
"\9375CFF0413111d3B88A00104B2A6676"
objreg.EnumKey HKEY_CURRENT_USER, strKeyPath, _
arrProfileKeys
For Each subkey In arrProfileKeys
strsubkeypath = strKeyPath & "\" & subkey
objreg.SetBinaryValue HKEY_CURRENT_USER, _
strsubkeypath, "New Signature", myArray
objreg.SetBinaryValue HKEY_CURRENT_USER, _
strsubkeypath, "Reply-Forward Signature", myArray
Next
Else
strMsg = "Please shut down Outlook before " & _
"running this script."
MsgBox strMsg, vbExclamation, "SetDefaultSignature"
End If
End Sub 
Function IsOutlookRunning()
strComputer = "."
strQuery = "Select * from Win32_Process " & _
"Where Name = 'Outlook.exe'"
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" _
& strComputer & "\root\cimv2")
Set colProcesses = objWMIService.ExecQuery(strQuery)
For Each objProcess In colProcesses
If UCase(objProcess.Name) = "OUTLOOK.EXE" Then
IsOutlookRunning = True
Else
IsOutlookRunning = False
End If
Next
End Function 
Public Function StringToByteArray _
(Data, NeedNullTerminator)
Dim strAll
strAll = StringToHex4(Data)
If NeedNullTerminator Then
strAll = strAll & "0000"
End If
intLen = Len(strAll) \ 2
ReDim arr(intLen - 1)
For i = 1 To Len(strAll) \ 2
arr(i - 1) = CByte _
("&H" & Mid(strAll, (2 * i) - 1, 2))
Next
StringToByteArray = arr
End Function 
Public Function StringToHex4(Data)
' Input: normal text
' Output: four-character string for each character,
' e.g. "3204" for lower-case Russian B,
' "6500" for ASCII e
' Output: correct characters
' needs to reverse order of bytes from 0432
Dim strAll
For i = 1 To Len(Data)
' get the four-character hex for each character
strChar = Mid(Data, i, 1)
strTemp = Right("00" & Hex(AscW(strChar)), 4)
strAll = strAll & Right(strTemp, 2) & Left(strTemp, 2)
Next
StringToHex4 = strAll
End Function

Open in new window

Comment
Watch Question
This problem has been solved!
Unlock 1 Answer and 3 Comments.
See Answer
Why Experts Exchange?

Experts Exchange always has the answer, or at the least points me in the correct direction! It is like having another employee that is extremely experienced.

Jim Murphy
Programmer at Smart IT Solutions

When asked, what has been your best career decision?

Deciding to stick with EE.

Mohamed Asif
Technical Department Head

Being involved with EE helped me to grow personally and professionally.

Carl Webster
CTP, Sr Infrastructure Consultant
Ask ANY Question

Connect with Certified Experts to gain insight and support on specific technology challenges including:

  • Troubleshooting
  • Research
  • Professional Opinions
Did You Know?

We've partnered with two important charities to provide clean water and computer science education to those who need it most. READ MORE