送分100分：如何将"10101101"直接压缩到一个字节中去。

问题如下：

   DIM A AS STRING ,B AS BYTE,C AS LONG，D(1) AS BYTE

1、A="10101101"
   如何将A直接赋值给B。

2、C=123456
   如何根据条件，随意将C的4个字节（即32位）中的某位置0或置1。

3、C=123456
   如何随意读取C的4个字节（即32位）中的某位的值。

4、不同于第一个问题：C=1234  如何让D(0)的高四位为1低四位为2。
                                   D(1)的高四位为3低四位为4。

   --------------------编程问答-------------------- 第一个问题



Public Function BitToHex(ByVal Data As String) As String

    Dim str As String, I As Integer, C As Integer

    Data = Data & String((8 - (Len(Data) Mod 8)) Mod 8, "0")

    BitToHex = ""

    For I = 1 To Len(Data) Step 4

        str = Mid(Data, I, 4)

        Select Case str

            Case "0000"

                BitToHex = BitToHex & "0"

            Case "1000"

                BitToHex = BitToHex & "1"

            Case "0100"

                BitToHex = BitToHex & "2"

            Case "1100"

                BitToHex = BitToHex & "3"

            Case "0010"

                BitToHex = BitToHex & "4"

            Case "1010"

                BitToHex = BitToHex & "5"

            Case "0110"

                BitToHex = BitToHex & "6"

            Case "1110"

                BitToHex = BitToHex & "7"

            Case "0001"

                BitToHex = BitToHex & "8"

            Case "1001"

                BitToHex = BitToHex & "9"

            Case "0101"

                BitToHex = BitToHex & "A"

            Case "1101"

                BitToHex = BitToHex & "B"

            Case "0011"

                BitToHex = BitToHex & "C"

            Case "1011"

                BitToHex = BitToHex & "D"

            Case "0111"

                BitToHex = BitToHex & "E"

            Case "1111"

                BitToHex = BitToHex & "F"

        End Select

    Next

    C = Len(BitToHex) \ 2

    str = ""

    For I = 0 To C - 1

        str = str & Mid(BitToHex, I * 2 + 2, 1)

        str = str & Mid(BitToHex, I * 2 + 1, 1)

    Next

    BitToHex = str

End Function



Public Function HexToBit(ByVal Data As String) As String

    Dim C As Integer, I As Integer, CH As String

    If Len(Data) Mod 2 = 1 Then Data = "0" & Data

    C = Len(Data) \ 2

    For I = 0 To C - 1

        HexToBit = HexToBit & Mid(Data, I * 2 + 2, 1)

        HexToBit = HexToBit & Mid(Data, I * 2 + 1, 1)

    Next

    Data = HexToBit

    HexToBit = ""

    For I = 0 To Len(Data)

        Select Case LCase(Mid(Data, I + 1, 1))

            Case "0"

                HexToBit = HexToBit & "0000"

            Case "1"

                HexToBit = HexToBit & "1000"

            Case "2"

                HexToBit = HexToBit & "0100"

            Case "3"

                HexToBit = HexToBit & "1100"

            Case "4"

                HexToBit = HexToBit & "0010"

            Case "5"

                HexToBit = HexToBit & "1010"

            Case "6"

                HexToBit = HexToBit & "0110"

            Case "7"

                HexToBit = HexToBit & "1110"

            Case "8"

                HexToBit = HexToBit & "0001"

            Case "9"

                HexToBit = HexToBit & "1001"

            Case "a"

                HexToBit = HexToBit & "0101"

            Case "b"

                HexToBit = HexToBit & "1101"

            Case "c"

                HexToBit = HexToBit & "0011"

            Case "d"

                HexToBit = HexToBit & "1011"

            Case "e"

                HexToBit = HexToBit & "0111"

            Case "f"

                HexToBit = HexToBit & "1111"

        End Select

    Next

End Function

