VBScript binary array help wanted (Windows 10 1607 bug?) - arrays

Question

I have a working .vbs file which reads a binary file, changes one byte and the saves the file. Up until Windows 1607 this worked fine on many different Windows systems.
However, now with 1607 and later versions of Windows 10 it no longer works!
I have changed the code because the read file code I had no longer works correctly in 1607, but I am still having problems with the
data = Mid(data, 1, 21) & Chr(b21) & Mid(data, 23) line which worked perfectly before Windows 10 1607!
I get
(60, 3) ADODB.Stream: Arguments are of the wrong type, are out of acceptable range, or are in conflict with one another.
This code creates a shortcut on the Desktop and then changes one bit of one byte so that the shortcut will be run as admin. If I comment out the offending line then it seems to work.
Is this a bug in 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."

Answer 1

' THIS NEXT LINE CAUSES PROBLEMS!
data = Mid(data, 1, 21) & Chr(b21) & Mid(data, 23)
This line causes problems because it changes the type of data from Byte() to String. This would illustrate it:
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 function only accepts Byte() arrays.
The solution is to use this function from motobit website:
' 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
But the string needs to be converted to multi-byte first. For this purpose there is another 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
So, this is how to make it work:
data = Mid(data, 1, 21) & Chr(b21) & Mid(data, 23)
data = MultiByteToBinary(StringToMB(data))