signature auto reply for plain text emails - vbscript

Question

im currently using a VBS to set HTML newmail/reply signatures. this is the script.
I want to set the txtreply.txt as default reply on txt emails. atm im not even able to choose the file from outlook.
Option Explicit
On Error Resume Next
Dim qQuery, objSysInfo, objuser, strComputer, objWMIService, colProcessList, objProcess
Dim FullName, EMail, Title, PhoneNumber, MobileNumber, FaxNumber, OfficeLocation, Department, Firstname, Lastname, HeadNumber
Dim web_address, web_address_pl, FolderLocation, HTMFileString,HTMFileString2,HTMFileString3 StreetAddress, Town, State, Company, gptw_link, gptw_img
Dim ZipCode, PostOfficeBox, UserDataPath
Dim linkedin_link, linkedin_img
' Closing outlook
'==========================================================
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colProcessList = objWMIService.ExecQuery _
("SELECT * FROM Win32_Process WHERE Name = 'OUTLOOK.EXE'")
For Each objProcess in colProcessList
objProcess.Terminate()
Next
WScript.Sleep 1000
' Read LDAP(Active Directory)
'==========================================================
Set objSysInfo = CreateObject("ADSystemInfo")
'objSysInfo.RefreshSchemaCache
qQuery = "LDAP://" & objSysInfo.Username
Set objuser = GetObject(qQuery)
FullName = objuser.displayname
Firstname = objuser.Firstname
Lastname = objuser.Lastname
EMail = objuser.mail
Company = objuser.Company
Title = objuser.title
HeadNumber = ""
PhoneNumber = objuser.TelephoneMobile
FaxNumber = objuser.FaxNumber
OfficeLocation = objuser.physicalDeliveryOfficeName
StreetAddress = objuser.streetaddress
PostofficeBox = objuser.postofficebox
Department = objUser.Department
ZipCode = objuser.postalcode
Town = objuser.l
MobileNumber = objuser.TelephoneMobile
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 & "Newmail.htm"
HTMFileString2 = FolderLocation & "Reply.htm"
HTMFileString3 = FolderLocation & "txtreply.txt."
' Ingen rettigheder for brugeren i at ændre signaturen.
'==========================================================
' Outlook 2010
objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\14.0\Common\MailSettings\NewSignature" , "Newmail"
objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\14.0\Common\MailSettings\ReplySignature" , "Reply"
objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\14.0\Outlook\Options\Mail\EnableLogging" , "0", "REG_DWORD"
' Outlook 2013
objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\15.0\Common\MailSettings\NewSignature" , "Hartmanns"
objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\15.0\Common\MailSettings\ReplySignature" , "Hartmanns_Reply"
objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\15.0 \Outlook\Options\Mail\EnableLogging" , "0", "REG_DWORD"
' KOntroller om signatur biblioteket eksistere, opret hvis ikke
'==========================================================
Dim objFS1
Set objFS1 = CreateObject("Scripting.FileSystemObject")
If (objFS1.FolderExists(FolderLocation)) Then
Else
Call objFS1.CreateFolder(FolderLocation)
End if
' Opret signatur filen
'==========================================================
Dim objFSO
Dim objFile,objFile2,objFile3,afile
Dim aQuote, aColon
Dim objCitatFile, strText, arrCitat, x
aQuote = chr(34)
aColon = chr(58)
' Opbyg HTML fil struktur
'==========================================================
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Slet andre signatur filer
' Disse filer er automatisk oprettet af Outlook 2003, 2007 & 2010
'==========================================================
Set AFile = objFSO.GetFile(Folderlocation&"Newmail.rtf")
'aFile.Delete
Set AFile = objFSO.GetFile(Folderlocation&"Newmail.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>"
the new mail content
objfile.write "</body></HTML>" & vbCrLf
objfile.Close
' Skriv besvar signatur
' =========================================================
Set AFile = objFSO.GetFile(Folderlocation&"Reply.rtf")
aFile.Delete
Set AFile = objFSO.GetFile(Folderlocation&"Reply.txt")
aFile.Delete
Set objFile2 = objFSO.CreateTextFile(HTMFileString2,True)
objFile2.Close
Set objFile2 = objFSO.OpenTextFile(HTMFileString2, 2)
objfile2.write "<!DOCTYPE HTML PUBLIC " & aQuote & "-//W3C//DTD HTML 4.0 Transitional//EN" & aQuote & ">" & vbCrLf
objfile2.write "<HTML>
the reply email
objfile2.write "</body></HTML>" & vbCrLf
objfile2.close
' Skriv Plain tekst besvar signatur
' =========================================================
Set AFile = objFSO.GetFile(Folderlocation&"txtreply.rtf")
'aFile.Delete
Set AFile = objFSO.GetFile(Folderlocation&"txtreply.htm")
'aFile.Delete
Set objFile3 = objFSO.CreateTextFile(HTMFileString3,True)
objFile3.Close
Set objFile3 = objFSO.OpenTextFile(HTMFileString3, 2)
objfile3.write "<font size=3></font><br /><br />"
objfile3.write "<font size=3><b></font></b><br>"
objfile3.write "<font size=3><b></b><br /></font>"
objfile3.write "<font size=3></font><br /><br /></font>"
objfile3.write "<font size=3>Please consider the environment before printing this email or its attachments</font>"
objfile3.close
' Læs outlook profilen og sæt signaturen som default
' =========================================================
Call SetDefaultSignature("newmail","")
Call SetDefaultReplyForwardSignature("Reply","")
Sub SetDefaultSignature(strSigName, strProfile)
Dim objreg, strKeyPath, myArray, arrProfileKeys, subkey, strsubkeypath
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\"
' Find profil navn, hvis ikke det er defineret
If strProfile = "" Then
objreg.GetStringValue HKEY_CURRENT_USER, _
strKeyPath, "DefaultProfile", strProfile
End If
' Byg array fra signatur navne
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
Next
'Else
' strMsg = "Please shut down Outlook before " & _
' "running this script."
' MsgBox strMsg, vbExclamation, "SetDefaultSignature"
End If
End Sub
'Reply_Forward
Sub SetDefaultReplyForwardSignature(strSigName, strProfile)
Dim objreg, strKeyPath, myArray, arrProfileKeys, subkey, strsubkeypath
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\"
' Find profil navn, hvis ikke det er defineret
If strProfile = "" Then
objreg.GetStringValue HKEY_CURRENT_USER, _
strKeyPath, "DefaultProfile", strProfile
End If
' Byg array fra signatur navne
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, "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()
Dim strQuery, colProcesses
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, intLen, i
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)
Dim strAll, strChar, strTemp, i
For i = 1 To Len(Data)
' Konverter hver karakter (4) til hex ?#!" :)
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
if i create a txt file in the \Microsoft\Signatures folder it shows in outlook but im not able to create the file using the script. problem is that i need to create the .txt signature on 100 users.