VBScript二進制數組求助（Windows 10 1607的bug？）

我有一個工作的.vbs文件，它讀取一個二進制文件，更改一個字節並保存文件。直到Windows 1607，這在許多不同的Windows系統上運行良好。VBScript二進制數組求助（Windows 10 1607的bug？）

但是，現在使用1607及更高版本的Windows 10不再有效！我已經更改了代碼，因爲讀取的文件代碼在1607年已不再正常工作，但我仍然遇到 data = Mid(data, 1, 21) & Chr(b21) & Mid(data, 23)行在Windows之前完美工作的問題 10 1607！

我得到

（60，3）ADODB.Stream：參數的錯誤類型，超出可接受的範圍內，或在彼此的衝突。

此代碼在桌面上創建一個快捷方式，然後更改一個字節的一個位，以便該快捷方式將以管理員身份運行。如果我評論一下違規線路，那麼它似乎就可以工作。

這是Windows 10 1607 VBScript中的錯誤嗎？

' Make shortcut on Desktop and Set as Run As Admin 
Q = Chr(34) 
Dim fso 
Dim curDir 
Dim WinScriptHost 

If WScript.Arguments.Count < 2 Then 
    WScript.Echo "Please run CreateShortcuts.cmd" 
    WScript.Quit 
End If 

' --- SET Target and Desktop Link Name from command line --- 

strTargetName = WScript.Arguments.Item(0) 
strLinkName = WScript.Arguments.Item(1) 

'Target - e.g. %windir%\system32\cmd.exe /c C:\"temp\MakePartImage_AutoRun_FAT32.cmd" 

Set WshShell = CreateObject("WScript.Shell") 
Set fso = CreateObject("Scripting.FileSystemObject") 
strWinDir =WshShell.ExpandEnvironmentStrings("%windir%") 
strSysDir = strWinDir & "\System32" 
strMyDir = fso.GetParentFolderName(wscript.ScriptFullName) 
strDesktop = WshShell.SpecialFolders("Desktop") 
strCurDir = WshShell.CurrentDirectory ' e.g. C:\temp 

