0

我编写了一个从 Active Directory 获取用户信息的 vbscript，基于 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

谁能帮我检查版本，并根据结果将 de MYSIGNATURE 设置为 Outlook 中的默认值。就像我说的那样，上面的文章对所有 2010 年的用户都是如此……

4

3 回答 3

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
于 2016-08-10T13:43:58.483 回答
0

您正在对配置文件部分 guid ( 9375CFF0413111d3B88A00104B2A6676) 进行硬编码 - 您不应该这样做：对于不同机器上不同配置文件中的不同帐户，它是不同的。另请注意，配置文件存储在 Outlook 2016 的不同注册表位置。

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

如果不能将扩展 MAPI 与 C++ 或 Delphi 一起使用，则可以使用Redemption - 它公开RDOSignatures集合和公开和属性的RDOAccount对象。NewMessageSignatureReplySignature

于 2016-08-03T17:58:40.317 回答
-1

这是我的全部代码，

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-path，版本被检索到了应该的样子......但是由于某种原因，代码不会在下一部分进入“for each”循环，它没有'找不到任何'子键'（但是当我签入注册表时，它们就在那里......）

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
于 2016-08-04T09:59:48.840 回答