Link to home
Start Free TrialLog in
Avatar of MH-Administrator
MH-Administrator

asked on

VBS generates Outlook signature - customize help

I am creating a custom script for our outlook 2002, 2003 and 2007 users to standardize their signatures. So far, I have this script that pulls their info from active directory, but I need to make it look a bit nicer. I want to add font styles and a logo. Is there any way to do so with the following script?

[code]
On Error Resume Next

Set objSysInfo = CreateObject("ADSystemInfo")

strUser = objSysInfo.UserName
Set objUser = GetObject("LDAP://" & strUser)

strName = objUser.FullName
strTitle = objUser.Title
strDepartment = objUser.Department
strCompany = objUser.Company
strPhone = objUser.telephoneNumber

Set objWord = CreateObject("Word.Application")

Set objDoc = objWord.Documents.Add()
Set objSelection = objWord.Selection

Set objEmailOptions = objWord.EmailOptions
Set objSignatureObject = objEmailOptions.EmailSignature

Set objSignatureEntries = objSignatureObject.EmailSignatureEntries


objSelection.TypeText strName & ", " & strTitle
objSelection.TypeParagraph()
objSelection.TypeText strDepartment
objSelection.TypeParagraph()
objSelection.TypeText strCompany
objSelection.TypeParagraph()
objSelection.TypeText strPhone

Set objSelection = objDoc.Range()

objSignatureEntries.Add "AD Signature", objSelection
objSignatureObject.NewMessageSignature = "AD Signature"
objSignatureObject.ReplyMessageSignature = "AD Signature"

objDoc.Saved = True
objWord.Quit
[/code]
Avatar of MH-Administrator
MH-Administrator

ASKER

I want it to eventually look like this:

[code]
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
<HTML><HEAD><TITLE>Signature Template</TITLE>
<META http-equiv=Content-Type content="text/html; charset=windows-1252">
<META content="MSHTML 6.00.2900.3132" name=GENERATOR>
<BODY>
<DIV align=left>
  <FONT face="Arial Black" size=2 color="#336600">My Name</FONT><br>
  <font color="#009900" size="2" face="Arial Black"><em>My Title</em></font><br>
  <a href="http://some.com"><img src="Logo folder/image001.jpg" alt="Online Text" width="187" height="35" border="0"></a><br>
  <font color="#336600" size="2" face="Arial Black">Address<BR>
Address Line 2<BR>
Phone Number<BR>
Fax</font><BR>
<BR>
</DIV>
</BODY></HTML>
[/code]
ASKER CERTIFIED SOLUTION
Avatar of chandru_sol
chandru_sol
Flag of India image
Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of MH-Administrator
MH-Administrator

ASKER

Excellent, Thanks for the find.
Just for congruency, here is the modified script for the US. FYI, save as a vbs file:

[code]
'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 assign 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.webaddr.com"

' 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 English version.
' Changing this in a production environment might create extra work
' all employees are missing their old signatures
'====================
Dim objShell, RegKey, RegKeyParm
Set objShell = CreateObject("WScript.Shell")
RegKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\11.0\Common\General"
RegKey = RegKey & "\Signatures"
objShell.RegWrite RegKey , "Signatures"
UserDataPath = ObjShell.ExpandEnvironmentStrings("%appdata%")
FolderLocation = UserDataPath &"\Microsoft\Signatures\"
HTMFileString = FolderLocation & "AD-Signature.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" , "AD-Signature"
objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\11.0\Common\MailSettings\ReplySignature" , "AD-Signature"
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&"AD-Signature.rtf")
aFile.Delete
Set AFile = objFSO.GetFile(Folderlocation&"AD-Signature.txt")
aFile.Delete

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 link=#FFFFFF alink=#FFCC00 vlink=#FFFFFF>" & vbCrLf
objfile.write "<FONT size=2 face=Arial>Kind Regards,<br>" & vbCrLf
objfile.write "<BR>" & vbCrLf
objfile.write "<FONT size=2 face=" & aQuote & "Arial Black" & aQuote & " color=#336600>"& FullName & "<BR>" & vbCrLf
objfile.write "<font color=#009900 size=2 face=" & aQuote & "Arial Black" & aQuote & "><em>" & title & "</em></font><br>" & vbCrLf
objfile.write "<a href=" & aQuote & "http://webaddr.com" & aQuote & "><img src=" & aQuote & "http://webaddr.com/images/image001.jpg" & aQuote & " alt=" & aQuote & "Visit Us at webaddr.com!" & aQuote & " width=" & aQuote & "187" & aQuote & " height=" & aQuote & "35" & aQuote & " border=" & aQuote & "0" & aQuote & "></a><br>" & vbCrLf
objfile.write "<FONT size=2 face=" & aQuote & "Arial Black" & aQuote & " color=#336600>"&Department&"<BR>" & vbCrLf
objfile.write "<FONT size=2 face=" & aQuote & "Arial Black" & aQuote & " color=#336600>"&Company&"<BR>" & vbCrLf
objfile.write "<FONT size=2 color=#336600>" & StreetAddress&", "&town&", "&state&" "&ZipCode&"<BR>"& vbCrLf
objfile.write "<FONT size=2 color=#336600>T<FONT size=1 color=#336600> " & PhoneNumber & "<FONT size=2 color=#336600> | " & "<FONT size=2 color=#336600>F<FONT size=1 color=#336600> " & FaxNumber & "<BR>" & vbCrLf
objfile.write "<FONT size=2 color=#336600>E<FONT size=1 color=#336600> " & Email &"<FONT size=2 color=#336600> | " & "<FONT size=2 color=#336600>I<FONT size=1 color=#336600> " & web_address & vbCrLf
objfile.write "</FONT></BODY></HTML>" & vbCrLf
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

Call SetDefaultSignature("AD-Signature","")

' 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
[/code]
Avatar of roseward
roseward
Flag of United Kingdom of Great Britain and Northern Ireland image
This needs a re-write to include style sheets and not use the Font Tag which is depracated !

Anyone :)