VBspeed / Bits / StringToBitW
VBspeed © 2000-10, updated: 19-Nov-2001
StringToBitW
See also StringToBit, StringToBitB


StringToBit, StringToBitB, StringToBitW
StringToBit generally returns the bit-pattern (or bit-stream) representing a given input string.
We gotta deal with the ANSI/ASCII vs Unicode issue here, and this is how we do it:

StringToBit has *3 sub-disciplines* in analogy with the Asc-function:
  1. StringToBit:    8 bits per char, Unicode is converted to ANSI/ASCII
  2. StringToBitB:   8 bits per char, first Unicode byte (the upper unicode byte is ignored)
  3. StringToBitW:  16 bits per char, both Unicode bytes

For example: the Euro-sign "" = Unicode 8364 (&H20AC), ANSI/ASCII-code 128
  StringToBit("")  --> "10000000"          '=  128 =   &H80 =  Asc("")
  StringToBitB("") --> "10101100"          '=  172 =   &HAC = AscB("")
  StringToBitW("") --> "0010000010101100"  '= 8364 = &H20AC = AscW("")
Use this function (VB5/6-compatible) to verify the correctness of your StringToBit, StringToBitB, StringToBitW code.


Function StringToBitW
Returns the bit-pattern representing an input string. 16 bits per char, that's both Unicode bytes. For example:
  StringToBitW("abc") --> "000000000110000100000000011000100000000001100011"
  StringToBitW("") --> "0010000010101100"
Code
StringToBitW02
Public Function StringToBitW02(sData As String) As String
' by Donald, donald@xbeat.net, 20011027
  
  ' init byte-bits
  Static b As Long
  Static sByte(0 To 255) As String
  If b = 0 Then
    For b = 0 To 255
      sByte(b) = "00000000"
      If b And &H1& Then MidB$(sByte(b), 15&) = "1"
      If b And &H2& Then MidB$(sByte(b), 13&) = "1"
      If b And &H4& Then MidB$(sByte(b), 11&) = "1"
      If b And &H8& Then MidB$(sByte(b), 9&) = "1"
      If b And &H10& Then MidB$(sByte(b), 7&) = "1"
      If b And &H20& Then MidB$(sByte(b), 5&) = "1"
      If b And &H40& Then MidB$(sByte(b), 3&) = "1"
      If b And &H80& Then MidB$(sByte(b), 1&) = "1"
    Next
  End If
  
  ' string to bit
  Dim i As Long
  StringToBitW02 = Space$(LenB(sData) * 8)
  For i = 1 To LenB(sData) Step 2
    Mid$(StringToBitW02, i * 8 - 7) = sByte(AscB(MidB$(sData, i + 1)))
    Mid$(StringToBitW02, i * 8 + 1) = sByte(AscB(MidB$(sData, i)))
  Next
  
End Function
StringToBitW03
Public Function StringToBitW03(sData As String) As String
' by Donald, donald@xbeat.net, 20011027
  
  ' init byte-bits
  Static b As Long
  Static sByte(0 To 255) As String
  If b = 0 Then
    For b = 0 To 255
      sByte(b) = "00000000"
      If b And &H1& Then MidB$(sByte(b), 15&) = "1"
      If b And &H2& Then MidB$(sByte(b), 13&) = "1"
      If b And &H4& Then MidB$(sByte(b), 11&) = "1"
      If b And &H8& Then MidB$(sByte(b), 9&) = "1"
      If b And &H10& Then MidB$(sByte(b), 7&) = "1"
      If b And &H20& Then MidB$(sByte(b), 5&) = "1"
      If b And &H40& Then MidB$(sByte(b), 3&) = "1"
      If b And &H80& Then MidB$(sByte(b), 1&) = "1"
    Next
  End If
  
  ' string to bit
  Dim i As Long
  Dim abData() As Byte
  abData = sData
  StringToBitW03 = Space$(LenB(sData) * 8)
  For i = 0 To LenB(sData) - 1 Step 2
    Mid$(StringToBitW03, i * 8 + 1) = sByte(abData(i + 1))
    Mid$(StringToBitW03, i * 8 + 9) = sByte(abData(i))
  Next
  
