我目前正在使用VBS设置HTML新邮件/回复签名。这是剧本。
我想将txtreply.txt设置为txt电子邮件的默认回复。 atm我甚至无法从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
如果我在\ Microsoft \ Signatures文件夹中创建一个txt文件，它在outlook中显示但我无法使用该脚本创建该文件。问题是我需要在100个用户上创建.txt签名。