--------------------编程问答-------------------- 第三个问题
CBool(C and 2^某位)
如,第十二位
CBool(C and 2^12) 如果是0返回False 是1返回True --------------------编程问答-------------------- 第四个问题
用动态数组
Dim D() As Byte
D=HexToArr(hex(1234))'函数参数是十六进制字符串



public Function HexToArr(str As String) As Byte()

    Dim C As Integer, I As Integer, Arr() As Byte, CH As String

    On Error GoTo hErr

    C = Len(str) \ 2 - 1

    ReDim Arr(C)

    For I = 0 To C

        CH = Mid(str, I * 2 + 1, 2)

        Arr(I) = CByte("&H" & CH)

    Next

    HexToArr = Arr

hErr:

End Function

--------------------编程问答-------------------- 顶一下~~ --------------------编程问答-------------------- 第二个问题
如
c=123456
setbit C,True,0 '把第0位置1
setbit C,False,11 '把第11位置0



Public Sub SetBit(ByRef Value As Long, ByVal Bit As Boolean, ByVal Pos As Integer)

    Dim V As Long

    V = IIf(Bit = True, 1, 0) * 2 ^ Pos

    If V = 0 Then

        V = (2 ^ Pos) Xor &HFFFFFFFF

        Value = Value And V

    Else

        Value = V Or Value

    End If

End Sub

--------------------编程问答-------------------- 第一个问题用的程序是单片机上的小尾结构,顺序和我们电脑上是相反的 --------------------编程问答--------------------

--------------------编程问答--------------------

引用 6 楼 bakw 的回复:

第一个问题用的程序是单片机上的小尾结构,顺序和我们电脑上是相反的

不懂,怎么和单片机扯上关系了? --------------------编程问答-------------------- ..................... --------------------编程问答--------------------

引用 8 楼 bcrun 的回复:

引用 6 楼 bakw 的回复:

第一个问题用的程序是单片机上的小尾结构,顺序和我们电脑上是相反的

不懂,怎么和单片机扯上关系了?

程序代码我没改,这个是我写单片机通讯时候用的程序 --------------------编程问答-------------------- 没有现成的函数吗？
--------------------编程问答-------------------- 二进制转八进制和十六进制代码 --------------------编程问答-------------------- 第一个问题：



Public Function BIN_to_DEC(ByVal Bin As String) As Variant

    Dim i As Integer

    BIN_to_DEC = CDec(BIN_to_DEC)

    For i = 1 To Len(Bin)

        BIN_to_DEC = BIN_to_DEC * 2 + Mid(Bin, i, 1)

    Next i

    

End Function



Private Sub Command1_Click()

    Dim b As Byte

    Dim a As String

    a = "10101101"

    b = BIN_to_DEC(a)

    MsgBox b

    

End Sub

--------------------编程问答-------------------- 第一个问题：
　　网上代码大把大把的。
　　我就不贴代码了。

'第二、三个问题的代码：

' 32位整数，位的序号为 0 ～31

' 最低位为 0位、最高位为 31位

Private Sub Form_Click()

' 测试代码

    Dim i&

    Me.Cls

    Me.Print "getBit(&HD0000006,  0) = "; getBit(&HD0000006, 0)

    Me.Print "getBit(&HD0000006,  1) = "; getBit(&HD0000006, 1)

    Me.Print "getBit(&HD0000006,  2) = "; getBit(&HD0000006, 2)

    Me.Print "getBit(&HD0000006, 29) = "; getBit(&HD0000006, 29)

    Me.Print "getBit(&HD0000006, 30) = "; getBit(&HD0000006, 30)

    Me.Print "getBit(&HD0000006, 31) = "; getBit(&HD0000006, 31)

    For i = 0 To 31

        Me.Print i, Right$("00000000" & Hex$(setBit(0, i)), 8), Right$("00000000" & Hex$(setBit(-1, i, False)), 8)

    Next

End Sub



'　函数功能：设置/清除 指定位