End Function
StringToBitW04
Stuff you need for StringToBitW04:
1. Typelib BStrAPI (2KB, VB5-compatible, by G.Beckmann)

Private Declare Function ArrPtr& Lib "msvbvm60.dll" Alias "VarPtr" (ptr() As Any) Private Declare Sub RtlZeroMemory Lib "kernel32" (dst As Any, ByVal nBytes&) Private Declare Sub RtlMoveMemory Lib "kernel32" (dst As Any, src As Any, ByVal nBytes&) Private Declare Sub RtlFillMemory Lib "kernel32" (dst As Any, ByVal nBytes&, ByVal bFill As Byte)
Public Function StringToBitW04(sData As String) As String ' by G.Beckmann, G.Beckmann@NikoCity.de, 20011025 ' returns unicode string Static saSrc As bstrapi.SAFEARRAY1D, pSrc& Static saDst As bstrapi.SAFEARRAY1D, pDst& Static init&, aNibbles#(15) Dim c&, d&, e&, aSrc%(), aDst#() If init = 0 Then ReDim Preserve aSrc(3) For init = 0 To 15 d = 1: c = 3 Do Until c < 0 If init And d Then aSrc(c) = 49 Else aSrc(c) = 48 d = d * 2: c = c - 1 Loop RtlMoveMemory aNibbles(init), aSrc(0), 8 Next init Erase aSrc() saSrc.cDims = 1 saSrc.cbElements = 2 pSrc = VarPtr(saSrc) saDst.cDims = 1 saDst.cbElements = 8 pDst = VarPtr(saDst) End If c = Len(sData) StringToBitW04 = bstrapi.SysAllocStringLen(vbNullString, c * 16) saSrc.pvData = StrPtr(sData) saSrc.cElements1D = c saDst.pvData = StrPtr(StringToBitW04) saDst.cElements1D = c * 4 RtlMoveMemory ByVal ArrPtr(aSrc), pSrc, 4 RtlMoveMemory ByVal ArrPtr(aDst), pDst, 4 c = c - 1 Do Until c < 0 d = aSrc(c) And &HFFFF& '1 unicode-character -> 4 nibbles aDst(c * 4 + 3) = aNibbles(d And &HF) 'LoLo aDst(c * 4 + 2) = aNibbles((d \ &H10) And &HF) 'LoHi aDst(c * 4 + 1) = aNibbles((d \ &H100) And &HF) 'HiLo aDst(c * 4 + 0) = aNibbles(d \ &H1000) 'HiHi c = c - 1 Loop RtlZeroMemory ByVal ArrPtr(aSrc), 4 RtlZeroMemory ByVal ArrPtr(aDst), 4 End Function
StringToBitW05
Stuff you need for StringToBitW05:
1. Module modSafeArray_Paul.bas (2KB zipped, VB5-compatible).
2. Module modStringToBit05 (1KB zipped, VB5-compatible), portions shown below.
3. Typelib FastString (1KB, VB5-compatible, by Paul)  

