如何修改VBS脚本使Office 365将签名保存至用户账户而非设备

我司使用VBS脚本生成并更新Outlook邮箱签名已近10年，日常仅修改脚本中的网页图片路径。该脚本从AD读取用户信息后生成签名，原本会保存至用户邮箱账户下。但近期发现，安装Office 365许可的新设备上，脚本将签名保存至“此设备上的签名”而非用户账户，下周更新圣诞签名时，Office 365用户的现有签名无法被更新。相关脚本代码如下：

脚本第一部分：检测Outlook #

'Option Explicit
On Error Resume Next
DEBUGMODEON = FALSE 'USED FOR FAULT FINDING AND DEBUGGING, SET TO FALSE FOR PRODUCTION USE

boolocksig = TRUE ' USED TO PREVENT USER FROM CHANGING SIGNATURE

'FIRST CHECK TO SEE IF OUTLOOK IS INSTALLED.  IF SO RECORD THE VERSION, IF NOT ALERT THE USER AND QUIT
If AppPathExist("outlook.exe") Then
    If DEBUGMODEON <> FALSE Then
        WScript.Echo "Outlook is installed, version is: " & GetVersion("outlook.exe")
    End if
    strOutlookVer = GetVersion("outlook.exe")
else
    WScript.Echo "Outlook has not been detected.  Quitting!"
    WScript.Quit
end if

