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

时间：2016-08-03 12:19:15

标签： vbscript outlook office-2016

我编写了一个vbscript，它从Active Directory获取用户信息，根据html生成签名，并将outlook中的签名设置为默认值。这在Office 2010中运行良好。但是现在有些用户有办公室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年的所有用户提供了这个......

3 个答案:

答案 0 :(得分：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

答案 1 :(得分：0)

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

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

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

答案 2 :(得分：-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

直到这里，代码运行得很好，它是正确的注册路径，版本被检索它应该... 但出于某种原因，代码不会为每个＆＃39;进入＆＃39;循环在下一部分，它没有找到任何＆＃39;子键＆＃39; （但是当我登记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
相关问题
最新问题