Private lookup(0 To 15) As Currency
Public Function StringToBitW05(ByRef sData As String) As String ' by Paul, wpsjr1@syix.com, 20011027 Dim lInArrayPointer As Long Static cOut() As Currency Dim lLen As Long Dim i As Long Static iData() As Integer ' array shell used to contain string data Dim saIn As SAFEARRAYHEADER Static lInit As Long Static lLastLen As Long Dim iTemp As Integer lLen = Len(sData) If lLen Then ' not zero length lInArrayPointer = VarPtrArray(iData) If RedimArray(integerArray, lLen, saIn, StrPtr(sData), lInArrayPointer) Then If lInit Then Else lInit = 1 InitLookupTable End If If lLastLen <> lLen Then ReDim cOut(lLen * 4) ' one extra, but don't bother subtracting lLastLen = lLen For i = 0 To lLen - 1 iTemp = iData(i) cOut(i * 4) = lookup((iTemp And &HF000&) \ &H1000) cOut((i * 4) + 1) = lookup((iTemp And &HF00&) \ &H100) cOut((i * 4) + 2) = lookup((iTemp And &HF0) \ &H10) cOut((i * 4) + 3) = lookup(iTemp And &HF) Next i StringToBitW05 = FastString.SysAllocStringLen(cOut(0), lLen * 16) DestroyArray lInArrayPointer End If End If End Function
Private Sub InitLookupTable() lookup(0) = 1351100504368.7472@ ' magic numbers, magical mystery tour :P lookup(1) = 1379248002039.8128@ lookup(2) = 1351100933865.4768@ lookup(3) = 1379248431536.5424@ lookup(4) = 1351100504375.3008@ lookup(5) = 1379248002046.3664@ lookup(6) = 1351100933872.0304@ lookup(7) = 1379248431543.096@ lookup(8) = 1351100504368.7473@ lookup(9) = 1379248002039.8129@ lookup(10) = 1351100933865.4769@ lookup(11) = 1379248431536.5425@ lookup(12) = 1351100504375.3009@ lookup(13) = 1379248002046.3665@ lookup(14) = 1351100933872.0305@ lookup(15) = 1379248431543.0961@ End Sub
StringToBitW06
Stuff you need for StringToBitW06:
1. Module modSafeArray_Paul.bas (2KB zipped, VB5-compatible).
2. Module modStringToBit06 (1KB zipped, VB5-compatible), portions shown below.
3. Typelib FastString (1KB zipped, VB5-compatible, by Paul)  

Private lookup(0 To 255) As Currency
Public Function StringToBitW06(ByRef sData As String) As String ' by Paul, wpsjr1@syix.com, 20011029 Dim lLen As Long Dim lTemp As Long Static saIn As SAFEARRAYHEADER Static saOut As SAFEARRAYHEADER Static iData() As Integer ' array shell used to contain string data Static cOut() As Currency Static lInit As Long Static lpsaIn As Long Static lpsaOut As Long Static lInArrayPointer As Long Static lOutArrayPointer As Long lLen = Len(sData) If lInit Then Else lInit = 1 lInArrayPointer = VarPtrArray(iData) lOutArrayPointer = VarPtrArray(cOut) InitLookupTable With saIn .DataSize = 2 ' integer array .dimensions = 1 End With With saOut .DataSize = 8 ' currency array .dimensions = 1 End With lpsaIn = VarPtr(saIn) lpsaOut = VarPtr(saOut) End If With saIn .dataPointer = StrPtr(sData) .sab(0).cElements = lLen End With RtlMoveMemory ByVal lInArrayPointer, lpsaIn, 4 StringToBitW06 = FastString.SysAllocStringLen(ByVal 0&, lLen * 16) With saOut .dataPointer = StrPtr(StringToBitW06) .sab(0).cElements = lLen * 4 End With RtlMoveMemory ByVal lOutArrayPointer, lpsaOut, 4 If lLen Then Do lLen = lLen - 1 lTemp = iData(lLen) cOut((lLen * 4) + 3) = lookup(lTemp And &HF) cOut((lLen * 4) + 2) = lookup(lTemp And &HF0) cOut((lLen * 4) + 1) = lookup(lTemp \ &H100 And &HF) cOut(lLen * 4) = lookup(lTemp \ &H1000 And &HF) Loop While lLen End If RtlMoveMemory ByVal lInArrayPointer, 0&, 4 RtlMoveMemory ByVal lOutArrayPointer, 0&, 4 End Function
Private Sub InitLookupTable() Dim i As Long lookup(0) = 1351100504368.7472@ ' magic numbers, magical mystery tour :P lookup(1) = 1379248002039.8128@ lookup(2) = 1351100933865.4768@ lookup(3) = 1379248431536.5424@ lookup(4) = 1351100504375.3008@ lookup(5) = 1379248002046.3664@ lookup(6) = 1351100933872.0304@ lookup(7) = 1379248431543.096@ lookup(8) = 1351100504368.7473@ lookup(9) = 1379248002039.8129@ lookup(10) = 1351100933865.4769@ lookup(11) = 1379248431536.5425@ lookup(12) = 1351100504375.3009@ lookup(13) = 1379248002046.3665@ lookup(14) = 1351100933872.0305@ lookup(15) = 1379248431543.0961@ For i = 16 To 255 lookup(i) = lookup((i And &HF0) \ &H10) Next i End Sub
StringToBitW07
Stuff you need for StringToBitW07:
1. Typelib BStrAPI (2KB, VB5-compatible, by G.Beckmann)

