Brad Marsh’s Weblog

'====================

'

' VBScript: <Signatures.vbs>

' AUTHOR: Peter Aarts

' Contact Info: peter.aarts@l1.nl

' Version 2.04

' Date: January 20, 2006

' Moddified By Brad Marsh Now works with both 2003 and 2007 outlook 

' Contact: gentex@tpg.com.au

' Date 19 feb 08

' Tested on Vista, XP, XP64 and office 2003 and 2007. 

' NOTE will not work that well with various email accounts

' Additions added on 20 Nov 08 - Tested on Office 07 and Vista 

'====================  

'Option Explicit

On Error Resume Next

Dim qQuery, objSysInfo, objuser

Dim FullName, EMail, Title, PhoneNumber, MobileNumber, FaxNumber, OfficeLocation, Department

Dim web_address, FolderLocation, HTMFileString, StreetAddress, Town, State, Company

Dim ZipCode, PostOfficeBox, UserDataPath

' Read LDAP(Active Directory) information to asigns the user's info to variables.

'====================

Set objSysInfo = CreateObject("ADSystemInfo")

objSysInfo.RefreshSchemaCache

qQuery = "LDAP://" & objSysInfo.Username

Set objuser = GetObject(qQuery)

FullName = objuser.displayname

EMail = objuser.mail

Company = objuser.Company

Title = objuser.title

PhoneNumber = objuser.TelephoneNumber

FaxNumber = objuser.FaxNumber

OfficeLocation = objuser.physicalDeliveryOfficeName

StreetAddress = objuser.streetaddress

PostofficeBox = objuser.postofficebox

Department = objUser.Department

ZipCode = objuser.postalcode

Town = objuser.l

MobileNumber = objuser.TelephoneMobile

web_address = "http://www.elcom.com.au"

' This section creates the signature files names and locations.

'====================

' Corrects Outlook signature folder location. Just to make sure that

' Outlook is using the purposed folder defined with variable : FolderLocation

' Example is based on Dutch version.

' Changing this in a production enviremont might create extra work

' all employees are missing their old signatures

'====================

Dim objShell, RegKey, RegKey07, RegKeyParm

Set objShell = CreateObject("WScript.Shell")

RegKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\11.0\Common\General"

RegKey07 = "HKEY_CURRENT_USER\Software\Microsoft\Office\12.0\Common\General"

RegKey07 = RegKey07 & "\Signatures"

RegKey = RegKey & "\Signatures"

objShell.RegWrite RegKey , "AD_elcom"

objShell.RegWrite RegKey07 , "AD_elcom"

UserDataPath = ObjShell.ExpandEnvironmentStrings("%appdata%")

FolderLocation = UserDataPath &"\Microsoft\AD_elcom\"

HTMFileString = FolderLocation & "Elcom.htm"

' This section disables the change of the signature by the user.

'====================

'objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\11.0\Common\MailSettings\NewSignature" , "L1-Handtekening"

'objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\11.0\Common\MailSettings\ReplySignature" , "L1-Handtekening"

'objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\11.0\Outlook\Options\Mail\EnableLogging" , "0", "REG_DWORD"  

' This section checks if the signature directory exits and if not creates one.

'====================

Dim objFS1

Set objFS1 = CreateObject("Scripting.FileSystemObject")

If (objFS1.FolderExists(FolderLocation)) Then

Else

Call objFS1.CreateFolder(FolderLocation)

End if

' The next section builds the signature file

'====================

Dim objFSO

Dim objFile,afile

Dim aQuote

aQuote = chr(34)

' This section builds the HTML file version

'====================

Set objFSO = CreateObject("Scripting.FileSystemObject")

' This section deletes to other signatures.

' These signatures are automaticly created by Outlook 2003.

'====================

Set AFile = objFSO.GetFile(Folderlocation&"Elcom.rtf")

aFile.Delete

Set AFile = objFSO.GetFile(Folderlocation&"Elcom.txt")

aFile.Delete

'=========================================================

' This adds the Text file, will need to be changed accordingly

'========================================================== 

Set objFile = objFSO.CreateTextFile(Folderlocation&"Elcom.txt",True)

objfile.writeLine ""& FullName & " | " & title & " |  " & title & " | "& Company & " | Australian Technology Park"

objfile.writeLine "T +612 " & PhoneNumber & " | F +612 9209 4423 | www.elcom.com.au | " & Email &" "

objfile.writeLine " "

objfile.writeLine " "

objfile.writeLine "--------------------------------------------------------------------------------"

objfile.writeLine "This email is intended for the intended recipients(s) and may contain confidential information. "

objfile.writeLine "Reproduction, dissemination or distribution of this message is prohibited unless authorised by the sender."

objfile.writeLine "If you are not the intended recipient, please notify the sender immediately and you must not read,"

objfile.writeLine "keep, use, disclose, copy or distribute this email without the sender's prior permission."

objfile.writeLine "The views expressed by the sender are not necessarily those of Elcom Technology Pty Ltd "

objFile.Close

Set objFile = objFSO.CreateTextFile(HTMFileString,True)

objFile.Close

Set objFile = objFSO.OpenTextFile(HTMFileString, 2)

objfile.write "<!DOCTYPE HTML PUBLIC " & aQuote & "-//W3C//DTD HTML 4.0 Transitional//EN" & aQuote & ">" & vbCrLf

objfile.write "<HTML><HEAD><TITLE>Microsoft Office Outlook Signature</TITLE>" & vbCrLf

objfile.write "<META http-equiv=Content-Type content=" & aQuote & "text/html; charset=windows-1252" & aQuote & ">" & vbCrLf