'GET FILE PATH FOR COMMON USE APPS
Function AppPathExist(sProgram) 
    sAppPathsBase = "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\" 
    sAppPathExe = RegRead(sAppPathsBase & sProgram & "\") 
    If sAppPathExe <> "" Then 
        AppPathExist = True 
    Else 
        AppPathExist = False 
    End If 
End Function 

'PULL VERSION FROM EXE
Function GetVersion(sProgram) 
    GetVersion = "Unknown" ' init value 
    sAppPathsBase = "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\" 
    sFilePath = RegRead(sAppPathsBase & sProgram & "\") 
    Set oFSO = CreateObject("Scripting.FileSystemObject") 
    If oFSO.FileExists(sFilePath) Then 
        sFileVer = oFSO.GetFileVersion(sFilePath) 
        If sFileVer <> "" Then 
            aFileVer = Split(sFileVer, ".") 
            GetVersion = aFileVer(0) 
        End If 
    End If 
End Function 

'REGISTRY READING FUNCTION
Function RegRead(sRegValue) 
    Set oShell = CreateObject("WScript.Shell") 
    On Error Resume Next 
    RegRead = oShell.RegRead(sRegValue) 
    ' If the value does not exist, error is raised 
    If Err Then 
        RegRead = "" 
        Err.clear 
    End If 
    ' If a value is present but uninitialized the RegRead method 
    ' returns the input value in Win2k. 
    If VarType(RegRead) < vbArray Then 
        If RegRead = sRegValue Then 
            RegRead = "" 
        End If 
    End If 
    On Error Goto 0 
End Function 

'IF DEBUG MODE ON THEN REPORT OUTLOOK DETECTION AS COMPLETE
If DEBUGMODEON <> FALSE Then
        WScript.Echo "Outlook Detection Complete"
End if       

脚本第三部分：生成签名 #

' This section creates the signature files names and locations.
'====================
' Corrects Outlook signature folder location. Just to make sure that
' Outlook is using the purposed folder defined with variable : strFolderLocation
' Changing this in a production environmont might create extra work
' all employees are missing their old signatures
'====================
Dim objShell, RegKey, RegKeyParm
Set objShell = CreateObject("WScript.Shell")
RegKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & strOutlookVer & ".0\Common\General"
RegKey = RegKey & "\Signatures"
objShell.RegWrite RegKey , "Signatures"
strUserDataPath = ObjShell.ExpandEnvironmentStrings("%appdata%")
strFolderLocation = strUserDataPath &"\Microsoft\Signatures\"
strHtmFileString = strFolderLocation & strSignatureName & ".htm"

' This section checks if the signature directory exits and if not creates one.
'====================
Dim objFS1
Set objFS1 = CreateObject("Scripting.FileSystemObject")
If (objFS1.FolderExists(strFolderLocation)) Then
Else
    Call objFS1.CreateFolder(strFolderLocation)
End if

' The next section builds the signature file
'====================
Dim objFSO
Dim objFile,afile
Dim aQuote
aQuote = chr(34)

' This section builds the HTML file version
'====================
Set objFSO = CreateObject("Scripting.FileSystemObject")

' This section deletes to other signatures.
' These signatures are automaticly created by Outlook 2003.
'====================
Set AFile = objFSO.GetFile(strFolderLocation & strSignatureName & ".rtf")
aFile.Delete
Set AFile = objFSO.GetFile(strFolderLocation & strSignatureName & ".txt")
aFile.Delete

Set objFile = objFSO.CreateTextFile(strHtmFileString,True)
objFile.Close
Set objFile = objFSO.OpenTextFile(strHtmFileString, 2)

If DEBUGMODEON <> FALSE Then
        WScript.Echo "objFile = " & objFile.Path &vbcrlf & "strFullName = " & strFullName &vbcrlf & "Writing HTML to File."
End if


'I HAVE REMOVED A LARGE SECTION OF CODE HERE BUT THIS WAS JUST CREATING OUR SIGNATURE IN HTML


If DEBUGMODEON <> FALSE Then
        WScript.Echo "HTML File Generated"
End if
' ===========================
' This section readsout the current Outlook profile and then sets the name of the default Signature
' ===========================
' Use this version to set all accounts
' in the default mail profile
' to use a previously created signature
If DEBUGMODEON <> FALSE Then
        WScript.Echo "Attempting to Set Default Signature"
End if
Call SetDefaultSignature(strSignatureName,"")

' Use this version (and comment the other) to
' modify a named profile.
'Call SetDefaultSignature _
' ("Signature Name", "Profile Name")

Sub SetDefaultSignature(strSigName, strProfile)
    
    dim objReg
    Const HKEY_CURRENT_USER = &H80000001
    strComputer = "."
    If DEBUGMODEON <> FALSE Then
        WScript.Echo "Checking if Outlook is running"
    End if
    If Not IsOutlookRunning Then
        If DEBUGMODEON <> FALSE Then
            WScript.Echo "Outlook isn't running"
        End if
        Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\" & strComputer & "\root\default:StdRegProv")
        strKeyPath = "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\"
        ' get default profile name if none specified
        If strProfile = "" Then
            objReg.GetStringValue HKEY_CURRENT_USER, strKeyPath, "DefaultProfile", strProfile
        End If
        ' build array from signature name
        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
            If DEBUGMODEON <> FALSE Then
                WScript.Echo "Add New Signature Option To registry: " & strsubkeypath
            End if
            'objReg.SetBinaryValue HKEY_CURRENT_USER, _
            'strsubkeypath, "Reply-Forward Signature", myArray
        Next
        
        if booLockSig <> FALSE Then
            If DEBUGMODEON <> FALSE Then
            WScript.Echo "Locking Signature"
            End if
            objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\11.0\Common\MailSettings\NewSignature" , strSignatureName
        End if
        
        If DEBUGMODEON <> FALSE Then
            WScript.Echo "Preventing Outlook Embedding the Images: HKEY_CURRENT_USER\Software\Microsoft\Office\" & strOutlookVer & ".0\Outlook\Options\Mail\Send Pictures With Document=0"
        End if
        objReg.SetDWordValue HKEY_CURRENT_USER,"Software\Microsoft\Office\" & strOutlookVer & ".0\Outlook\Options\Mail\", "Send Pictures With Document" , "0"
    Else
        strMsg = "Please shut down Outlook before running this script."
        MsgBox strMsg, vbExclamation, "Outlook Signature Generator"
        WScript.Quit
    End If
End Sub

Function IsOutlookRunning()
    dim objWMIService
    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)
    ' Input: normal text
    ' Output: four-character string for each character,
    ' e.g. "3204" for lower-case Russian B,
    ' "6500" for ASCII e
    ' Output: correct characters
    ' needs to reverse order of bytes from 0432
    Dim strAll
    For i = 1 To Len(Data)
        ' get the four-character hex for each character
        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

If DEBUGMODEON <> FALSE Then
    WScript.Echo "Script Complete. Exiting"
End if

针对Office 365环境下的签名存储问题，需对脚本做以下4处关键修改：

1. 动态判断签名存储路径 #

Office 365（Click-to-Run版本）的签名默认存储路径与传统Outlook不同，需先检测版本再切换路径：
替换脚本中设置strFolderLocation的代码段：

' 原代码
strUserDataPath = ObjShell.ExpandEnvironmentStrings("%appdata%")
strFolderLocation = strUserDataPath &"\Microsoft\Signatures\"

替换为：

' 判断是否为Office 365版本
Dim isO365
isO365 = False
If strOutlookVer = "16" Then
    Dim o365RegPath
    o365RegPath = "HKEY_CURRENT_USER\Software\Microsoft\Office\16.0\Outlook\Setup\ClickToRun"
    If RegRead(o365RegPath) <> "" Then
        isO365 = True
    End If
End If

' 设置签名路径
If isO365 Then
    ' 优先使用账户专属漫游签名路径
    Dim accountSigPath
    accountSigPath = ObjShell.ExpandEnvironmentStrings("%userprofile%\AppData\Local\Microsoft\Outlook\RoamedSignatures")
    If objFS1.FolderExists(accountSigPath) Then
        strFolderLocation = accountSigPath & "\"
    Else
        '  fallback到传统漫游路径
        strRoamingPath = ObjShell.ExpandEnvironmentStrings("%userprofile%\AppData\Roaming\Microsoft\Signatures")
        strFolderLocation = strRoamingPath & "\"
    End If
Else
    ' 传统版本路径
    strUserDataPath = ObjShell.ExpandEnvironmentStrings("%appdata%")
    strFolderLocation = strUserDataPath &"\Microsoft\Signatures\"
End If

2. 更新注册表签名位置配置 #

原脚本强制写入固定注册表值，需改为动态匹配Office 365路径：
替换原注册表写入代码：

RegKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & strOutlookVer & ".0\Common\General"
RegKey = RegKey & "\Signatures"
objShell.RegWrite RegKey , "Signatures"

替换为：

RegKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & strOutlookVer & ".0\Common\General"
RegKey = RegKey & "\Signatures"
If isO365 Then
    objShell.RegWrite RegKey , strFolderLocation
Else
    objShell.RegWrite RegKey , "Signatures"
End If

3. 修正签名锁定的注册表路径 #

原脚本硬编码Office 11.0路径，需替换为当前检测的版本：
替换原锁定签名代码：

objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\11.0\Common\MailSettings\NewSignature" , strSignatureName

替换为：

objShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\" & strOutlookVer & ".0\Common\MailSettings\NewSignature" , strSignatureName

4. 添加新Outlook配置的签名支持 #

Office 365新Outlook使用不同注册表项存储默认签名，需在SetDefaultSignature子过程中添加以下代码（放在For Each subkey In arrProfileKeys循环之后）：

' 针对Office 365新Outlook的默认签名设置
If isO365 Then
    Dim newOutlookKeyPath
    newOutlookKeyPath = "Software\Microsoft\Office\" & strOutlookVer & ".0\Outlook\Profiles\" & strProfile & "\Accounts"
    objReg.EnumKey HKEY_CURRENT_USER, newOutlookKeyPath, arrAccountKeys
    For Each accountKey In arrAccountKeys
        Dim accountSubKeyPath
        accountSubKeyPath = newOutlookKeyPath & "\" & accountKey
        ' 设置新邮件签名
        objReg.SetBinaryValue HKEY_CURRENT_USER, accountSubKeyPath, "New Signature", myArray
        ' 可选：设置回复/转发签名
        ' objReg.SetBinaryValue HKEY_CURRENT_USER, accountSubKeyPath, "Reply-Forward Signature", myArray
    Next
End If

内容的提问来源于stack exchange，提问作者SaintKev