I've put together a script for creating Outlook signatures that includes details collected from active directory along with a company logo, example image below.
Along with the script there are a few supporting template files all of which can be downloaded
here I've also put a few blog entries together with more detailed information on how the script works and how to update the temeplet files with new images.
http://ifnotisnull.wordpress.com Apart for being useful for creating consistent Outlook signatures across your organisation there may be some functions and sub procedures that you can re-use in your own scripts.
I've included the source code for the script in this post but the formatting seems all messed up with no proper line breaks.
You might find it easier to grab a copy from the download link I have provided above.
Main Script code below:
Option Explicit'#########################################################################' Description: Add Outlook signatures to users profile.' Author: Steve Adams' Date: 10-01-2012' Version: 1.0'#########################################################################
'--------------------------------------------------------------------------'Exit codes'--------------------------------------------------------------------------' 0 - Success'99 - Failed to create a text file required by this script'98 - Failed to write to a text file required by this script'97 - Unable to find master signature template folder
'--------------------------------------------------------------------------'Declare constants'--------------------------------------------------------------------------Const APPLICATION_DATA = &H1a&Const ForReading = 1 '\Const ForAppending = 8 ' --> Used by OpentextFile object to determine how to open fileConst ForWriting = 2 '/'RegistryConst HKEY_CURRENT_USER = &H80000001
'-------------------------------------------------------------------------' Declare variables'--------------------------------------------------------------------------'Log fileDim objShell 'Scripting shell objectDim objFolder 'Scripting folder objectDim CUAppPath 'Current users application data folderDim LogFile 'Log file to write stuff toDim MyPath 'Location this script is running from'Company detailsDim CompanyName 'Name of the companyDim CompanyWeb 'Default company web site'Over ride addressDim OverrideAddress 'If this is set the active directory address will be ignored 'User detailsDim UserDomain 'Current users domainDim UserName 'Current users logon nameDim ComputerName 'Name of computer this script is running onDim UsrDN 'Users active directory distinguished name'User active directory account propertiesDim NAME 'Display nameDim TITLE 'TitleDim EXTERNALPHONE 'Telephone numberDim INTERNALPHONE 'PagerDim FAX 'Facsimile telephone numberDim MOBILEPHONE 'MobileDim DESCRIPTION 'DescriptionDim OFFICE 'Physical delivery office nameDim DEPARTMENT 'DepartmentDim COMPANY 'CompanyDim EMAIL 'MailDim WWW 'www home page'User active directory address detailsDim STREET 'Street addressDim arrStreet 'Temporary street arrayDim StreetLoop 'Loop count for street arrayDim POBOX 'Post office boxDim CITY 'lDim STATE 'StDim POSTCODE 'Postal codeDim COUNTRY 'Co'Signature filesDim UserSigRoot 'Path to current users signatures folderDim MasterSigRoot 'Path to source master (template) signature folder (Netlogon share)Dim MasterSigName 'Name of the master (template) signature filesDim strRTF 'String to hold RTF template loaded into RAMDim strHTM 'String to hold HTM template loaded into RAMDim arrColumn1 'Array to hold column 1 of signature contentDim arrColumn2 'Array to hold column 2 of signature contentDim arrColumn3 'Array to hold column 3 of signature contentDim SigName 'Name for signature in Outlook'Environmental printing message'http://thinkbeforeprinting.orgDim EnviroPrint 'Flag to indicate if this should be included or notDim EnviroPrintFile 'Name of image file to be included HTM versionDim msgEnviroPrint 'Text messageDim htmEnviroPrint 'String with htm code for environmental print messageDim rtfEnviroPrint 'String with RTF code for environmental print messageDim rtfEnviroPrintExtract 'Extracted RTF code in a txt file ready for import'Force defaut Outlook signatureDim DefaultSig 'Force this signature to be set as the default in Outlook'-------------------------------------------------------------------------'Set some values'-------------------------------------------------------------------------CompanyName = "Local Lab Limited"CompanyWeb = "www.lab.local"SigName = "Local-Lab-Signature"'Configure optional environmental print message true / false'If set to true an environmental image / message will be tagged to the bottom of'the email signatureEnviroPrint = TrueEnviroPrintFile = "thinkbeforeprinting.gif"msgEnviroPrint = "Please consider the environment before printing this email"rtfEnviroPrintExtract = "rtfEnviroPrintExtract.txt"DefaultSig = True'##########################################################################' Start of script'##########################################################################'--------------------------------------------------------------------------'Prepare for logfile'--------------------------------------------------------------------------'Get path to this scriptMyPath = Left(WScript.ScriptFullName, InstrRev(WScript.ScriptFullName, "\"))'XP - C:\Documents and Settings\<Current User Profile>\Application Data'WIN 7 - C:\Users\stevea\<Current User Profile>\RoamingSet objShell = CreateObject("Shell.Application")Set objFolder = objShell.Namespace(APPLICATION_DATA)CUAppPath = objFolder.Self.Path & "\"LogFile = CUAppPath & "doOLSig.log"'XP - C:\Documents and Settings\<Current User Profile>\Application Data\Microsoft\Signatures'WIN 7 - C:\Users\stevea\<Current User Profile>\Roaming\Microsoft\SignaturesUserSigRoot = CUAppPath & "Microsoft\Signatures"MasterSigRoot = MyPath & "SigMaster"MasterSigName = "sig1"'--------------------------------------------------------------------------' Query for inital user details'--------------------------------------------------------------------------UserName = UsrName()ComputerName = CompName()UserDomain = Domain()
'--------------------------------------------------------------------------'Create log file & write header information'--------------------------------------------------------------------------Call CreateTxtFile(LogFile, False)Call WriteLine(LogFile, "###############################################################", False)Call WriteLine(LogFile, "Outlook Signature Process Started @ " & Now, False)Call WriteLine(LogFile,"Starting Outlook Signature Process On " & ComputerName & " for user " & UserName & " in " & UserDomain &" domain.", False) Call WriteLine(LogFile, "###############################################################", False)
'--------------------------------------------------------------------------' Query active directory for user account data'--------------------------------------------------------------------------Call WriteLine(LogFile, "Started Reading User Data from Active Directory @ " & Now, False)Call WriteLine(LogFile, "----------------------------------------", False)'Users distinguished name is needed to query active directoryUsrDN = GetUserDN(UserName, UserDomain)'Collect data from active directory using AD property functionNAME = ADProperty("DisplayName", UsrDN)TITLE = ADProperty("Title", UsrDN)'External phone numberEXTERNALPHONE = ADProperty("telephoneNumber", UsrDN)'Internal extension numberINTERNALPHONE = ADProperty("pager", UsrDN)MOBILEPHONE = ADProperty("mobile", UsrDN)FAX = ADProperty("facsimileTelephoneNumber", UsrDN)DESCRIPTION = ADProperty("Description", UsrDN)OFFICE = ADProperty("physicalDeliveryOfficeName", UsrDN)DEPARTMENT = ADProperty("Department", UsrDN)COMPANY = ADProperty("company", UsrDN)EMAIL = LCase(ADProperty("mail", UsrDN))WWW = LCase(ADProperty("wWWHomePage", UsrDN))'Address details'NOTE:'Active directory stores each line of the users street property with a caridge retun (vbcrlf).'This script assumes that each line of street should be on a seperate line of the Outlook SignatureSTREET = ADProperty("streetAddress", UsrDN)POBOX = ADProperty("postOfficeBox", UsrDN)CITY = ADProperty("l", UsrDN)STATE = ADProperty("st", UsrDN)POSTCODE = ADProperty("postalCode", UsrDN)COUNTRY = ADProperty("co", UsrDN)
'--------------------------------------------------------------------------'Verify some values are correct and adjust if required'--------------------------------------------------------------------------'Web address'Test if user account properties includes web addressIf Len(WWW) = 0 Then 'If not then use the default web address if set in this script. 'Otherwise not web address will be included If CompanyWeb <> "" Then WWW = LCase(CompanyWeb) End IfEnd If'Company name'Test if user account properties includes company nameIf Len(COMPANY) = 0 Then If CompanyName <> "" Then COMPANY = CompanyName End IfEnd If
'--------------------------------------------------------------------------'Write the collected data to the log file'--------------------------------------------------------------------------Call WriteLine(LogFile, vbTab & "USER NAME: " & UserName, False)Call WriteLine(LogFile, vbTab & "USER DOMAIN: " & UserDomain, False)Call WriteLine(LogFile, vbTab & "USER DN: " & UsrDN, False)Call WriteLine(LogFile, vbTab & "COMPUTER NAME: " & ComputerName, False)Call WriteLine(LogFile, vbTab & "NAME: " & NAME, False)Call WriteLine(LogFile, vbTab & "TITLE: " & TITLE, False)Call WriteLine(LogFile, vbTab & "EXTERNALPHONE: " & EXTERNALPHONE, False)Call WriteLine(LogFile, vbTab & "INTERNALPHONE: " & INTERNALPHONE, False)Call WriteLine(LogFile, vbTab & "MOBILEPHONE: " & MOBILEPHONE, False)Call WriteLine(LogFile, vbTab & "FAX: " & FAX, False)Call WriteLine(LogFile, vbTab & "DESCRIPTION: " & DESCRIPTION, False)Call WriteLine(LogFile, vbTab & "OFFICE: " & OFFICE, False)Call WriteLine(LogFile, vbTab & "DEPARTMENT: " & DEPARTMENT, False)Call WriteLine(LogFile, vbTab & "COMPANY: " & COMPANY, False)Call WriteLine(LogFile, vbTab & "EMAIL: " & EMAIL, False)Call WriteLine(LogFile, vbTab & "WEB SITE: " & WWW, False)'User address details!Call WriteLine(LogFile, vbTab & "STREET: " & REPLACE(STREET, vbCrLf, ", "), False)Call WriteLine(LogFile, vbTab & "POBOX: " & POBOX, False)Call WriteLine(LogFile, vbTab & "CITY: " & CITY , False)Call WriteLine(LogFile, vbTab & "STATE: " & STATE , False)Call WriteLine(LogFile, vbTab & "POSTCODE: " & POSTCODE , False)Call WriteLine(LogFile, vbTab & "COUNTRY: " & COUNTRY , False)Call WriteLine(LogFile, "----------------------------------------", False)Call WriteLine(LogFile, "Completed Reading User Data from Active Directory @ " & Now, False)'--------------------------------------------------------------------------'Add the additional formatting to relavent values'--------------------------------------------------------------------------If Len(EXTERNALPHONE) <> 0 Then EXTERNALPHONE = "T: " & trim(EXTERNALPHONE)End IfIf Len(INTERNALPHONE) <> 0 Then INTERNALPHONE = "T: " & trim(INTERNALPHONE)End IfIf Len(FAX) <> 0 Then FAX = "F: " & trim(FAX)End IfIf Len(EMAIL) <> 0 Then EMAIL = "E: " & trim(EMAIL)End IfIf Len(WWW) <> 0 Then WWW = "W: " & trim(WWW)End IfIf Len(MOBILEPHONE) <> 0 Then MOBILEPHONE = "M: " & Trim(MOBILEPHONE)End IfIf Len(POBOX) <> 0 Then POBOX = "PO BOX " & Trim(POBOX)End If
'--------------------------------------------------------------------------'Verify destination user signature folder is present'--------------------------------------------------------------------------'XP - C:\Documents and Settings\<Current User Profile>\Application Data\Microsoft\Signatures'WIN 7 - C:\Users\stevea\<Current User Profile>\Roaming\Microsoft\SignaturesIf Not FolderExists(UserSigRoot) Then 'Create folder Call WriteLine(LogFile, "Creating Folder: " & UserSigRoot, False) Call CreateFolder(UserSigRoot)End If
'--------------------------------------------------------------------------' Generate the 3 signature files'--------------------------------------------------------------------------' An Outlook signature is actually 3 files for each type of email format' HTML' RTF (Rich Text Format)' PLAIN TEXT'' The layout for my signatures is 3 columns which can be of variable length & width' I also include a logo (image) in the HTML & RTF versions of the signature' So the collected user data is loaded into 3 seperate arrays, 1 for each column' Each row of the array is then padded with spaces to make each column the same width' Finally the values are read from the array and then ' the 3 files are created and written to the users profile
' To make things a bit easier I use a master template which contains a place holder for each column' You could actually generate all 3 files completely from within the script' But you won't be able to embed any images into the RTF :-(' and you will have to write out the whole of the HTM & RTF file from scratch from within the script!
'--------------------------------------------------------------------------' Load master templates into RAM from master template location'--------------------------------------------------------------------------'Verify source location'<Domain Controller>\Netlogon\SigMasterIf FolderExists(MasterSigRoot) Then 'Verify the master files are present If FileExists(MasterSigRoot& "\" & MasterSigName & ".rtf") And FileExists(MasterSigRoot& "\" & MasterSigName & ".htm") Then 'Read source files into strings Call WriteLine(LogFile, "Read master signature files into memory and update @ " & Now(), False) 'NOTE: 'The text file is created completely in memory with no template file Call WriteLine(LogFile, MasterSigRoot& "\" & MasterSigName & ".rtf", False) strRTF = File2String(MasterSigRoot& "\" & MasterSigName & ".rtf", False) Call WriteLine(LogFile, MasterSigRoot& "\" & MasterSigName & ".htm", False) strHTM = File2String(MasterSigRoot& "\" & MasterSigName & ".htm", False) Else 'Unable to locate the source files, this is BAD! Call WriteLine(LogFile, "CRITICAL ERROR: Unable to locate htm & rtf source master files", False) End If Call WriteLine(LogFile, "Master signature files loaded @ " & Now(), False)Else 'Unable to locate the master folder! Call WriteLine(LogFile, "CRITICAL ERROR: Unable to locate Folder: " & MasterSigRoot & " is missing!", False) WScript.Quit(97)End If
'--------------------------------------------------------------------------' Verify place holders are present'--------------------------------------------------------------------------'This is a basic check to ensure the master signatures will not'crash this script by being modified incorrectly'Place holders:'SIGCOMPANYSIG'SIGCOLUMN1SIG'SIGCOLUMN2SIG'SIGCOLUMN3SIG'SIGENVIROPRINTSIG
'CROTICAL NOTE!!!'If any place holders are added or removed these checks below need to be updated
'The company name is not icluded as a place holder in the RTF file'But it is used as the title element of the HTM file so we check it is present in the HTM master templateIf InStr(UCASE(strHTM), UCase("SIGCOMPANYSIG")) = 0 Then 'Place holder missing from master template Call WriteLine(LogFile, "CRITICAL ERROR: Missing place holder in HTML master file!", False) Call QuitScriptErr()End IfIf InStr(UCASE(strRTF), UCase("SIGCOLUMN1SIG")) = 0 Then 'Place holder missing from master template Call WriteLine(LogFile, "CRITICAL ERROR: Missing place holder in RTF master file!", False) Call QuitScriptErr()End IfIf InStr(UCASE(strHTM), UCase("SIGCOLUMN1SIG")) = 0 Then 'Place holder missing from master template Call WriteLine(LogFile, "CRITICAL ERROR: Missing place holder in HTML master file!", False) Call QuitScriptErr()End IfIf InStr(UCASE(strRTF), UCase("SIGCOLUMN2SIG")) = 0 Then 'Place holder missing from master template Call WriteLine(LogFile, "CRITICAL ERROR: Missing place holder in RTF master file!", False) Call QuitScriptErr()End IfIf InStr(UCASE(strHTM), UCase("SIGCOLUMN2SIG")) = 0 Then 'Place holder missing from master template Call WriteLine(LogFile, "CRITICAL ERROR: Missing place holder in HTML master file!", False) Call QuitScriptErr()End IfIf InStr(UCASE(strRTF), UCase("SIGCOLUMN3SIG")) = 0 Then 'Place holder missing from master template Call WriteLine(LogFile, "CRITICAL ERROR: Missing place holder in RTF master file!", False) Call QuitScriptErr()End IfIf InStr(UCASE(strHTM), UCase("SIGCOLUMN3SIG")) = 0 Then 'Place holder missing from master template Call WriteLine(LogFile, "CRITICAL ERROR: Missing place holder in HTML master file!", False) Call QuitScriptErr()End IfIf InStr(UCASE(strRTF), UCase("SIGENVIROPRINTSIG")) = 0 Then 'Place holder missing from master template Call WriteLine(LogFile, "CRITICAL ERROR: Missing place holder in RTF master file!", False) Call QuitScriptErr()End IfIf InStr(UCASE(strHTM), UCase("SIGENVIROPRINTSIG")) = 0 Then 'Place holder missing from master template Call WriteLine(LogFile, "CRITICAL ERROR: Missing place holder in HTML master file!", False) Call QuitScriptErr()End If
'--------------------------------------------------------------------------' Load collected data in to each coloumn array'--------------------------------------------------------------------------' NOTE:' This will determine which properties from the users account go in which' column and also what order within the column''| Column 1 | Column 2 | Column 3 | ''Joe Boo : T: 01 234 5678 : Local Lab Limited'Senior Web Designer : M: 111 222 3333 : Customer Support ' : F: 01 987 6543 : PO BOX 1234 ' : E: joe.boo@lab.local : Waddington ' : W: www.lab.local : C123 ' : : Antarctica '--------------------------------------------------------------------------Call WriteLine(LogFile, "Loading data into Column arrays @ " & Now(), False)'Column1If NAME <> "" Then Call add2array(arrColumn1, NAME)End IfIf TITLE <> "" Then Call add2array(arrColumn1, TITLE)End If'Column2If EXTERNALPHONE <> "" Then Call add2array(arrColumn2, EXTERNALPHONE)End IfIf MOBILEPHONE <> "" Then Call add2array(arrColumn2, MOBILEPHONE)End IfIf FAX <> "" Then Call add2array(arrColumn2, FAX)End IfIf EMAIL <> "" Then Call add2array(arrColumn2, EMAIL)End IfIf WWW <> "" Then Call add2array(arrColumn2, WWW)End If'Column3If COMPANY <> "" Then Call add2array(arrColumn3, COMPANY)End IfIf DEPARTMENT <> "" Then Call add2array(arrColumn3, DEPARTMENT)End If'Address details'NOTE:'PO BOX will over ride street in this scriptIf POBOX <> "" Then Call WriteLine(LogFile, "PO BOX defined for user, over riding street details", False) Call add2array(arrColumn3, POBOX)Else 'Split street and load into the array If STREET <> "" Then 'Load street details into a temporary array arrStreet = Split(STREET, vbCrLf) If NotEmpty(arrStreet) Then For StreetLoop = LBound(arrStreet) To UBound(arrStreet) 'Load into the column array Call add2array(arrColumn3, arrStreet(StreetLoop)) Next End If End IfEnd IfCall add2array(arrColumn3, CITY)Call add2array(arrColumn3, STATE)Call add2array(arrColumn3, POSTCODE)Call add2array(arrColumn3, COUNTRY)'We now have 3 arrays with the content of each column of the signature
'--------------------------------------------------------------------------' Update templates with the collected data'--------------------------------------------------------------------------'HTML SignaturestrHTM = arr2String(arrColumn1, strHTM, "SIGCOLUMN1SIG")strHTM = arr2String(arrColumn2, strHTM, "SIGCOLUMN2SIG")strHTM = arr2String(arrColumn3, strHTM, "SIGCOLUMN3SIG")'We also need to do a find and replace on company name for the HTM fileIf COMPANY <> "" Then strHTM = Replace(strHTM, "SIGCOMPANYSIG", COMPANY, 1, -1, 1)End If'Correct the path to the image for the HTM signature'src="New_files/image001.gif"'should be:'src="<SIGNAME>_files/image001.gif"strHTM = Replace(strHTM, MasterSigName & "_files/", SigName & "_files/", 1, -1, 1)'RTF SignaturestrRTF = arr2String(arrColumn1, strRTF, "SIGCOLUMN1SIG")strRTF = arr2String(arrColumn2, strRTF, "SIGCOLUMN2SIG")strRTF = arr2String(arrColumn3, strRTF, "SIGCOLUMN3SIG")
'--------------------------------------------------------------------------'Copy addtional folder (<signature>_files) to users signatures profile'--------------------------------------------------------------------------Call WriteLine(LogFile, "Copying addtional signature folder from " & MasterSigRoot & "\" & MasterSigName & "_files" & " to " & UserSigRoot & "\" & SigName & "_files", False)Call CopyFolder(MasterSigRoot& "\" & MasterSigName & "_files", UserSigRoot & "\" & SigName & "_files")
'--------------------------------------------------------------------------' Add optional environmental print message to signature files'--------------------------------------------------------------------------If EnviroPrint Then Call WriteLine(LogFile, "NOTE: Environmental Print message enabled.", False) Call WriteLine(LogFile, "Environmental Print message will be added to the bottom of the signature files", False) 'Replace place holder with HTM code 'SIGENVIROPRINTSIG '<BR><IMG title="Please consider the environment before printing"alt="Please consider the environment before printing" hspace=0 src="sig1_files/thinkbeforeprinting.gif" align=baseline border=0> htmEnviroPrint = "<BR>" & vbCrLf & "<IMG title=" & chr(34) & msgEnviroPrint &_ chr(34) & " alt=" & chr(34) & msgEnviroPrint & Chr(34) & " hspace=0 src=" &_ chr(34) & SigName & "_files/" & EnviroPrintFile & Chr(34) & " align=baseline border=0>" strHTM = Replace(strHTM, "SIGENVIROPRINTSIG", htmEnviroPrint, 1, -1, 1) '**** 'Replace place holder with RTF code rtfEnviroPrint = File2String(MasterSigRoot & "\" & rtfEnviroPrintExtract, False) strRTF = Replace(strRTF, "SIGENVIROPRINTSIG", rtfEnviroPrint, 1, -1, 1)Else Call WriteLine(LogFile, "Environmental Print message will NOT be added to the bottom of the signature files", False) 'Delete print image from signature _files folder DeleteFile(UserSigRoot & "\" & SigName & "_files\" & EnviroPrintFile) 'Remove placeholder from HTM signature string strHTM = Replace(strHTM, "SIGENVIROPRINTSIG", "", 1, -1, 1) 'Remove placeholder from RTF signature string strRTF = Replace(strRTF, "SIGENVIROPRINTSIG", "", 1, -1, 1)End If
'--------------------------------------------------------------------------' Write the HTM & RTF strings out to files.' NOTE:' As part of this we also name the files to match the required name of the' signature file we want to see in Outlook (SigName Variable).'--------------------------------------------------------------------------Call WriteLine(LogFile, "HTML Signature File: " & UserSigRoot & "\" & SigName & ".htm", False)Call String2File(strHTM, UserSigRoot & "\" & SigName & ".htm", False)Call WriteLine(LogFile, "RIch Text Format Signature File: " & UserSigRoot & "\" & SigName & ".rtf", False)Call String2File(strRTF, UserSigRoot & "\" & SigName & ".rtf", False)
'--------------------------------------------------------------------------' Now create the text version of the signature file from the collected data'--------------------------------------------------------------------------Call WriteLine(LogFile, "Text Signature File: " & UserSigRoot & "\" & SigName & ".txt", False)'*****' Add enviromental print option to the function Call Arrays2TXTSig(arrColumn1, arrColumn2, arrColumn3, UserSigRoot & "\" & SigName & ".txt", EnviroPrint, msgEnviroPrint)
'--------------------------------------------------------------------------' Set the default Outlook signature'--------------------------------------------------------------------------If DefaultSig Then Call WriteLine(LogFile, "Configuring Outlook to use " & SigName & " as default signature @ " & Now(), False) 'NOTE: This will only work if an Users Outlook profile is already present! Call SetOutlookSig(SigName, LogFile)End If
'--------------------------------------------------------------------------'Write log file tail'--------------------------------------------------------------------------Call WriteLine(LogFile, "###############################################################", False)Call WriteLine(LogFile, "Outlook Signature Process Completed @ " & Now, False)Call WriteLine(LogFile, "###############################################################", False)'##########################################################################' End Of Script'##########################################################################
'##########################################################################' Sub Procedures'##########################################################################Sub CreateTxtFile(File, UNICODE)'--------------------------------------------------------------------------' Create Text file with overwrite'-------------------------------------------------------------------------- Dim objFSO 'File System object Dim objFile 'Text File object Set objFSO = CreateObject("Scripting.FileSystemObject") Set objFile = objFSO.CreateTextFile(File, True, UNICODE) 'If we can't create the file then exit with error (99) If Err.Number <> 0 Then Set objFSO = Nothing 'Quit with exit code 99 (failure) WScript.quit(99) End If 'Clean up Set objFSO = NothingEnd Sub
Sub WriteLine(File, Str, UNICODE)'--------------------------------------------------------------------------' Write line to file (append) or quit'-------------------------------------------------------------------------- If FileExists(File) Then Dim objFSO Dim objFile Set objFSO = CreateObject("Scripting.FileSystemObject") If UNICODE Then Set objFile = objFSO.OpenTextFile(File, ForAppending, False, -1) Else Set objFile = objFSO.OpenTextFile(File, ForAppending) End If objFile.WriteLine(Str) objFile.Close Else 'Unable to find file to write to 'Quit with exit code 98 (failure) WScript.quit(98) End If 'Clean up Set objFSO = NothingEnd Sub
Sub CreateFolder(Folder)'--------------------------------------------------------------------------' Create a folder'-------------------------------------------------------------------------- 'NOTE: Will only create a single folder NOT the full path 'So the parent folder MUST already exist Dim objFSO Set objFSO = CreateObject("Scripting.FileSystemObject") objFSO.CreateFolder Folder 'Clean up Set objFSO = NothingEnd Sub
Sub CopyFolder(Src, Dest)'--------------------------------------------------------------------------' Create a copy of a folder'-------------------------------------------------------------------------- 'NOTE: Full path to source and destination is required. Dim objFSO Set objFSO = CreateObject("Scripting.FileSystemObject") objFSO.CopyFolder Src, Dest, TRUE 'Clean up Set objFSO = NothingEnd Sub
Sub DeleteFile(File)'---------------------------------------------' Delete a file, if it exists'--------------------------------------------- 'Check we have a file to delete If FileExists(File) Then Dim objFSO Set objFSO = CreateObject("Scripting.FileSystemObject") objFSO.DeleteFile File 'Clean up Set objFSO = Nothing End IfEnd Sub
Sub String2File(Str, File, UNICODE)'--------------------------------------------------------------------------' Create a text file from a string value'-------------------------------------------------------------------------- Dim objFSO Dim objTextFile 'Create text file if NOT present If Not FileExists(File) Then 'Create text file Call CreateTxtFile(File, UNICODE) End If 'Write string to file Set objFSO = CreateObject("Scripting.FileSystemObject") If UNICODE Then Set objTextFile = objFSO.OpenTextFile (File, ForWriting, False,-1) Else Set objTextFile = objFSO.OpenTextFile (File, ForWriting, False) End If objTextFile.Write Str objTextFile.Close 'Clean up Set objFSO = NothingEnd Sub
Sub Arrays2TXTSig(arr1, arr2, arr3, SigFileName, EnviroPrint, msgEnviroPrint)'--------------------------------------------------------------------------' Create a 3 column text signature file from 3 arrays'-------------------------------------------------------------------------- 'The text signature is built in memory from scratch 'So we need to pad out the structure for good formating in Outlook 'The signature is made up of 3 arrays that can be of variable widths & lengths 'For example: ' | Column 1 | Column 2 | Column 3 | ' | | | | '0 Joe Boo : T: 01 234 5678 : Local Lab Limited| '1 Senior Web Designer : M: 111 222 3333 : Customer Support | '2 | : F: 01 987 6543 : PO BOX 1234 | '3 | : E: joe.boo@lab.local : Waddington | '4 | : W: www.lab.local : C123 | '5 | : : Antarctica | ' |xxxxxxxx 19 xxxxxxx|xxxxxxxx 22 xxxxxxxxxx|xxxxxxx 18 xxxxxxx| ' | array1 (arr1) | array2 (arr2) | array3 (arr3) | 'So that we have a properly formatted text signature all arrays need to be resized to the length 'of the largest array out of the 3 'So in this example array1 & array3 will be resized to the same upper boundary(unbound) as array 2
'Each element (string) in the array will also be of a variable length 'Again to have a properly formatted signature we need to make each element(string) in each array 'the same width by adding additional spaces to the elements (string) in that array 'So we scan through each array and find the longest string within it 'We then add spaces to every other element in the array (including empty ones) to ensure they are 'all the same width 'The procedure can also add an optional environmental print message at the end (EnviroPrint = TRUE)
Dim MaxCount 'Ubound count of array with the most elements Dim strTXT 'Final output string for text signature Dim Pad 'Count of number of spaces we need to pad each element with Dim ArrayLoop 'Loop count for array '-------------------------------------------------------------------------- ' Find array with largest number of elements '-------------------------------------------------------------------------- MaxCount = UBound(arr3) If UBound(arr2) > MaxCount Then MaxCount = UBound(arr2) End If If UBound(arr1) > MaxCount Then MaxCount = UBound(arr1) End If 'Resize all arrays to match maximum element count ReDim Preserve arr1(MaxCount) ReDim Preserve arr2(MaxCount) ReDim Preserve arr3(MaxCount) '-------------------------------------------------------------------------- ' Calculate space padding for each array '-------------------------------------------------------------------------- 'Array 1 Pad = MaxLength(arr1) 'pad out the array For ArrayLoop = LBound(arr1) To UBound(arr1) arr1(ArrayLoop) = arr1(ArrayLoop) & Space(Pad - Len(arr1(ArrayLoop))) Next 'Array 2 Pad = MaxLength(arr2) 'pad out the array For ArrayLoop = LBound(arr2) To UBound(arr2) arr2(ArrayLoop) = arr2(ArrayLoop) & Space(Pad - Len(arr2(ArrayLoop))) Next 'Array 3 Pad = MaxLength(arr3) 'pad out the array For ArrayLoop = LBound(arr3) To UBound(arr3) arr3(ArrayLoop) = arr3(ArrayLoop) & Space(Pad - Len(arr3(ArrayLoop))) Next '-------------------------------------------------------------------------- ' Combine the completed arrays (columns) into a finished signature '-------------------------------------------------------------------------- strTXT = "" For ArrayLoop = LBound(arr3) To UBound(arr3) strTXT = strTXT & arr1(ArrayLoop) & " : " & arr2(ArrayLoop) & " : " & arr3(ArrayLoop) & VbCrLf Next 'Add optional enviromental print message If EnviroPrint Then strTXT = strTXT & vbCrLf & msgEnviroPrint End If '-------------------------------------------------------------------------- ' Write updated string to users signature folder '-------------------------------------------------------------------------- Call String2File(strTXT, SigFileName , True)End Sub
Sub QuitScriptErr '-------------------------------------------------------------------------- ' Quit script and write log file tail with error '-------------------------------------------------------------------------- Call WriteLine(LogFile, "###############################################################", False) Call WriteLine(LogFile, "Outlook Signature Process Failed @ " & Now, False) Call WriteLine(LogFile, "###############################################################", False) 'Exit with error code 1 WScript.Quit(1)End Sub
Sub SetOutlookSig(strSig, LogFile) Dim arrSig 'Array holiding unicode conversion of signature name Dim objReg 'Local Registry Object Dim strDefaultProfile 'Name of users Outlook default profile Dim arrReg 'Sub profile value that we need to update Dim arrLoop 'Array Loop Dim strProfile 'String hold sub profile registry key we need to update Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv") 'NOTE: 'The values are stored an unicode binary values within the registry. 'A conversion needs to be done on the string to store it in the registry in the correct format. 'The registry provier requires a binary value to be held in an array that it can then write to the registry. 'Convert the signature name passed to this string (strSig) into a unicode array. arrSig = String2ByteArray(strSig, True) '---------------------------------------- ' Check we have a default profile defined! '---------------------------------------- 'Read default outlook profile value from the registry '[HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\Outlook] objReg.GetStringValue HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles", "DefaultProfile", strDefaultProfile If Not IsNUll(strDefaultProfile) Then Call WriteLine(LogFile, "Default Outlook Profile for " & UserName & " set to: " & strDefaultProfile, False) 'Test there is an actual profile to update arrReg = GetRegBinValue(HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\" & strDefaultProfile & "\9375CFF0413111d3B88A00104B2A6676", "{ED475418-B0D6-11D2-8C3B-00104B2A6676}") '02 00 00 00 'WARNING: ' If Outlook has no valid email profile then the regsitry key {ED475418-B0D6-11D2-8C3B-00104B2A6676} ' will have a zero-length binary value ' The array will be empty! ' This will result in strProfile being any empty string below 'We can test for this do something about it 'Test if we got a valid return from the registry or not If IsArray(arrReg) Then 'Build up the subkey string from the array we have just read in from the registry 'Array is: '(0) 2 '(1) 0 '(3) 0 '(4) 0 'Subkey will be 00000002 'Read the array into a string backwards For arrLoop = uBound(arrReg) To lBound(arrReg) Step -1 'Find the correct profile to upate from reg value '{ED475418-B0D6-11D2-8C3B-00104B2A6676} '00000001 '00000002 '00000007 '00000008 strProfile = strProfile & arrReg(arrLoop) Next 'Test we haven't returned an empty value If Len(strProfile) > 0 Then Call WriteLine(LogFile, "Found valid Outlook Sub Profile for " & UserName, False) 'GetRegBinValue will return single 0 and it needs to be double 'We also need to 'reverse' the value 'For example: '2000 needs to be 00000002 strProfile = String(8-Len(strProfile), "0") & strProfile Call WriteLine(LogFile, "Identified valid Outlook Sub Profile as " & strProfile, False) '---------------------------------------- ' Update registry with new signature values '---------------------------------------- 'HKEY_CURRENT_USERSoftware\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\Outlook\9375CFF0413111d3B88A00104B2A6676\00000002" 'New Signature 'Reply-Forward Signature Call WriteLine(LogFile, "Updating registry @ " & Now(), False) Call SetRegValue(HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\" & strDefaultProfile & "\9375CFF0413111d3B88A00104B2A6676" & "\" & strProfile, "New Signature", arrSig) Call SetRegValue(HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\" & strDefaultProfile & "\9375CFF0413111d3B88A00104B2A6676" & "\" & strProfile, "Reply-Forward Signature", arrSig) '---------------------------------------- ' Verify Registry Keys have been set '---------------------------------------- Dim arrTestReg arrTestReg = GetRegBinValue(HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\" & strDefaultProfile & "\9375CFF0413111d3B88A00104B2A6676" & "\" & strProfile, "New Signature") If IsNull(arrTestReg) Then Call WriteLine(LogFile, "CRITICAL ERROR: Failed to validate registry key - New Signature", False) Else Call WriteLine(LogFile, "Successfully validated registry key is present - New Signature", False) End If arrTestReg = GetRegBinValue(HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\" & strDefaultProfile & "\9375CFF0413111d3B88A00104B2A6676" & "\" & strProfile, "Reply-Forward Signature") If IsNull(arrTestReg) Then '### CRITIAL ERROR ### Call WriteLine(LogFile, "CRITICAL ERROR: Failed to validate registry key - Reply-Forward Signature", False) Else Call WriteLine(LogFile, "Successfully validated registry key is present- Reply-Forward Signature", False) End If Else 'strProfile was empty 'This is probably because there was no email profile defined in Outlook. Call WriteLine(LogFile, "Unable to find valid Outlook Sub Profile for " & UserName, False) Call WriteLine(LogFile, "Verify " & UserName & " has a valid Outlook profile", False) End If Else 'No Outlook profile present! Call WriteLine(LogFile, "Unable to find valid Outlook Sub Profile for " & UserName, False) Call WriteLine(LogFile, "Verify " & UserName & " has a valid Outlook profile", False) End If Else 'No default profile could be found Call WriteLine(LogFile, "No default Outlook profile could be found for: " & UserName & " @ " & NOW(), False) Call WriteLine(LogFile, "Verify " & UserName & " has a valid Outlook profile", False) End If 'clean Up Set objReg = NothingEnd Sub
Sub SetRegValue(RegRoot, RegPath, RegValue, arr) '-------------------------------------------------------------------------- ' Write a binary registry value (binary value held in an array) '-------------------------------------------------------------------------- 'Write details to logfile: Call WriteLine(LogFile, "Writing to registry.", False) Call WriteLine(LogFile, "--------------------------------------------", False) Call WriteLine(LogFile, vbTab & "RegRoot: " & RegRoot, False) Call WriteLine(LogFile, vbTab & "RegPath: " & RegPath, False) Call WriteLine(LogFile, vbTab & "RegValue: " & RegValue, False) Dim Return Dim strComputer Dim objRegistry strComputer = "." Set objRegistry = GetObject("winmgmts:\\" & strComputer & "\root\default:StdRegProv") Return = objRegistry.SetBinaryValue( RegRoot, RegPath, RegValue, arr) If (Return = 0) And (Err.Number = 0) Then 'Set registry key with no problems Call WriteLine(LogFile, vbTab & "SetBinaryKey Return = 0", False) Else 'ERROR! - Unable to set registry key Call WriteLine(LogFile, vbTab & "ERROR: Err.number=" & Err.Number, False) Call WriteLine(LogFile, vbTab & "ERROR: Return=" & Return, False) End If Set objRegistry = NothingEnd Sub
'##########################################################################'Functions'##########################################################################Function UsrName()'--------------------------------------------------------------------------' Return Username'-------------------------------------------------------------------------- Dim objNet 'Scripting network object Dim sUser 'Current users logon name Dim startTime 'Time this function was called ' Network object Set objNet = CreateObject("WScript.Network") ' Get the user name. On Windows 9x, the user may not be logged ' on when the script starts running; keep checking every 1/2 a ' second until they are logged on. sUser = objNet.UserName startTime = Now Do While sUser = "" 'Quit script if we have been waiting more than 30 seconds If DateDiff("s", startTime, Now) > 30 Then Wscript.Quit sUser = objNet.UserName If sUser = "" Then 'Pause before we loop round again Wscript.Sleep 500 End If Loop UsrName = sUser 'Clean Up Set objNet = NothingEnd Function
Function Domain()'--------------------------------------------------------------------------' Current Users domain'-------------------------------------------------------------------------- Dim objUser 'Create active directory object for current logged on user Set objUser = CreateObject("WScript.Network") 'Get domain of current user. Domain = objUser.UserDomain 'Clean Up Set objUser = NothingEnd Function
Function CompName()'--------------------------------------------------------------------------' Return Computer Name'-------------------------------------------------------------------------- Dim objNet ' Network object Set objNet = CreateObject("WScript.Network") CompName = objNet.ComputerName 'Clean Up Set objNet = NothingEnd Function
Function GetUserDN(ByVal UN, ByVal DN)'----------------------------------------'Get the distinguished name of the current user.'---------------------------------------- Dim ObjTrans Dim strUserDN
Set ObjTrans = CreateObject("NameTranslate") objTrans.init 1, DN objTrans.set 3, DN & "\" & UN strUserDN = objTrans.Get(1) GetUserDN = strUserDN 'Clean Up Set ObjTrans = NothingEnd Function
Function ADProperty(Prop, UsrDN)'----------------------------------------'Read a property from Active Directory'---------------------------------------- Dim objUser Dim domainName Dim objLDAPUser
'Create active directory object supplied User Distiguished name ' For Exmaple: CN=Joe Boo,OU=Users,OU=LAB,DC=lab,DC=local Set objLDAPUser = GetObject("LDAP://" & UsrDN) On Error Resume Next 'Try and read users property from active directory. ADProperty = objLDAPUser.Get(Prop) If Err.Number <> 0 Then 'If we get an error set property to BLANK. ADProperty = "" End If On Error GoTo 0 'Remove white space from each end of the variable. ADProperty = Trim(ADProperty) 'Clean Up Set objLDAPUser = NothingEnd Function
Function FileExists(File)'---------------------------------------------' File exists - returns true/false '--------------------------------------------- Dim objFSO Set objFSO = CreateObject("Scripting.FileSystemObject") FileExists = objFSO.FileExists(File) 'Clean Up Set objFSO = NothingEnd Function
Function FolderExists(FolderName)'---------------------------------------------' Folder exists - returns true/false '--------------------------------------------- Dim objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject") FolderExists = objFSO.FolderExists(FolderName) 'Clean Up Set objFSO = NothingEnd Function
Function File2String(File, UNICODE)'--------------------------------------------------------------------------' Read a complete file into a string'-------------------------------------------------------------------------- Dim objFSO Dim objTextFile If FileExists(File) Then Set objFSO = CreateObject("Scripting.FileSystemObject") If UNICODE Then Set objTextFile = objFSO.OpenTextFile (File, ForReading, False,-1) Else Set objTextFile = objFSO.OpenTextFile (File, ForReading, False) End If File2String = objTextFile.ReadAll objTextFile.Close End If 'Clean Up Set objFSO = NothingEnd Function
Function add2array(arr, Str)'--------------------------------------------------------------------------' Add value to an array and return the modified array object back'-------------------------------------------------------------------------- ' NOTE: ' If the array is empty or not created then create it and add the 1st string If trim(UCase(Str)) <> "" Then If trim(UCase(Str)) <> "NULL" Then 'Test for empty / NULL array. If NotEmpty(arr) Then 'Extend the array and add the string ReDim Preserve arr(UBound(arr)+1) arr(UBound(arr)) = Str Else '1st element of array ReDim arr(0) arr(0) = Str End If Else 'Value is empty so do nothing! End If Else 'Value is empty so do nothing! End If 'Return the modifed array back add2array = arrEnd Function
Function NotEmpty(arr)'--------------------------------------------------------------------------' Test if an array is empty or not.'-------------------------------------------------------------------------- Dim arrCount Err.Clear On Error Resume Next arrCount = UBound(arr) If (Err.Number = 0) And (arrCount> -1) Then NotEmpty = True End If On Error GoTo 0End Function
Function arr2String(arr, str, strReplace)'--------------------------------------------------------------------------' Do a repalce within a string with the content of the array'--------------------------------------------------------------------------' NOTE:' We also need to terminate each line based on format type (HTM or RTF)
Dim LineEnd 'Line end terminator for HTM or RTF Dim LineEnd2 'Other line terminator for HTM ir RTF Dim strColumn 'String holding the column content with line terminators Dim ArrLoop 'Loop count for array LineEnd = "" 'Default Line end termintor (BLANK) LineEnd2 = "" 'Default Line end termintor (BLANK) 'Test the string for format type 'HTML If InStr(1,UCASE(str), UCase("<HTML>"), 1) Then LineEnd = "<br>" & vbCrLf LineEnd2 = vbCrLf End If 'RTF If InStr(1,UCASE(str), UCase("\rtf1\"), 1) Then LineEnd = "\line " End If 'Loop round array and added each element to the string For ArrLoop = LBound(arr) To UBound(arr) If ArrLoop <> UBound(arr) Then strColumn = strColumn & arr(ArrLoop) & LineEnd Else strColumn = strColumn & arr(ArrLoop) & LineEnd2 End If Next arr2String = Replace(str, strReplace, strColumn, 1, 1)End Function
Function MaxLength(arr)'--------------------------------------------------------------------------' Find longest element in the array and return that length value.'-------------------------------------------------------------------------- Dim arrLoop 'Loop count for array Dim Length 'value of longest element in the array Length = 0 'Loop round the array and check the length of each element. For arrLoop = LBound(arr) To UBound(arr) If Len(arr(arrLoop)) > Length Then Length = Len(arr(arrLoop)) End If Next MaxLength = LengthEnd Function
Function String2ByteArray (Data, NeedNullTerminator)'--------------------------------------------------------------------------' Convert a regular string into a byte array that can be loaded into the registry'-------------------------------------------------------------------------- Dim strAll Dim intLen Dim arr Dim i strAll = String2Hex4(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 String2ByteArray = arrEnd Function
Function String2Hex4(Data)'--------------------------------------------------------------------------' Convert a regular string into it unicode cahracter codes'-------------------------------------------------------------------------- ' 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 Dim i Dim strChar Dim strTemp 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 String2Hex4 = strAllEnd Function
Function GetRegBinValue(RegRoot, RegPath, RegValue)'--------------------------------------------------------------------------' Read binary registry key into an array'-------------------------------------------------------------------------- Dim Return Dim strComputer Dim objRegistry strComputer = "." Set objRegistry = GetObject("winmgmts:\\" & strComputer & "\root\default:StdRegProv") objRegistry.GetBinaryValue RegRoot,RegPath,RegValue,Return If Not IsArray(Return) Then GetRegBinValue = Null Else GetRegBinValue = Return End If 'Clean Up Set objRegistry = NothingEnd Function
<message edited by ifnotisnull on Monday, January 30, 2012 7:10 PM>