objfile.write "<META content=" & aQuote & "MSHTML 6.00.3790.186" & aQuote & " name=GENERATOR></HEAD>" & vbCrLf

objfile.write "<body>" & vbCrLf

objfile.write "<font color=696969 face=" & aQuote & "Arial" & aQuote & "><h6> "& FullName & " | " & title & " | "& Company & " | Australian Technology Park <br>"& vbCrLf

objfile.write "T +612 " & PhoneNumber & " | F +612 9209 4423 | <a href=http://www.elcom.com.au><font color=#696969>www.elcom.com.au</font></a> |<a href=mailto:" & Email &" > <font color=#696969>" & Email &" " & vbCrLf

objfile.write "</h6></font></a></B>" & vbCrLf

objfile.write "</font>" & vbCrLf

objfile.write "<font color=696969 face=arial><A href=http://www.elcom.com.au/> <img src=http://www.elcom.com.au/images/elcom-logo-web-175x70.gif border=0></a>" & vbCrLf

objfile.write "<br>" & vbCrLf

objfile.write "<img src=http://www.elcom.com.au/images/mspartner.jpg>" & vbCrLf

objfile.write "<br>" & vbCrLf

objfile.write "</font><font color=696969 size=1 face=arial><br>" & vbCrLf

objfile.write "<hr size=1 align=left width=465 color=696969>" & vbCrLf

objfile.write " This email is intended for the intended recipients(s) and may contain confidential information. <br> Reproduction, dissemination or distribution of this message is prohibited unless authorised by the sender.<br> If you are not the intended recipient, please notify the sender immediately and you must not read,<br> keep, use, disclose, copy or distribute this email without the sender's prior permission.<br> The views expressed by the sender are not necessarily those of Elcom Technology Pty Ltd</font>"  & vbCrLf

objfile.write "</FONT></BODY></HTML>" & vbCrLf

objFile.Close

'==========================================================================

' This copies the .htm file and changes it to a RTF format

'==========================================================================

'Set the Source and Destination paths below - CHANGE your file name

'---------------------------------------------------- 

Const OverwriteExisting = True

Set objFSO = CreateObject("Scripting.FileSystemObject")

objFSO.CopyFile Folderlocation & "Elcom.htm" , Folderlocation & "Elcom.rtf", OverwriteExisting

' ===========================

' This section readsout the current Outlook profile and then sets the name of the default Signature

' ===========================

' Use this version to set all accounts

' in the default mail profile

' to use a previously created signature  

Call SetDefaultSignature("Elcom","")

' Use this version (and comment the other) to

' modify a named profile.

'Call SetDefaultSignature _

' ("Signature Name", "Profile Name")  

Sub SetDefaultSignature(strSigName, strProfile)

Const HKEY_CURRENT_USER = &H80000001

strComputer = "."

If Not IsOutlookRunning Then

Set objreg = GetObject("winmgmts:" & _

"{impersonationLevel=impersonate}!\\" & _

strComputer & "\root\default:StdRegProv")

strKeyPath = "Software\Microsoft\Windows NT\" & _

"CurrentVersion\Windows " & _

"Messaging Subsystem\Profiles\"

' get default profile name if none specified

If strProfile = "" Then

objreg.GetStringValue HKEY_CURRENT_USER, _

strKeyPath, "DefaultProfile", strProfile

End If

' build array from signature name

myArray = StringToByteArray(strSigName, True)

strKeyPath = strKeyPath & strProfile & _

"\9375CFF0413111d3B88A00104B2A6676"

objreg.EnumKey HKEY_CURRENT_USER, strKeyPath, _

arrProfileKeys

For Each subkey In arrProfileKeys

strsubkeypath = strKeyPath & "\" & subkey

objreg.SetBinaryValue HKEY_CURRENT_USER, _

strsubkeypath, "New Signature", myArray

objreg.SetBinaryValue HKEY_CURRENT_USER, _

strsubkeypath, "Reply-Forward Signature", myArray

Next

Else

strMsg = "Please shut down Outlook before " & _

"running this script."

MsgBox strMsg, vbExclamation, "SetDefaultSignature"

End If

End Sub

Function IsOutlookRunning()

strComputer = "."

strQuery = "Select * from Win32_Process " & _

"Where Name = 'Outlook.exe'"

Set objWMIService = GetObject("winmgmts:" _

& "{impersonationLevel=impersonate}!\\" _

& strComputer & "\root\cimv2")

Set colProcesses = objWMIService.ExecQuery(strQuery)

For Each objProcess In colProcesses

If UCase(objProcess.Name) = "OUTLOOK.EXE" Then

IsOutlookRunning = True

Else

IsOutlookRunning = False

End If

Next

End Function

Public Function StringToByteArray _

(Data, NeedNullTerminator)

Dim strAll

strAll = StringToHex4(Data)

If NeedNullTerminator Then

strAll = strAll & "0000"

End If

intLen = Len(strAll) \ 2

ReDim arr(intLen - 1)

For i = 1 To Len(strAll) \ 2

arr(i - 1) = CByte _

("&H" & Mid(strAll, (2 * i) - 1, 2))

Next

StringToByteArray = arr

End Function

Public Function StringToHex4(Data)

' Input: normal text

' Output: four-character string for each character,

' e.g. "3204" for lower-case Russian B,

' "6500" for ASCII e

' Output: correct characters

' needs to reverse order of bytes from 0432

Dim strAll

For i = 1 To Len(Data)

' get the four-character hex for each character

strChar = Mid(Data, i, 1)

strTemp = Right("00" & Hex(AscW(strChar)), 4)

strAll = strAll & Right(strTemp, 2) & Left(strTemp, 2)

Next

StringToHex4 = strAll

End Function