0

Active Directory からユーザー情報を取得し、html に基づいて署名を生成し、署名を Outlook にデフォルトとして設定する vbscript を作成しました。これは 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

これは私のコード全体です。

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 パスであり、バージョンは本来あるべきように取得されます...しかし、何らかの理由で、コードは次の部分で「for each」ループに入りません。 「サブキー」が見つかりません (しかし、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
于 2016-08-04T09:59:48.840 に答える