Private Declare Function ArrPtr& Lib "msvbvm60.dll" Alias "VarPtr" (ptr() As Any) Private Declare Sub RtlZeroMemory Lib "kernel32" (dst As Any, ByVal nBytes&) Private Declare Sub RtlMoveMemory Lib "kernel32" (dst As Any, src As Any, ByVal nBytes&) Private Declare Sub RtlFillMemory Lib "kernel32" (dst As Any, ByVal nBytes&, ByVal bFill As Byte)
Public Function StringToBitW07(ByRef sData As String) As String ' by G.Beckmann, G.Beckmann@NikoCity.de, 20011119 Static saSrc As bstrapi.SafeArray1D Static saDst As bstrapi.SafeArray1D Static init& Static aLoNibbles#(0 To 255) Static aHiNibbles#(0 To 255) Static aSrc%() Static aDst#() Static pSrc&, psaSrc& Static pDst&, psaDst& Dim c&, d& If init = 0 Then ReDim Preserve aSrc(0 To 3) For init = 0 To 15 d = 1: c = 3 Do Until c < 0 If init And d Then aSrc(c) = 49 Else aSrc(c) = 48 d = d * 2: c = c - 1 Loop RtlMoveMemory aLoNibbles(init), aSrc(0), 8 Next init Erase aSrc() For c = 0 To 255 aLoNibbles(c) = aLoNibbles(c Mod 16) aHiNibbles(c) = aLoNibbles(c \ 16) Next c saSrc.cDims = 1 saSrc.cbElements = 2 saSrc.cElements1D = &H7FFFFFFF saDst.cDims = 1 saDst.cbElements = 8 saDst.cElements1D = &H7FFFFFFF pSrc = VarPtr(saSrc) pDst = VarPtr(saDst) psaSrc = ArrPtr(aSrc) psaDst = ArrPtr(aDst) End If c = LenB(sData) * 2 StringToBitW07 = bstrapi.SysAllocStringLenPtr(0, c * 4) saSrc.pvData = StrPtr(sData) saDst.pvData = StrPtr(StringToBitW07) RtlMoveMemory ByVal psaSrc, pSrc, 4 RtlMoveMemory ByVal psaDst, pDst, 4 Do Until c <= 0 c = c - 4 d = aSrc(c \ 4) And &HFFFF& aDst(c + 0) = aHiNibbles(d \ &H100) aDst(c + 1) = aLoNibbles(d \ &H100) aDst(c + 2) = aHiNibbles(d And &HFF) aDst(c + 3) = aLoNibbles(d And &HFF) Loop RtlZeroMemory ByVal psaSrc, 4 RtlZeroMemory ByVal psaDst, 4 End Function
StringToBitW08
Stuff you need for StringToBitW08:
1. Module modSafeArray_Paul.bas (2KB zipped, VB5-compatible).
2. Typelib FastString (1KB, VB5-compatible, by Paul)  