Public Function setBit(ByVal value As Long, ByVal Pos As Long, _

                        Optional ByVal bSet As Boolean = True) As Long

    Dim lMask As Long

    If (Pos > 31 Or Pos < 0) Then setBit = value: Exit Function

    If (Pos = 31) Then

        If (bSet) Then

            setBit = value Or &H80000000

        Else

            setBit = value And &H7FFFFFFF

        End If

    Else

        lMask = Not (2 ^ Pos Xor CLng(bSet))

        If (bSet) Then

            setBit = value Or lMask

        Else

            setBit = value And lMask

        End If

    End If

End Function



'　函数功能：获取指定位

Public Function getBit(ByVal value As Long, ByVal Pos As Long) As Long

    If (Pos > 31 Or Pos < 0) Then getBit = 0: Exit Function

    If (Pos = 31) Then

        getBit = (value < 0) And 1

    Else

        getBit = ((value And 2 ^ Pos) > 0) And 1

    End If

End Function

--------------------编程问答-------------------- 学习了,谢谢各位.. --------------------编程问答-------------------- 帮顶。。。。。。。。。。。。。 --------------------编程问答--------------------

貌似说完了... ... --------------------编程问答--------------------

引用楼主 tigherqq 的回复:

2、C=123456
如何根据条件，随意将C的4个字节（即32位）中的某位置0或置1。

第二题：



Private Sub Command2_Click()

'VB6 32位长整没有无符号长整。

'VB6 32位长整最高位是符号位，0为正，1为负

'本程序从右到左1-32位，对应底层二进制位的0-31位

   

   Dim c As Long

   c = -1               '底层32个1

   c = bitSet(c, 0, 32) '最高位置0

   Debug.Print c        '观查结果

   c = 255              '底层8个1

   c = bitSet(c, 0, 8)  '第8位置0

   Debug.Print c        '观查结果

   '--------------------------

   c = 1                '底层最底位为1其它位为0

   c = bitSet(c, 1, 32) '最高位置1，结果将成为负数

   Debug.Print c        '观查结果

   c = 127              '底层7个1

   c = bitSet(c, 1, 8)  '第8位置1

   Debug.Print c        '观查结果

End Sub





Function bitSet(ByVal Source As Long, ByVal setup As Byte, bit As Byte)

    If bit > 32 Or bit < 1 Then

        MsgBox "bit不能大于32或小于1": Exit Function

    ElseIf setup > 1 Or setup < 0 Then

        MsgBox "setup只可以是0或1": Exit Function

    ElseIf bit = 32 Then

        If setup = 0 Then bitSet = Source And 2147483647

        If setup = 1 Then bitSet = Source Or -2147483648#

    Else

        If setup = 0 Then bitSet = Source And (-2 ^ (bit - 1) - 1)

        If setup = 1 Then bitSet = Source Or 2 ^ (bit - 1)

    End If

End Function

--------------------编程问答--------------------

引用楼主 tigherqq 的回复:

3、C=123456
如何随意读取C的4个字节（即32位）中的某位的值。

第三题：



Private Sub Command1_Click()

'从右向左1-32位

   Dim a As Byte, c As Long

   c = 1

   a = getBitValue(c, 32)

   Debug.Print a

   c = -1

   a = getBitValue(c, 32)

   Debug.Print a

   c = 55

   a = getBitValue(c, 4)

   Debug.Print a

End Sub



Function getBitValue(ByVal source As Long, bit As Byte)

   If bit > 32 Or bit < 1 Then

      MsgBox "bit不能大于32不能小于1": Exit Function

   ElseIf bit = 32 Then

      If source >= 0 Then getBitValue = 0 Else getBitValue = 1

   Else

      getBitValue = source And 2 ^ (bit - 1)

   End If

End Function

--------------------编程问答-------------------- 第四题：



