Submitted By: Bryan Dady

Creates a Microsoft Outlook email signature based on Active Directory information for the logged-on user.

Visual Basic
Edit|Remove
'==========================================================================
' VBScript Source File
' NAME: Email_Signature.vbs
' AUTHOR: Bryan Dady
' DATE  : 12/08/2006
' COMMENT: Create Email Signature block. Automatically save rtf, txt and html signature files
'		with data from Active Directory and open Outlook Mail Format preferences menu
'==========================================================================
'
'**Start Encode**
' Declarations
'==========================================================================
Option Explicit 
'On Error Resume Next
Dim szUserID, saveDir ' as variant
Dim WshShell, userID, objUser, objFSO ' as object
Dim objWord, objDoc, objSelection ' as object
Dim bValid ' as boolean

' Set OU_USERS with the proper parameters to query user objects; used on line 52
Const OU_USERS = "OU=people;OU=users;DC=US;DC=CompanyName;DC=net"
' Set Word formats
Const FONTNAME = "Verdana"
Const FONTSIZE = "8"
Const wdGray50 = 15 ' wdDarkBlue = 9
Const wdFormatRTF = 6
Const wdFormatFilteredHTML = 10
Const wdFormatUnicodeText = 7

Set WshShell = WScript.CreateObject("WScript.Shell")
'==========================================================================
' Script Body
'==========================================================================
' Read current userID from registry
bValid = False
On Error Resume Next
userID = WshShell.RegRead( "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Logon User Name" )
On Error Goto 0
Do
	'validate expected format of reg value found in userID
	If LCase( Left( userID, 1 ) ) = LCase( "u" ) Then
		bValid = True
	Else
		' userID retreival from registry doesn't meet expected format, ask user
		userID = InputBox( "Please enter your user ID","user ID","u999999")
		' Handle blank entry or user clicked [cancel]
		If userID = "" Then Wscript.Quit(46)
	End If
Loop Until bValid = true

' Check connection to Active Directory
On Error Resume Next
Set objUser = GetObject( "LDAP://cn=" & userID & "," & OU_USERS )

If Err Then
	MsgBox "Unable to connect to corporate network to retrieve user information." & vbNewLine & "Please confirm connection and try again.", ,Wscript.ScriptName
Else
	On Error Goto 0
	' create new MS Word document and setup formatting
	Set objWord = CreateObject("Word.Application")
	objWord.Visible = True
	Set objDoc = objWord.Documents.Add()
	Set objSelection = objWord.Selection

	objSelection.Font.Name = FONTNAME
	objSelection.Font.Size = FONTSIZE
	objSelection.Font.ColorIndex = wdGray50

	objSelection.TypeParagraph()

	'Retreive AD info and write to document
	With objUser
		objSelection.TypeText .description
		objSelection.TypeParagraph()
		objSelection.TypeText .title 'Title
		objSelection.TypeParagraph()
		objSelection.TypeText .department
		objSelection.TypeParagraph()
		objSelection.TypeText .division
		objSelection.TypeParagraph()
		objSelection.TypeParagraph()
		objSelection.TypeText .company
		objSelection.TypeParagraph()
		objSelection.TypeText .streetAddress & ", " & .physicalDeliveryOfficeName
		objSelection.TypeParagraph()
		objSelection.TypeText .l & ", " & .st & " " & .postalCode
		objSelection.TypeParagraph()
		objSelection.TypeParagraph()
		objSelection.TypeText .telephoneNumber & " direct, " & .facsimileTelephoneNumber & " fax"
		objSelection.TypeParagraph()
		objSelection.TypeText .mail
		objSelection.TypeParagraph()
	End With
	Set objUser = Nothing

	' add disclosure; optional based on corporate standards
	objSelection.TypeParagraph()
	objSelection.TypeText "This communication may contain privileged or other confidential information. If you have received it in error, please advise the sender by reply email and immediately delete the message and any attachments without copying or disclosing the contents. Thank you."
	objSelection.TypeParagraph()

	' define save location, per user profile
	Set objFSO = CreateObject("Scripting.FileSystemObject")
	saveDir = objFSO.BuildPath( objFSO.GetParentFolderName(WshShell.SpecialFolders("MyDocuments")), "Application Data\Microsoft\Signatures")
	Set objFSO = Nothing

	' save multiple formats supported by Outlook 2003
	objDoc.SaveAs saveDir & "\" & userID & ".rtf", wdFormatRTF
	objDoc.SaveAs saveDir & "\" & userID & ".htm", wdFormatFilteredHTML
	objDoc.SaveAs saveDir & "\" & userID & ".txt", wdFormatUnicodeText 

	objDoc.Close()

	' Cleanup
	objWord.Quit
	Set objSelection = Nothing
	' Set colTasks = Nothing
	Set objDoc = Nothing
	Set objWord = Nothing

	MsgBox "This file has been saved to the default directory where Outlook expects signature files." & vbNewLine & vbNewLine &_
		"You may now open Outlook and select the Tools -> Options -> Mail Format menu to review and select your new signature.", , Wscript.ScriptName

	Set WshShell = Nothing
End If