Private lookup(0 To 255) As Currency
Public Function StringToBitW08(ByRef sData As String) As String ' by Paul, wpsjr1@syix.com 20011120 ' doping FastString typelib Dim lLen As Long Dim lTemp As Long Dim lCounter As Long Static saIn As SAFEARRAYHEADER Static saOut As SAFEARRAYHEADER Static iData() As Integer ' array shell used to contain string data Static cOut() As Currency Static lInit As Long Static lpsaIn As Long Static lpsaOut As Long Static lInArrayPointer As Long Static lOutArrayPointer As Long lLen = LenB(sData) If lInit Then Else 'lInit = 1 ReDim iData(3) For lInit = 0 To 15 ' generate LUT lTemp = lInit iData(3) = 48 + (lTemp And 1) lTemp = lTemp \ 2 iData(2) = 48 + (lTemp And 1) lTemp = lTemp \ 2 iData(1) = 48 + (lTemp And 1) lTemp = lTemp \ 2 iData(0) = 48 + (lTemp And 1) RtlMoveMemory lookup(lInit), iData(0), 8 Next lInit For lInit = 16 To 255 lookup(lInit) = lookup((lInit And &HF0) \ &H10) Next lInit Erase iData lInArrayPointer = VarPtrArray(iData) lOutArrayPointer = VarPtrArray(cOut) With saIn .DataSize = 2 ' integer array .dimensions = 1 .sab(0).cElements = &H7FFFFFFF End With With saOut .DataSize = 8 ' currency array .dimensions = 1 .sab(0).cElements = &H7FFFFFFF End With lpsaIn = VarPtr(saIn) lpsaOut = VarPtr(saOut) End If saIn.dataPointer = StrPtr(sData) RtlMoveMemory ByVal lInArrayPointer, lpsaIn, 4 StringToBitW08 = FastString.SysAllocStringLen(ByVal 0&, lLen * 8) saOut.dataPointer = StrPtr(StringToBitW08) RtlMoveMemory ByVal lOutArrayPointer, lpsaOut, 4 lLen = lLen * 2 If lLen Then lLen = lLen - 1 lCounter = 0 Do lTemp = iData(lCounter \ 4) cOut(lCounter) = lookup(lTemp \ &H1000 And &HF) cOut(lCounter + 1) = lookup(lTemp \ &H100 And &HF) cOut(lCounter + 2) = lookup(lTemp And &HF0) cOut(lCounter + 3) = lookup(lTemp And &HF) lCounter = lCounter + 4 Loop While lCounter <= lLen End If FastString.RtlMoveMemory ByVal lInArrayPointer, 0& FastString.RtlMoveMemory ByVal lOutArrayPointer, 0& End Function
Calls
1sRet = StringToBitW("x") [1 char] --> "01111000"
2sRet = StringToBitW("xxx...xxx") [10 chars] --> "01111000 .... 01111000"
3sRet = StringToBitW("xxx...xxx") [100 chars] --> "01111000 .... 01111000"
4sRet = StringToBitW("xxx...xxx") [10000 chars] --> "01111000 .... 01111000"
Charts
 VB5 Charts
CodeAuthorDopingNotes
StringToBitW02 Donald  
StringToBitW03 Donald  
StringToBitW04 GuidoAPI,TLB 
StringToBitW05 PaulAPI,TLB 
StringToBitW06 PaulAPI,TLB 
StringToBitW07 GuidoAPI,TLB 
StringToBitW08 PaulAPI,TLB 
Call 1
61.774.401s
72.947.323s
51.403.490s
21.032.557s
31.062.647s
41.122.797s
11.002.492s
Call 2
77.9331.884s
64.2216.967s
51.234.949s
41.214.871s
11.004.019s
31.024.086s
21.004.025s
Call 3
720.97352s
66.33106s
31.1119s
51.5827s
21.0618s
11.0017s
41.1519s
Call 4
7273.06985,471s
63.4412,403s
31.033,733s
51.515,463s
21.023,696s
11.003,609s
41.053,806s
 VB6 Charts
CodeAuthorDopingNotes
StringToBitW02 Donald  
StringToBitW03 Donald  
StringToBitW04 GuidoAPI,TLB 
StringToBitW05 PaulAPI,TLB 
StringToBitW06 PaulAPI,TLB 
StringToBitW07 GuidoAPI,TLB 
StringToBitW08 PaulAPI,TLB 
Call 1
61.624.215s
72.927.591s
51.443.738s
21.132.937s
11.002.602s
41.183.083s
31.152.994s
Call 2
77.7731.312s
63.6014.518s
41.275.119s
51.325.314s
11.004.028s
21.104.436s
31.124.512s
Call 3
719.82342s
64.1471s
31.0819s
51.3824s
21.0318s
11.0017s
41.1520s
Call 4
7271.53986,707s
62.448,872s
21.023,689s
51.495,400s
31.023,708s
11.003,634s
41.053,813s
Conclusions
Please, stop fighting! The tables get too long!
Got comments? How to read all those numbers

top




VBspeed © 2000-10 by Donald Lessau