The Script

I have posted the script below, I think wordpress screws the fromatting a bit and some lines may be wrapped. It looks like word press also removes all the tabs so all my nicly formatted script is now left justified.

You might be better off getting the zip file from my Google docs site. This also has the additional supporting signature template files used by this script.

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 file
Const ForWriting = 2 ‘/
‘Registry
Const HKEY_CURRENT_USER = &H80000001
‘————————————————————————-
‘ Declare variables
‘————————————————————————–
‘Log file
Dim objShell ‘Scripting shell object
Dim objFolder ‘Scripting folder object
Dim CUAppPath ‘Current users application data folder
Dim LogFile ‘Log file to write stuff to
Dim MyPath ‘Location this script is running from
‘Company details
Dim CompanyName ‘Name of the company
Dim CompanyWeb ‘Default company web site
‘Over ride address
Dim OverrideAddress ‘If this is set the active directory address will be ignored
‘User details
Dim UserDomain ‘Current users domain
Dim UserName ‘Current users logon name
Dim ComputerName ‘Name of computer this script is running on
Dim UsrDN ‘Users active directory distinguished name
‘User active directory account properties
Dim NAME ‘Display name
Dim TITLE ‘Title
Dim EXTERNALPHONE ‘Telephone number
Dim INTERNALPHONE ‘Pager
Dim FAX ‘Facsimile telephone number
Dim MOBILEPHONE ‘Mobile
Dim DESCRIPTION ‘Description
Dim OFFICE ‘Physical delivery office name
Dim DEPARTMENT ‘Department
Dim COMPANY ‘Company
Dim EMAIL ‘Mail
Dim WWW ‘www home page
‘User active directory address details
Dim STREET ‘Street address
Dim arrStreet ‘Temporary street array
Dim StreetLoop ‘Loop count for street array
Dim POBOX ‘Post office box
Dim CITY ‘l
Dim STATE ‘St
Dim POSTCODE ‘Postal code
Dim COUNTRY ‘Co
‘Signature files
Dim UserSigRoot ‘Path to current users signatures folder
Dim MasterSigRoot ‘Path to source master (template) signature folder (Netlogon share)
Dim MasterSigName ‘Name of the master (template) signature files
Dim strRTF ‘String to hold RTF template loaded into RAM
Dim strHTM ‘String to hold HTM template loaded into RAM
Dim arrColumn1 ‘Array to hold column 1 of signature content
Dim arrColumn2 ‘Array to hold column 2 of signature content
Dim arrColumn3 ‘Array to hold column 3 of signature content
Dim SigName ‘Name for signature in Outlook
‘Environmental printing message
http://thinkbeforeprinting.org
Dim EnviroPrint ‘Flag to indicate if this should be included or not
Dim EnviroPrintFile ‘Name of image file to be included HTM version
Dim msgEnviroPrint ‘Text message
Dim htmEnviroPrint ‘String with htm code for environmental print message
Dim rtfEnviroPrint ‘String with RTF code for environmental print message
Dim rtfEnviroPrintExtract ‘Extracted RTF code in a txt file ready for import
‘Force default Outlook signature
Dim DefaultSig ‘Force this signature to be set as the default in Outlook
‘————————————————————————-
‘ Set some values
‘————————————————————————-
‘NOTE:
‘These three values should be set to match your environment
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 print image / message will be tagged to the bottom of
‘the email signature
EnviroPrint = True ‘Set to False to disable this feature
EnviroPrintFile = “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 script
MyPath = Left(WScript.ScriptFullName, InstrRev(WScript.ScriptFullName, “\”))
‘XP – C:\Documents and Settings\<Current User Profile>\Application Data
‘WIN 7 – C:\Users\stevea\<Current User Profile>\Roaming
Set 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\Signatures
UserSigRoot = 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 directory
UsrDN = GetUserDN(UserName, UserDomain)
‘Collect data from active directory using AD property function
NAME = ADProperty(“DisplayName”, UsrDN)
TITLE = ADProperty(“Title”, UsrDN)
‘External phone number
EXTERNALPHONE = ADProperty(“telephoneNumber”, UsrDN)
‘Internal extension number
INTERNALPHONE = 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 Signature
STREET = 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 address
If Len(WWW) = 0 Then
‘If not then use the default web address if set in this script.
‘Otherwise no web address will be included
If CompanyWeb <> “” Then
WWW = LCase(CompanyWeb)
End If
End If
‘Company name
‘Test if user account properties includes company name
If Len(COMPANY) = 0 Then
If CompanyName <> “” Then
COMPANY = CompanyName
End If
End 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 If
If Len(INTERNALPHONE) <> 0 Then
INTERNALPHONE = “T: ” & trim(INTERNALPHONE)
End If
If Len(FAX) <> 0 Then
FAX = “F: ” & trim(FAX)
End If
If Len(EMAIL) <> 0 Then
EMAIL = “E: ” & trim(EMAIL)
End If
If Len(WWW) <> 0 Then
WWW = “W: ” & trim(WWW)
End If
If Len(MOBILEPHONE) <> 0 Then
MOBILEPHONE = “M: ” & Trim(MOBILEPHONE)
End If
If 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\Signatures
If 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\SigMaster
If 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
‘CRITICAL 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 template
If 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 If
If 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 If
If 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 If
If 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 If
If 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 If
If 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 If
If 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 If
If 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 If
If 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: http://www.lab.local : C123
‘ : : Antarctica
‘————————————————————————–
Call WriteLine(LogFile, “Loading data into Column arrays @ ” & Now(), False)
‘Column1
If NAME <> “” Then
Call add2array(arrColumn1, NAME)
End If
If TITLE <> “” Then
Call add2array(arrColumn1, TITLE)
End If
‘Column2
If EXTERNALPHONE <> “” Then
Call add2array(arrColumn2, EXTERNALPHONE)
End If
If MOBILEPHONE <> “” Then
Call add2array(arrColumn2, MOBILEPHONE)
End If
If FAX <> “” Then
Call add2array(arrColumn2, FAX)
End If
If EMAIL <> “” Then
Call add2array(arrColumn2, EMAIL)
End If
If WWW <> “” Then
Call add2array(arrColumn2, WWW)
End If
‘Column3
If COMPANY <> “” Then
Call add2array(arrColumn3, COMPANY)
End If
If DEPARTMENT <> “” Then
Call add2array(arrColumn3, DEPARTMENT)
End If
‘Address details
‘NOTE:
‘PO BOX will over ride street in this script
If 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 If
End If
Call 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 Signature
strHTM = 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 file
If 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 Signature
strRTF = 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 = Nothing
End 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 = Nothing
End 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 = Nothing
End 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 = Nothing
End 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 If
End 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 = Nothing
End 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: http://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
‘Re-size 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\9375CFF0413111d3B88A00104B2A66760000002″
‘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
‘### CRITICAL 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 = Nothing
End 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 = Nothing
End 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 = Nothing
End 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 = Nothing
End Function
Function CompName()
‘————————————————————————–
‘ Return Computer Name
‘————————————————————————–
Dim objNet
‘ Network object
Set objNet = CreateObject(“WScript.Network”)
CompName = objNet.ComputerName
‘Clean Up
Set objNet = Nothing
End 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 = Nothing
End 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 = Nothing
End Function
Function FileExists(File)
‘———————————————
‘ File exists – returns true/false
‘———————————————
Dim objFSO
Set objFSO = CreateObject(“Scripting.FileSystemObject”)
FileExists = objFSO.FileExists(File)
‘Clean Up
Set objFSO = Nothing
End Function
Function FolderExists(FolderName)
‘———————————————
‘ Folder exists – returns true/false
‘———————————————
Dim objFSO
Set objFSO = CreateObject(“Scripting.FileSystemObject”)
FolderExists = objFSO.FolderExists(FolderName)
‘Clean Up
Set objFSO = Nothing
End 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 = Nothing
End 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 modified array back
add2array = arr
End 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 0
End 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 = Length
End 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 = arr
End 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 = strAll
End 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 = Nothing
End Function
Advertisements

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s