Programmaticaly在Outlook 2016中使用vbScript设置签名

Question

我已经写了一个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 & _ 
"\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", 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 

谁能帮我检查版本，并根据结果来设定去MYSIGNATURE为默认值在Outlook中。就像我说过的那样，对于2010年的所有用户来说，这一切都是这样的...

Answer 1

我已经解决了我的问题，路径出现了问题。我已经（和工作）的代码现在是以下（经测试的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 & "\9375CFF0413111d3B88A00104B2A6676" 
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 

Answer 2

您正在对配置文件部分guid进行硬编码（9375CFF0413111d3B88A00104B2A6676） - 您不应该那样做：它对于不同配置文件机器。另请注意，配置文件存储在Outlook 2016的其他注册表位置中。

必须使用IOlkAccount MAPI接口（仅限C++或Delphi）在特定帐户的配置文件部分中设置签名名称。您可以使用OutlookSpy中的该界面进行游戏（点击IOlkAccountManager按钮）。您需要使用IOlkAccount::SetProp方法来设置PROP_NEW_MESSAGE_SIGNATURE（0x0016001F）和PROP_REPLY_SIGNATURE（0x0017001F）属性。

如果您不能使用C扩展MAPI ++或Delphi，你可以使用Redemption - 它暴露RDOSignatures收集和RDOAccount对象暴露的NewMessageSignature和ReplySignature性能。

Answer 3

这是我的全部代码，

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 

直到这里，代码运行得很好，这是正确的REG路径，版本检索像它应该... 但由于某些原因，代码不会进入“每个”在接下来的部分循环，它没有找到任何“子项”（但是当我在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