AD Based Outlook Email Signature for 2003, 2007 and NOW 2010!!!
Due to the popularity of this script there is no way I could not support 2010 also so here it is!
For those newbie’s to my blog, welcome and here is the full script:
(I also suggest before posting any questions you might have refer to the implementation guide posted some time ago)
'====================
'
' 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@iinet.net.au
' Date 20 May 2010
' Tested on windows 7, Vista, XP, XP64 and office 2003, 2007 and 2010.
' 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.gentex.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, RegKey10, 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"
RegKey10 = "HKEY_CURRENT_USER\Software\Microsoft\Office\14.0\Common\General"
RegKey07 = RegKey07 & "\Signatures"
RegKey10 = RegKey10 & "\Signatures"
RegKey = RegKey & "\Signatures"
objShell.RegWrite RegKey , "AD_Gentex"
objShell.RegWrite RegKey07 , "AD_Gentex"
objShell.RegWrite RegKey10 , "AD_Gentex"
UserDataPath = ObjShell.ExpandEnvironmentStrings("%appdata%")
FolderLocation = UserDataPath &"\Microsoft\AD_Gentex\"
HTMFileString = FolderLocation & "Gentex.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&"Gentex.rtf")
aFile.Delete
Set AFile = objFSO.GetFile(Folderlocation&"Gentex.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.Gentex.com.au><font color=#696969>www.Gentex.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.Gentex.com.au/> <img src=http://www.Gentex.com.au/images/Gentex-logo-web-175x70.gif border=0></a>" & vbCrLf
objfile.write "<br>" & vbCrLf
objfile.write "<img src=http://www.Gentex.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 Gentex 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("Gentex","")
' 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
For those running the script already, why not update it so you have the additional support, or those that have upgraded to 2010, you don’t have to wait any longer here is the section of the script you must change
' 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, RegKey10, 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"
RegKey10 = "HKEY_CURRENT_USER\Software\Microsoft\Office\14.0\Common\General"
RegKey07 = RegKey07 & "\Signatures"
RegKey10 = RegKey10 & "\Signatures"
RegKey = RegKey & "\Signatures"
objShell.RegWrite RegKey , "AD_Gentex"
objShell.RegWrite RegKey07 , "AD_Gentex"
objShell.RegWrite RegKey10 , "AD_Gentex"
UserDataPath = ObjShell.ExpandEnvironmentStrings("%appdata%")
FolderLocation = UserDataPath &"\Microsoft\AD_Gentex\"
HTMFileString = FolderLocation & "Gentex.htm"
Remember for both scripts you need to change the ‘gentex’ with your organisation’s name etc. once again refer to the implementation guide before asking any questions.
for the history of all articles published regarding this script see below:
-
AD Based Outlook Email Signature for 2003 and 2007
-
AD Based Outlook Email Signature for 2003 and 2007 Continued – Implementation Guide
-
AD Based Outlook Email Signature for 2003 and 2007 Part 3 – Removing the Reply / forward signature
-
AD Based Outlook Email Signature for 2003 and 2007 Part 4 – Now writes TXT and RTF as well as HTML
Enjoy,
Brad
August 10th, 2010 at 1:12 pm
Permissions running the script, If I run it as a logon script via GPO or login.cmd I get permissions denied, After doing some googling I found that If I add Schema admins to the user the script runs fine. How can I run the script as a normal user. And or what section of the script needs the schema admins group to run ??
Thanks
Wayne
February 9th, 2011 at 9:13 am
This is an excellent script. Thank you for the update. Here is one additional modification I would suggest for Remote Desktop users:
With Remote Desktop if another user is logged on already and has Outlook running, then subsequent users receive the message “Please shutdown Outlook before running this script” when they try to logon, and have to click through this before the logon will complete (Usually not a problem, but fatal if you are trying to run RemoteApp or Citrix XenDesktop). To resolve this, simply remove the following portion from the “If Not IsOutlookRunning Then” section:
strMsg = “Please shut down Outlook before ” & _
“running this script.”
MsgBox strMsg, vbExclamation, “SetDefaultSignature”
Now the script will run silently whether other users are logged on or not.
February 9th, 2011 at 1:49 pm
Great point Laney, thanks for your contribution.
March 29th, 2011 at 3:35 am
Hey Brad!
This script is fabulous. Works wonderful.
But there is one thing that disturbes me:
Is it possible, to keep the users’ own signatures?
Some user want to use a few signatures , p.ex. for informal e-mails. The script deletes all other signatures.
Greetings from Germany
Stefan
September 22nd, 2011 at 4:08 pm
Hey Brad, like Stefan (above), I also would like to keep existing signatures how is this possible?
Other than that the script is prefect. Much appreciated for your time and efforts in posting this up
thanks
Luke
November 19th, 2011 at 1:59 am
Hi, could you please explain what the “modify named profile” section is for?
I’ve got some users that have multiple profiles within Outlook and was wondering if this would help them?
Regards,
Kieran
December 6th, 2011 at 1:58 am
Further to my previous comment, I have a user that sends from 3 differant email address but all alias in to the same account. As an example i set up a second account on my machine called “kp@sevatas.com”.
I have tried to following code with no luck:
“‘ Use this version to set all accounts
‘ in the default mail profile
‘ to use a previously created signature
‘Call SetDefaultSignature(pggDefaultSig,”")
‘ Use this version (and comment the other) to
‘ modify a named profile.
Call SetDefaultSignature _
(“Kieran Pearce Sevatas”, “kp@sevatas.com”)”
The signature in outlook is called Kieran Pearce Sevatas and the file is Kieran Pearce Sevatas.htm.
Do you have any ideas why this may not be working? and can this be set for more than one profile?
January 6th, 2021 at 7:54 pm
Proxies For Senuke…
Due to the popularity of this script there is no way I could not support 2010 also so here it is! For those newbie’s to my blog, welcome and here is the full…
January 14th, 2021 at 11:09 pm
Michal Banda…
Due to the popularity of this script there is no way I could not support 2010 also so here it is! For those newbie’s to my blog, welcome and here is the full…