Outlook Signature Script

I have a signature script bellow that works great. It loads a login and stops users changing the company signature to what ever they wish.
I want to add a line to the script that will make the reply forward signature change to <none> so I dont have the signature on replies.
I know ther are other ways like a bat file
reg delete "HKCU\Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\Outlook\9375CFF0413111d3B88A00104B2A66760000001" /v "Reply-Forward Signature" /f

BUT
I need this in the script so users cant add a reply signature and it iverwrites eeach time they login.


'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
MobileNumber = objuser.TelephoneMobile
OfficeLocation = objuser.physicalDeliveryOfficeName
StreetAddress = objuser.streetaddress
CityAddress = objuser.l
StateAddress = objuser.st
PostofficeBox = objuser.postofficebox
Department = objUser.Department
ZipCode = objuser.postalcode
web_address = "http://www.xxx.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 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_xxx"
objShell.RegWrite RegKey07 , "AD_xxx"
UserDataPath = ObjShell.ExpandEnvironmentStrings("%appdata%")
FolderLocation = UserDataPath &"\Microsoft\AD_xxx\"
HTMFileString = FolderLocation & "xxx.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&"xxx.rtf")
aFile.Delete
Set AFile = objFSO.GetFile(Folderlocation&"xxx.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>" & vbCrLf
 
 
objfile.write "<table cellspacing=0 cellpadding=0>"
objfile.write "<tr><td>"
 
 
 
objfile.write "<p align=left><B><FONT style=font-size:10pt color=808080 face=Verdana>" & FullName & "</B> | " & title & "<br>"& vbCrLf
objfile.write "<B><FONT style=font-size:20pt color=#00539B  face=Verdana> xxx</B></font><font color=78BDE8 style=font-size:20pt face=Verdana>xxx<br>"& vbCrLf
objfile.write "</font><font color=808080 style=font-size:2pt face=Verdana><br>" & vbCrLf
objfile.write "</font><font color=808080 style=font-size:8pt face=Verdana>" & Company & "<br>"& vbCrLf
objfile.write " " & StreetAddress & ", " & CityAddress & " " & StateAddress & " " & ZipCode & "<br>"& vbCrLf
 
if PostofficeBox <> "" then
	objfile.write " (" & PostofficeBox & ")<br>" & vbCrLf
end if
 
objfile.write "<nobr>T " & PhoneNumber & " | F " & FaxNumber
 
if MobileNumber <> "" then
	objfile.write " | M " & MobileNumber
end if
 
objfile.write "<br>" & vbCrLf
objfile.write "<a href=" & Email &" > <font color=#696969 face=Verdana>" & Email &"</a> | <a href=http://www.xxx.com><font color=#696969>www.xxx.com</font></a>"& vbCrLf
 
objfile.write "</td><td align=right>"
objfile.write "<img src=\\xxx.local\sysvol\xxx.local\scripts\anniversary.jpg ALIGN=RIGHT BORDER=0 WIDTH=316 HEIGHT=89>"
objfile.write "</td></tr></table>"
 
 
 
objfile.write "<font color=808080 style=font-size:7pt face=Verdana><br>" & vbCrLf
objfile.write " This transmission is for the intended addressee only. If you have received this transmission in error, please delete it and notify the sender.<br>"  & 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("Orient","")
 
' 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

Open in new window

ShayneBeaumontAsked:
Who is Participating?
 
bevhostCommented:
0
 
bevhostCommented:
Can you set the registry permission to stop them from add a reply sig.
See
http://www.lockergnome.com/windows/2005/01/11/set-registry-permissions-using-group-policy/
0
 
ShayneBeaumontAuthor Commented:
I want to do it in a script as there are many different settings on numerous PC's.

I could use a GPO but I really just need the script I have edited.

If there are any VBS  guru's that can help.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.