使用 vbScript 在 Outlook 2016 中以编程方式设置签名
Programmaticaly set signature in Outlook 2016 with vbScript
我编写了一个 vbscript，它从 Active Directory 中获取用户信息，根据 html 生成签名并将 outlook 中的签名设置为默认签名。这在 Office 2010 中运行良好。但现在一些用户有 office 2016，脚本确实在 outlook 中添加了签名，但我似乎无法将其设置为默认值（或回复默认值）。
这是我使用的代码：
Call SetDefaultSignature("MYSIGNATURE","")
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\"
If strProfile = "" Then
objreg.GetStringValue HKEY_CURRENT_USER, _
strKeyPath, "DefaultProfile", strProfile
End If
myArray = StringToByteArray(strSigName, True)
strKeyPath = strKeyPath & strProfile & _
"75CFF0413111d3B88A00104B2A6676"
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", StringToByteArray(None, True)
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)
Dim strAll
For i = 1 To Len(Data)
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
谁能帮我检查版本，并根据结果将 de MYSIGNATURE 设置为 outlook 中的默认值。就像我说的，上面的文章是为所有 2010 年用户做的......
这是我的全部代码，
Call SetDefaultSignature("Test3", "")
Sub SetDefaultSignature(strSigName, strProfile)
const HKEY_CURRENT_USER = &H80000001
const HKEY_LOCAL_MACHINE = &H80000002
strComputer = "."
Set objreg = GetObject("winmgmts:\" & _
strComputer & "\root\default:StdRegProv")
'Determine path to outlook.exe
strKeyOutlookAppPath = "SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\OUTLOOK.EXE"
strOutlookPath = "Path"
objreg.GetStringValue _
HKEY_LOCAL_MACHINE,strKeyOutlookAppPath,strOutlookPath,strOutlookPathValue
'Verify that the outlook.exe exist and get version information
Set objFSO = CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists(strOutlookPathValue & "outlook.exe") Then
strOutlookVersionNumber = objFSO.GetFileVersion(strOutlookPathValue & "outlook.exe")
strOutlookVersion = Left(strOutlookVersionNumber, inStr(strOutlookVersionNumber, ".0") - 1)
Else
msgbox "The location of OUTLOOK.EXE couldn not be verified." & vbNewLine & _
"Please contact your system administrator."
End If
'Set profile Registry path based on Outlook version
If strOutlookVersion >= 15 Then
strKeyPath = _
"Software\Microsoft\Office\" & strOutlookVersion & ".0\Outlook\Profiles\" _
& ProfileName & "9375CFF0413111d3B88A00104B2A6676"
Else
strKeyPath = _
"Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\" _
& ProfileName & "75CFF0413111d3B88A00104B2A6676"
End If
' If strProfile = "" Then
' objreg.GetStringValue HKEY_CURRENT_USER, _
' strKeyPath, "DefaultProfile", strProfile
' End If
myArray = StringToByteArray(strSigName, True)
objreg.EnumKey HKEY_CURRENT_USER, strKeyPath, _
arrProfileKeys
直到这里，代码运行得很好，它是正确的注册路径，版本被检索到，就像它应该的那样......
但由于某种原因，代码不会在下一部分进入 'for each' 循环，它没有找到任何 'subkeys' （但是当我检查 reg 时，它们在那里......）
For Each subkey In arrProfileKeys
msgbox "subkey" & subkey
strsubkeypath = strKeyPath & "\" & subkey
objreg.SetBinaryValue HKEY_CURRENT_USER, vstrsubkeypath,"New Signature",myArray
objreg.SetBinaryValue HKEY_CURRENT_USER, _
strsubkeypath, "Reply-Forward Signature", StringToByteArray(None, True)
Next
End Sub
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)
Dim strAll
For i = 1 To Len(Data)
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
我的问题已经解决了，路径有问题。我拥有（并且有效）的代码现在如下（已针对 Office 2010 和 2016 进行测试）：
'==========================================================================
' Set Signature As Default
'==========================================================================
Call SetDefaultSignature("NameOfTheSignature", "")
Sub SetDefaultSignature(strSigName, strProfile)
const HKEY_CURRENT_USER = &H80000001
const HKEY_LOCAL_MACHINE = &H80000002
strComputer = "."
Set objreg = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\" & _
strComputer & "\root\default:StdRegProv")
'Determine path to outlook.exe
strKeyOutlookAppPath = "SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\OUTLOOK.EXE"
strOutlookPath = "Path"
objreg.GetStringValue HKEY_LOCAL_MACHINE,strKeyOutlookAppPath,strOutlookPath,strOutlookPathValue
'Verify that the outlook.exe exist and get version information
Set objFSO = CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists(strOutlookPathValue & "outlook.exe") Then
strOutlookVersionNumber = objFSO.GetFileVersion(strOutlookPathValue & "outlook.exe")
strOutlookVersion = Left(strOutlookVersionNumber, inStr(strOutlookVersionNumber, ".0") - 1)
End If
'Set profile Registry path based on Outlook version
If strOutlookVersion >= 15 Then
strKeyPath = "Software\Microsoft\Office\" & strOutlookVersion & ".0\Outlook\Profiles\"
strDisableKeyPath = "Software\Microsoft\Office\" & strOutlookVersion & ".0\Common\MailSettings\"
Else
strKeyPath = "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\"
strDisableKeyPath = "Software\Microsoft\Office\" & strOutlookVersion & ".0\Common\MailSettings\"
End If
If strProfile = "" Then
objreg.GetStringValue HKEY_CURRENT_USER, _
strKeyPath, "DefaultProfile", strProfile
End If
myArray = StringToByteArray(strSigName, True)
strKeyPath = strKeyPath & strProfile & "75CFF0413111d3B88A00104B2A6676"
objreg.EnumKey HKEY_CURRENT_USER, strKeyPath, arrProfileKeys
For Each subkey In arrProfileKeys
strsubkeypath = strKeyPath & "\" & subkey
objreg.SetStringValue HKEY_CURRENT_USER, strsubkeypath, "New Signature", strSigName
objreg.SetStringValue HKEY_CURRENT_USER, strsubkeypath, "Reply-Forward Signature", "(None)"
Next
End Sub
我编写了一个 vbscript，它从 Active Directory 中获取用户信息，根据 html 生成签名并将 outlook 中的签名设置为默认签名。这在 Office 2010 中运行良好。但现在一些用户有 office 2016，脚本确实在 outlook 中添加了签名，但我似乎无法将其设置为默认值（或回复默认值）。
这是我使用的代码：
Call SetDefaultSignature("MYSIGNATURE","")
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\"
If strProfile = "" Then
objreg.GetStringValue HKEY_CURRENT_USER, _
strKeyPath, "DefaultProfile", strProfile
End If
myArray = StringToByteArray(strSigName, True)
strKeyPath = strKeyPath & strProfile & _
"75CFF0413111d3B88A00104B2A6676"
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", StringToByteArray(None, True)
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)
Dim strAll
For i = 1 To Len(Data)
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
谁能帮我检查版本，并根据结果将 de MYSIGNATURE 设置为 outlook 中的默认值。就像我说的，上面的文章是为所有 2010 年用户做的......
这是我的全部代码，
Call SetDefaultSignature("Test3", "")
Sub SetDefaultSignature(strSigName, strProfile)
const HKEY_CURRENT_USER = &H80000001
const HKEY_LOCAL_MACHINE = &H80000002
strComputer = "."
Set objreg = GetObject("winmgmts:\" & _
strComputer & "\root\default:StdRegProv")
'Determine path to outlook.exe
strKeyOutlookAppPath = "SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\OUTLOOK.EXE"
strOutlookPath = "Path"
objreg.GetStringValue _
HKEY_LOCAL_MACHINE,strKeyOutlookAppPath,strOutlookPath,strOutlookPathValue
'Verify that the outlook.exe exist and get version information
Set objFSO = CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists(strOutlookPathValue & "outlook.exe") Then
strOutlookVersionNumber = objFSO.GetFileVersion(strOutlookPathValue & "outlook.exe")
strOutlookVersion = Left(strOutlookVersionNumber, inStr(strOutlookVersionNumber, ".0") - 1)
Else
msgbox "The location of OUTLOOK.EXE couldn not be verified." & vbNewLine & _
"Please contact your system administrator."
End If
'Set profile Registry path based on Outlook version
If strOutlookVersion >= 15 Then
strKeyPath = _
"Software\Microsoft\Office\" & strOutlookVersion & ".0\Outlook\Profiles\" _
& ProfileName & "9375CFF0413111d3B88A00104B2A6676"
Else
strKeyPath = _
"Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\" _
& ProfileName & "75CFF0413111d3B88A00104B2A6676"
End If
' If strProfile = "" Then
' objreg.GetStringValue HKEY_CURRENT_USER, _
' strKeyPath, "DefaultProfile", strProfile
' End If
myArray = StringToByteArray(strSigName, True)
objreg.EnumKey HKEY_CURRENT_USER, strKeyPath, _
arrProfileKeys
直到这里，代码运行得很好，它是正确的注册路径，版本被检索到，就像它应该的那样...... 但由于某种原因，代码不会在下一部分进入 'for each' 循环，它没有找到任何 'subkeys' （但是当我检查 reg 时，它们在那里......）
For Each subkey In arrProfileKeys
msgbox "subkey" & subkey
strsubkeypath = strKeyPath & "\" & subkey
objreg.SetBinaryValue HKEY_CURRENT_USER, vstrsubkeypath,"New Signature",myArray
objreg.SetBinaryValue HKEY_CURRENT_USER, _
strsubkeypath, "Reply-Forward Signature", StringToByteArray(None, True)
Next
End Sub
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)
Dim strAll
For i = 1 To Len(Data)
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
我的问题已经解决了，路径有问题。我拥有（并且有效）的代码现在如下（已针对 Office 2010 和 2016 进行测试）：
'==========================================================================
' Set Signature As Default
'==========================================================================
Call SetDefaultSignature("NameOfTheSignature", "")
Sub SetDefaultSignature(strSigName, strProfile)
const HKEY_CURRENT_USER = &H80000001
const HKEY_LOCAL_MACHINE = &H80000002
strComputer = "."
Set objreg = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\" & _
strComputer & "\root\default:StdRegProv")
'Determine path to outlook.exe
strKeyOutlookAppPath = "SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\OUTLOOK.EXE"
strOutlookPath = "Path"
objreg.GetStringValue HKEY_LOCAL_MACHINE,strKeyOutlookAppPath,strOutlookPath,strOutlookPathValue
'Verify that the outlook.exe exist and get version information
Set objFSO = CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists(strOutlookPathValue & "outlook.exe") Then
strOutlookVersionNumber = objFSO.GetFileVersion(strOutlookPathValue & "outlook.exe")
strOutlookVersion = Left(strOutlookVersionNumber, inStr(strOutlookVersionNumber, ".0") - 1)
End If
'Set profile Registry path based on Outlook version
If strOutlookVersion >= 15 Then
strKeyPath = "Software\Microsoft\Office\" & strOutlookVersion & ".0\Outlook\Profiles\"
strDisableKeyPath = "Software\Microsoft\Office\" & strOutlookVersion & ".0\Common\MailSettings\"
Else
strKeyPath = "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\"
strDisableKeyPath = "Software\Microsoft\Office\" & strOutlookVersion & ".0\Common\MailSettings\"
End If
If strProfile = "" Then
objreg.GetStringValue HKEY_CURRENT_USER, _
strKeyPath, "DefaultProfile", strProfile
End If
myArray = StringToByteArray(strSigName, True)
strKeyPath = strKeyPath & strProfile & "75CFF0413111d3B88A00104B2A6676"
objreg.EnumKey HKEY_CURRENT_USER, strKeyPath, arrProfileKeys
For Each subkey In arrProfileKeys
strsubkeypath = strKeyPath & "\" & subkey
objreg.SetStringValue HKEY_CURRENT_USER, strsubkeypath, "New Signature", strSigName
objreg.SetStringValue HKEY_CURRENT_USER, strsubkeypath, "Reply-Forward Signature", "(None)"
Next
End Sub