AD Based Outlook Email Signature for 2003 and 2007
There is a few of these scripts out there that pull all the information from AD and then input it to a simple text format. But lets face it who has just text based signatures these days with the quick connections and cheap data costs. So I went on the look out for a Email signature that could be modified to how I desire, or how the company desires. Funnily enough there was not that many scripts I could find, there does seem to be a few third party applications. But who wants to pay… I hate paying for something that can be scripted.
Anyway I came across a script that did exactly want I wanted, it removes the old signatures and creates a new one (which you have designed) making it the default signature.
http://cwashington.netreach.net/depo/view.asp?Index=1123 written by Peter Aarts
So I took the base of the script (thanks a million Peter Aarts) then modified the ‘objfile.write’ objects with the HTML parts that I required to make the signature conform to the company standard.
It worked perfectly. But the issue is the above link / script only works with outlook 2003. the fix for 2007 is super simple…
All that needs to be done to make it 2007 compliant is:
Where it says
“HKEY_CURRENT_USER\Software\Microsoft\Office\11.0\Common\General”
change the 11.0 to a 12.0
“HKEY_CURRENT_USER\Software\Microsoft\Office\12.0\Common\General”
That’s it so simple….
Well its not that easy… if you have a mixed environment like we do then its defiantly not that easy… I have done the hard work for you, all you have to do is a copy and paste… and take the credit 
'==================== ' ' VBScript: <Signatures.vbs> ' AUTHOR: Peter Aarts ' Contact Info: peter.aarts@l1.nl ' Version 2.04 ' Date: January 20, 2006 ' Moddified By Brad Marsh Now works with both 2003 and 2007 outlook ' Contact: gentex@tpg.com.au ' Date 19 feb 08 ' Tested on Vista, XP, XP64 and office 2003 and 2007. ' NOTE will not work that well with various email accounts '==================== 'Option Explicit On Error Resume Next Dim qQuery, objSysInfo, objuser Dim FullName, EMail, Title, PhoneNumber, MobileNumber, FaxNumber, OfficeLocation, 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 Company = objuser.Company Title = objuser.title PhoneNumber = objuser.TelephoneNumber FaxNumber = objuser.FaxNumber OfficeLocation = objuser.physicalDeliveryOfficeName StreetAddress = objuser.streetaddress PostofficeBox = objuser.postofficebox Department = objUser.Department ZipCode = objuser.postalcode Town = objuser.l MobileNumber = objuser.TelephoneMobile web_address = "http://www.elcom.com.au" ' 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, RegKey07, RegKeyParm Set objShell = CreateObject("WScript.Shell") RegKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\11.0\Common\General" RegKey07 = "HKEY_CURRENT_USER\Software\Microsoft\Office\12.0\Common\General" RegKey07 = RegKey07 & "\Signatures" RegKey = RegKey & "\Signatures" objShell.RegWrite RegKey , "AD_elcom" objShell.RegWrite RegKey07 , "AD_elcom" UserDataPath = ObjShell.ExpandEnvironmentStrings("%appdata%") FolderLocation = UserDataPath &"\Microsoft\AD_elcom\" HTMFileString = FolderLocation & "Elcom.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-Handtekening" 'objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\11.0\Common\MailSettings\ReplySignature" , "L1-Handtekening" '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&"Elcom.rtf") aFile.Delete Set AFile = objFSO.GetFile(Folderlocation&"Elcom.txt") 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>" & vbCrLf objfile.write "<font color=696969 face=" & aQuote & "Arial" & aQuote & "><h6> "& FullName & " | " & title & " | "& Company & " | Australian Technology Park <br>"& vbCrLf objfile.write "T +612 " & PhoneNumber & " | F +612 9209 4423 | <a href=http://www.elcom.com.au><font color=#696969>www.elcom.com.au</font></a> |<a href=mailto:" & Email &" > <font color=#696969>" & Email &" " & vbCrLf objfile.write "</h6></font></a></B>" & vbCrLf objfile.write "</font>" & vbCrLf objfile.write "<font color=696969 face=arial><A href=http://www.elcom.com.au/> <img src=http://www.elcom.com.au/images/elcom-logo-web-175x70.gif border=0></a>" & vbCrLf objfile.write "<br>" & vbCrLf objfile.write "<img src=http://www.elcom.com.au/images/mspartner.jpg>" & vbCrLf objfile.write "<br>" & vbCrLf objfile.write "</font><font color=696969 size=1 face=arial><br>" & vbCrLf objfile.write "<hr size=1 align=left width=465 color=696969>" & vbCrLf objfile.write " This email is intended for the intended recipients(s) and may contain confidential information. <br> Reproduction, dissemination or distribution of this message is prohibited unless authorised by the sender.<br> If you are not the intended recipient, please notify the sender immediately and you must not read,<br> keep, use, disclose, copy or distribute this email without the sender's prior permission.<br> The views expressed by the sender are not necessarily those of Elcom Technology Pty Ltd</font>" & vbCrLf 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("Elcom","") ' 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
Enjoy
NOTE: I have now posted a how to implement article on this topic find it here