strMyDirSpecial = Mid(strMyDir, 1, 3) & Q & Mid(strMyDir, 4) & "\" & strTargetName & Q 
Set oMyShortCut= WshShell.CreateShortcut(strDesktop + "\" & strLinkName) 
oMyShortCut.WindowStyle = 1        '1=default 3=max 7=Min 
oMyShortCut.TargetPath = Q & strSysDir & "\cmd.exe" & Q 
oMyShortCut.Arguments= " /c " & strMyDirSpecial 
oMyShortcut.IconLocation = "%windir%\system32\cmd.exe" 
oMyShortCut.WorkingDirectory = Q & strMyDir & Q 
oMyShortCut.Save 
Set fso = Nothing 

'read binary geometry into byte array 
Dim stream, data 
Set stream = CreateObject("ADODB.Stream") 
stream.Open 
stream.Type = 1 
stream.LoadFromFile(strDesktop + "\" & strLinkName) 
data = stream.Read 
stream.Close 
WScript.Echo "BYTES 16-23 " & Hex(Asc(Mid(data, 16, 1))) & " " & Hex(Asc(Mid(data, 17, 1))) & " " & Hex(Asc(Mid(data, 18, 1))) & " " & Hex(Asc(Mid(data, 19, 1))) & " " & Hex(Asc(Mid(data, 20, 1))) & " " & Hex(Asc(Mid(data, 21, 1))) & " " & Hex(Asc(Mid(data, 22, 1))) & " " & Hex(Asc(Mid(data, 23, 1))) 
' --- PATCH .LNK FILE to set byte 21 bit 5 for Admin rights 
Dim b21 
b21 = Asc(Nid(data, 22, 1)) Or 32 'set bit 6 0x20  
' THIS NEXT LINE CAUSES PROBLEMS! 
data = Mid(data, 1, 21) & Chr(b21) & Mid(data, 23) 
WScript.Echo "BYTES 16-23 " & Hex(Asc(Mid(data, 16, 1))) & " " & Hex(Asc(Mid(data, 17, 1))) & " " & Hex(Asc(Mid(data, 18, 1))) & " " & Hex(Asc(Mid(data, 19, 1))) & " " & Hex(Asc(Mid(data, 20, 1))) & " " & Hex(Asc(Mid(data, 21, 1))) & " " & Hex(Asc(Mid(data, 22, 1))) & " " & Hex(Asc(Mid(data, 23, 1))) 

Const adTypeBinary = 1 
Const adTypeText = 2 
Const adSaveCreateOverWrite = 2 
Dim BinaryStream 
Set BinaryStream = CreateObject("ADODB.Stream") 
BinaryStream.Type = adTypeBinary 
BinaryStream.Open 
BinaryStream.Write data 
BinaryStream.SaveToFile strDesktop+"\" & strLinkName, adSaveCreateOverWrite 

WScript.Echo "Shortcut " & strLinkName & " created on Desktop."

來源

2017-03-27 SSi

是它的Windows操作系統版本，體系結構*（32比64位）*或兩者那已經改變了？ – Lankymart

我使用Win 10 64位。直到幾個星期前，它工作正常。現在它不起作用。另一位用戶表示這是1607更新，也是最新的預發佈更新，兩者都顯示出問題。我的版本現在是1607，它不再起作用，所以我認爲它是1607中的錯誤。 – SSi

它在1607 Build 14303.3.969上失敗。我嘗試了Win 10 1607 Build 14393.3.0的全新安裝，並且vbscript也能正常工作。所以問題是由KB後期更新引起的？ – SSi

' THIS NEXT LINE CAUSES PROBLEMS! 
data = Mid(data, 1, 21) & Chr(b21) & Mid(data, 23)

這條線會導致問題，因爲它改變了數據從字節（）的類型爲字符串。這可以說明：

WScript.Echo TypeName(data) 
' THIS NEXT LINE CAUSES PROBLEMS! 
data = Mid(data, 1, 21) & Chr(b21) & Mid(data, 23) 
WScript.Echo TypeName(data)

ADODB Stream.Write函數只接受Byte（）數組。

的解決方案是使用此功能從motobit網站：

' http://www.motobit.com/tips/detpg_binarytostring/ 
Function MultiByteToBinary(MultiByte) 
    '� 2000 Antonin Foller, http://www.motobit.com 
    ' MultiByteToBinary converts multibyte string To real binary data (VT_UI1 | VT_ARRAY) 
    ' Using recordset 
    Dim RS, LMultiByte, Binary 
    Const adLongVarBinary = 205 
    Set RS = CreateObject("ADODB.Recordset") 
    LMultiByte = LenB(MultiByte) 
    If LMultiByte>0 Then 
    RS.Fields.Append "mBinary", adLongVarBinary, LMultiByte 
    RS.Open 
    RS.AddNew 
     RS("mBinary").AppendChunk MultiByte & ChrB(0) 
    RS.Update 
    Binary = RS("mBinary").GetChunk(LMultiByte) 
    End If 
    MultiByteToBinary = Binary 
End Function

但字符串需要先轉換爲多字節。爲了這個目的還有另外一個功能：

' http://www.motobit.com/help/regedit/pa26.htm 
'Converts unicode string to a multibyte string 
Function StringToMB(S) 
    Dim I, B 
    For I = 1 To Len(S) 
    B = B & ChrB(Asc(Mid(S, I, 1))) 
    Next 
    StringToMB = B 
End Function

所以，這是如何使其工作：

data = Mid(data, 1, 21) & Chr(b21) & Mid(data, 23) 
data = MultiByteToBinary(StringToMB(data))

來源

2017-11-20 09:30:45 Hermolaou

VBScript二進制數組求助（Windows 10 1607的bug？）

回答

相關問題