;====================
;
; VBScript: <Signatures.vbs>
; AUTHOR: Peter Aarts
; Contact Info: peter.aarts@l1.nl
; Version 2.04
; Date: January 20, 2006
;
;====================
;Option Explicit
Dim $objSysInfo, $objuser
Dim $FullName, $EMail, $Title, $PhoneNumber, $MobileNumber, $FaxNumber, $OfficeLocation, $Department
Dim $web_address, $FolderLocation, $HTMFileString, $StreetAddress, $Town, $Company
Dim $ZipCode, $PostOfficeBox, $UserDataPath
; Read LDAP(Active Directory) information to asigns the user's info to variables.
;====================
$objSysInfo = CreateObject("ADSystemInfo")
$objSysInfo.RefreshSchemaCache
$objuser = GetObject("LDAP://" + $objSysInfo.Username)
$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.l1.nl"
; 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
$objShell = CreateObject("WScript.Shell")
$RegKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\11.0\Common\General"
$RegKey = $RegKey + "\Signatures"
$objShell.RegWrite($RegKey , "Handtekeningen")
$UserDataPath = $objShell.ExpandEnvironmentStrings("%appdata%")
$FolderLocation = $UserDataPath +"\Microsoft\Handtekeningen\"
$HTMFileString = $FolderLocation + "prc-new.htm"
; This section checks if the signature directory exits and if not creates one.
;====================
Dim $objFS1
$objFS1 = CreateObject("Scripting.FileSystemObject")
If NOT $objFS1.FolderExists($FolderLocation)
$objFS1.CreateFolder($FolderLocation)
EndIf
; The next section builds the signature file
;====================
Dim $objFSO
Dim $objFile, $afile
Dim $aQuote
$aQuote = chr(34)
; This section builds the HTML file version
;====================
$objFSO = CreateObject("Scripting.FileSystemObject")
; This section deletes to other signatures.
; These signatures are automaticly created by Outlook 2003.
;====================
$afile = $objFSO.GetFile($FolderLocation+"prc-new.rtf")
$afile.Delete
$afile = $objFSO.GetFile($FolderLocation+"prc-new.txt")
$afile.Delete
$objFile = $objFSO.CreateTextFile($HTMFileString, 1)
$objFile.Close
$objFile = $objFSO.OpenTextFile($HTMFileString, 2)
$objFile.Write("<!DOCTYPE HTML PUBLIC " + $aQuote + "-//W3C//DTD HTML 4.0 Transitional//EN" + $aQuote + ">" + @CRLF)
$objFile.Write("<HTML><HEAD><TITLE>Microsoft Office Outlook Signature</TITLE>" + @CRLF)
$objFile.Write("<META http-equiv=Content-Type content=" + $aQuote + "text/html; charset=windows-1252" + $aQuote + ">" + @CRLF)
$objFile.Write("<META content=" + $aQuote + "MSHTML 6.00.3790.186" + $aQuote + " name=GENERATOR></HEAD>" + @CRLF)
$objFile.Write("<BODY link=#FFFFFF alink=#FFCC00 vlink=#FFFFFF>" + @CRLF)
$objFile.Write("<FONT size=2 face=" + $aQuote + "Arial" + $aQuote + " color=black>Met vriendelijke groet,<br>"+ @CRLF)
$objFile.Write("<BR>" + @CRLF)
$objFile.Write("<B><FONT size=2>"+ $FullName + "</B><BR>" + @CRLF)
$objFile.Write($Department + " " + $Title + "<BR><BR>" + @CRLF)
$objFile.Write("<FONT size=2 face=" + $aQuote + "Arial" + $aQuote
+ " color=Navy><B>"+ $Company + "</B><BR>" + @CRLF)
$objFile.Write("<FONT size=2 color=black>"
+ $StreetAddress+", "+$PostOfficeBox+", "+$ZipCode+", "+$Town+"<BR>"+ @CRLF)
$objFile.Write("<B><FONT size=2 color=navy>T</B><FONT size=2 color=black> " + $PhoneNumber + " | " + "<B><FONT size=2 color=navy>M</B><FONT size=2 color=black> "
+ $MobileNumber + " | " + "<B><FONT size=2 color=navy>F</B><FONT size=2 color=black> " + $FaxNumber + "<BR>" + @CRLF)
$objFile.Write("<B><FONT size=2 color=navy>E</B><FONT size=2 color=black> " + $EMail +" | "
+ "<B><FONT size=2 color=navy>I</B><FONT size=2 color=black> " + $web_address + @CRLF)
$objFile.Write("</FONT></BODY></HTML>" + @CRLF)
$objFile.Close
; ===========================
; 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
SetDefaultSignature("prc-new","")
; Use this version (and comment the other) to
; modify a named profile.
; SetDefaultSignature("Signature Name", "Profile Name")
Function SetDefaultSignature($strSigName, $strProfile)
Dim $HKEY_CURRENT_USER = &80000001
$strComputer = "."
If IsOutlookRunning = 0
$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 = ""
$objreg.GetStringValue($HKEY_CURRENT_USER, $strKeyPath, "DefaultProfile", $strProfile)
EndIf
; build array from signature name
$myArray = StringToByteArray($strSigName, 1)
$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."
$=MessageBox($strMsg, "SetDefaultSignature")
EndIf
EndFunction
Function IsOutlookRunning()
$strComputer = "."
$strQuery = "Select * from Win32_Process Where Name = 'Outlook.exe'"
$objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" + $strComputer + "\root\cimv2")
$colProcesses = $objWMIService.ExecQuery($strQuery)
For Each $objProcess In $colProcesses
If UCase($objProcess.Name) = "OUTLOOK.EXE"
$IsOutlookRunning = 1
Else
$IsOutlookRunning = 0
EndIf
Next
EndFunction
Function StringToByteArray($Data, $NeedNullTerminator)
Dim $strAll
$strAll = StringToHex4($Data)
If $NeedNullTerminator
$strAll = $strAll + "0000"
EndIf
$intLen = Len($strAll) \ 2
ReDim $arr[$intLen - 1]
For $i = 1 To Len($strAll) \ 2
$arr($i - 1) = CByte("&" + Mid($strAll, (2 * $i) - 1, 2))
Next
$StringToByteArray = $arr
EndFunction
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
EndFunction