Private Sub Command1_Click()

   Dim c As Integer: c = 1234

   Dim b As String: b = Format(c, "0000")

   Dim D(1) As Byte

   D(0) = "&H" & Left(b, 2) '18

   D(1) = "&H" & Right(b, 2) '52

End Sub

--------------------编程问答-------------------- 问题一

Private Sub Command1_Click()

Dim A As String, B As Byte

Dim i As Long



A = "10101101"

B = 0

For i = 1 To 8

    Dim temp As Byte

    temp = 0

    temp = CByte(Mid$(A, i, 1))

    temp = temp * 2 ^ (8 - i)

    B = B Or temp



    

Next

End Sub

--------------------编程问答-------------------- 问题二：

Private Sub Command1_Click()

    Dim C As Long

    Dim pos As Long '0开头的位置

    

    C = 5

    pos = 1

    

    Dim temp As Long

    Dim temp1 As Long

    temp1 = &HFFFFFFFF

    

    temp = 2 ^ pos

    '把pos位置1

    C = C Or temp

    temp1 = temp1 Xor temp

    '置0

    C = C And temp1

    

End Sub

--------------------编程问答-------------------- 请大家要注意一个问题：

2^n　　当 n 大于 30 时，会出现溢出错误！

　　所以上面的代码中，对 Long 的最高位操作时（读位、置１、清０），如果代码中没有单独针对那一位进行操作的代码，都应该说是有BUG的。
--------------------编程问答-------------------- 谢谢楼上提醒，byte是无符号的,int是有符号的。 --------------------编程问答-------------------- DIM A AS STRING ,B AS BYTE,C AS LONG，D(1) AS BYTE

1、A="10101101"
如何将A直接赋值给B。

解答：
Dim bytVal(7) As Byte
'bytVal(0) 至 bytVal(7)的值分别为
'&H01,&H02, &H04, &H08, &H10, &H20, &H40, &H80

Private Function StringToByte(ByVal strVal As String) As Byte
    Dim lLen As Long
    Dim bRet As Byte
    Dim lPos As Long
    bRet = 0
    lPos = 0
    lLen = Len(strVal)
    Do While lLen > 0
        If Mid$(strVal, lLen, 1) = "1" Then
            bRet = bRet + bytVal(lPos)
        End If
        lPos = lPos + 1
        lLen = lLen - 1
    Loop
    StringToByte = bRet
End Function

2、C=123456
如何根据条件，随意将C的4个字节（即32位）中的某位置0或置1。
解答：
Dim lVal(32) As Long
'lVal(0) 至 lVal(31)的值分别为
'&H00000001,&H00000002, &H00000004, &H08, &H00000010, &H00000020,……&H40000000, &H80000000
如果要将C的某个字节置0，比如说第10位置0，则C = C And (Not lVal(10))，当然如果事先保存lVal各位的反码，速度会更快。
如果要将C的某个字节置1，比如说第11位置1，则C = C Or lVal(11)

3、C=123456
如何随意读取C的4个字节（即32位）中的某位的值。
解答：
Dim lVal(32) As Long
'lVal(0) 至 lVal(31)的值分别为
'&H00000001,&H00000002, &H00000004, &H08, &H00000010, &H00000020,……&H40000000, &H80000000
比如判断C的第10位的值，只要判断C Or lVal(10)的值是否为1即可，结果为1则为1，为0则为0。

4、不同于第一个问题：C=1234 如何让D(0)的高四位为1低四位为2。
D(1)的高四位为3低四位为4。
解答：
Dim i As Long
Dim j As Long
Dim strVal As Long
Dim lLen As Long
strVal = CStr(C)
lLen = strVal
For i = 0 to 1
    For j = 1 to lLen / 2
    D(i) = (D(i) And &H0F) Or CByte(Mid$(strVal, i * 2 + 1, 1))
    D(i) = (D(i) And &HF0) Or CByte(Mid$(strVal, i * 2 + 2, 1))
    Next j
Next i

--------------------编程问答--------------------

解决

补充：VB ,  网络编程