I have found the solution. To write data to a binary file two bytes at a time is possible, but the increase ins speed is just marginal (in my old laptop). I forgot you can add a "&" suffix to a number to declare it as a long. Here is the code:
fn=CreateObject("Scripting.FileSystemObject").GetSpecialFolder(2)& "\testwchr.bmp"
Function long2wstr( x) 'falta muy poco!!!
Dim k1,k2,x1
k1=((x And &h7fff) Or (&H8000& And ((X And &h8000&)<>0)))
k2=((X And &h7fffffff&) \ &h10000&) Or (&H8000& And ((X And &h80000000&) <>0 ))
long2wstr=chrw(k1) & chrw(k2)
End Function
Function wstr2long(s)
x1=AscW(mid(s,1,1))
xx1=x1-(65536 *(x1<0))
x2=AscW(mid(s,2,1))
wstr2long=x2*65536+xx1
End Function
Function rndlong() rndlong=CLng(4294967296* rnd()-2147483648+256*rnd) :End Function
Dim a(1000)
With CreateObject("ADODB.Stream")
.Charset = "UTF-16LE" 'o "UTF16-BE"
.Type = 2' adTypeText
.open
Randomize timer
For I=0 To 1000
a(i)=rndlong
.writetext long2wstr(a(i))
Next
.savetofile fn,2
.close
'now read the file to see if ADODB has changed anything
.open
.loadfromfile fn
.position=2 'skip bom
cnt=0
For I=0 To 1000
j= wstr2long(.readtext (2))
If j<>a(i) Then WScript.Echo a(i),j:cnt=cnt+1
Next
WScript.Echo cnt 'should print 0
.close
End With