Automating Outlook Signatures

Recently I was tasked with a way to standardize our signatures in Outlook. I came up with the follow script that was applied as a group policy to all users. There are a few things to note however:

• The script works on Outlook 2003/2007
• Other then IE, Webmail, and Outlook other browsers or Operating System will distort the layout of the signature
• The script pulls all information from Active Directory

 

On Error Resume Next

Set objSysInfo = CreateObject("ADSystemInfo")
strUser = objSysInfo.UserName
Set objUser = GetObject("LDAP://" & strUser)

strConfidS = "Confidentiality Note:"
strConfid = "Notice goes here"
strFname = objUser.FirstName
strLname = objUser.LastName
strInitial = objUser.Initials
strTitle = objUser.Title
strWebsite = "www.mycompanieswebsite.com"
strCompany = objUser.Company 
strPhone = objUser.telephoneNumber
strFax = objUser.facsimileTelephoneNumber
strStreet = objUser.streetAddress
strCity = objUser.l
strState = objUser.st
strZip = objUser.postalCode
strEmail = objUser.mail

Set objWord = GetObject(, "Word.Application")
If objWord Is Nothing Then
Set objWord = CreateObject("Word.Application")
blnWeOpenedWord = True
End If
Set objDoc = objWord.Documents.Add()
Set objSelection = objWord.Selection
Set objEmailOptions = objWord.EmailOptions
Set objSignatureObjects = objWord.EmailOptions.EmailSignature
Set objSignatureEntries = objSignatureObjects.EmailSignatureEntries
objSelection.Style = "No Spacing"


'Name
objSelection.Font.Size = "11"
objselection.Font.Bold = true
objSelection.TypeText vbTab & " " & strFname & " "
if strInitial then 
objSelection.TypeText UCase(strInitial) & ". "
end if
objSelection.TypeText strLname
objselection.Font.Bold = false

objSelection.Font.Size = "8"
objSelection.TypeText Chr(11)
objSelection.TypeText vbTab & " " & strCompany
objSelection.TypeText Chr(11)
if strTitle then 
objSelection.TypeText vbTab & " " & strTitle
end if

objSelection.TypeText Chr(11)
objSelection.TypeText Chr(11)
objSelection.TypeText vbTab & " " & strStreet & Chr(11)
objSelection.TypeText vbTab & " " & strCity & ", " & strState & " " & strZip & Chr(11)
objSelection.TypeText vbTab & " " & "tel. " & strPhone & Chr(11)
objSelection.TypeText vbTab & " " & "fax. " & strFax & Chr(11)
objSelection.TypeText Chr(11)

objSelection.TypeText vbTab & " " & "email. " & strEmail & Chr(11)
objSelection.TypeText vbTab & " " & "website. " & strWebsite & Chr(11)
objSelection.TypeText Chr(11)

objSelection.Font.Bold = True
objSelection.TypeText strConfidS & " "
objSelection.Font.Bold = False
objSelection.TypeText strConfid
Set objSelection = objDoc.Range()

Set objShape = objDoc.Shapes
objShape.AddPicture("\\server\netlogon\logo.png")

objSignatureEntries.Add "AD Signature", objSelection
objSignatureObjects.NewMessageSignature = "AD Signature"
objSignatureObjects.ReplyMessageSignature = "AD Signature"

objDoc.Close 0
If blnWeOpenedWord Then
objWord.Quit
End If