Results 1 to 1 of 1

Thread: [RESOLVED] Who have vb6 code of SHA3_224?

  1. #1

    Thread Starter
    PowerPoster
    Join Date
    Jan 2020
    Posts
    3,746

    Resolved [RESOLVED] Who have vb6 code of SHA3_224?

    Who have vb6 code of SHA3_224?

    Code:
    Sub MAIN()
    TestSHA3Functions
    End Sub
    Sub TestSHA3Functions()
     
      
    ' Create a new test
    Dim SHATestTxt As String
      
    SHATestTxt = "Cc123456"
    MsgBox SHA3_224(SHATestTxt) & vbCrLf & "The correct value should be:" & vbCrLf & "4d9a9b213f1518cb46243b5676365b08312d57eeb124874b16767697"
    '正确值应
    End Sub
    
    Function SHA3_224(msg As String, Optional opt As Dictionary) As String
    'Hash224
    'Generates 224-bit SHA-3 / Keccak hash of message.
    'String msg - String to be hashed (Unicode-safe).
    'Dictionary options - padding: sha-3 / keccak; msgFormat: string / hex; outFormat: hex / hex-b / hex-w.
    SHA3_224 = Keccak1600(1152, 448, msg, opt)
    
    End Function
    
    Function Keccak1600(R As Integer, C As Integer, msg As String, Optional opt As Dictionary) As String
        
    'Generates SHA-3 / Keccak hash of message M.
    'Integer r - Bitrate 'r' (b-c)
    'Integer c - Capacity 'c' (b-r), md length ?2
    'String msg - Message
    'Dictionary options - padding: sha-3 / keccak; msgFormat: string / hex; outFormat: hex / hex-b / hex-w.
    '{string} Hash as hex-encoded string.
        
        
    'const defaults = { padding: 'sha-3', msgFormat: 'string', outFormat: 'hex' };
    Set OptDefaults = New Scripting.Dictionary
    OptDefaults.Add "padding", "sha-3"
    OptDefaults.Add "msgFormat", "string"
    OptDefaults.Add "outFormat", "hex"
        
    If opt Is Nothing Then Set opt = New Scripting.Dictionary
    For Each k In OptDefaults.Keys
        If Not opt.Exists(k) Then
            opt.Add k, OptDefaults(k)
        End If
    Next k
        
    MsgLen = C / 2
    ' message digest output length in bits
        
    '
    If opt("msgFormat") = "hex-bytes" Then
        'NOT IMPLEMENTED YET, hexBytesToString(M)
        'msg = StrConv(msg, vbUnicode)
    Else
        'utf8Encode(M)
        'msg = StrConv(msg, vbUnicode)
    End If
    
    '2d array
    Dim state(0 To 4, 0 To 4, 0 To 1) As Currency
    Dim squeezeState(0 To 4, 0 To 4) As String
    ' last dimension: 0 = lo, 1 = hi
    ' * Keccak state is a 5 ?5 x w array of bits (w=64 for keccak-f[1600] / SHA-3).
    ' * Here, it is implemented as a 5 ?5 array of Long. The first subscript (x) defines the
    ' * sheet, the second (y) defines the plane, together they define a lane. Slices, columns,
    ' * and individual bits are obtained by bit operations on the hi,lo components of the Long
    ' * representing the lane.
    
    q = (R / 8) - Len(msg) Mod (R / 8)
    If q = 1 Then
        If opt("padding") = "keccak" Then
            msg = msg & Chr$(129)
        Else
            msg = msg & Chr$(134)
        End If
    Else
        If opt("padding") = "keccak" Then
            msg = msg & Chr$(1)
        Else
            msg = msg & Chr$(6)
        End If
        msg = msg & String(q - 2, Chr$(0))
        msg = msg & Chr$(128)
    End If
    
    'Debug.Print "q", q, Len(msg), msg,
    
    w = 64  'for keccak-f[1600]
    blocksize = R / w * 8
    
    'Debug.Print w, blocksize
    
    i = 0
    Do While i < Len(msg)
        j = 0
        Do While j < R / w
            lo = LeftShift(CLng(Asc(Mid(msg, i + j * 8 + 0 + 1, 1))), 0, 32) + _
                    LeftShift(CLng(Asc(Mid(msg, i + j * 8 + 1 + 1, 1))), 8, 32) + _
                    LeftShift(CLng(Asc(Mid(msg, i + j * 8 + 2 + 1, 1))), 16, 32) + _
                    LeftShift(CLng(Asc(Mid(msg, i + j * 8 + 3 + 1, 1))), 24, 32)
            hi = LeftShift(CLng(Asc(Mid(msg, i + j * 8 + 4 + 1, 1))), 0, 32) + _
                    LeftShift(CLng(Asc(Mid(msg, i + j * 8 + 5 + 1, 1))), 8, 32) + _
                    LeftShift(CLng(Asc(Mid(msg, i + j * 8 + 6 + 1, 1))), 16, 32) + _
                    LeftShift(CLng(Asc(Mid(msg, i + j * 8 + 7 + 1, 1))), 24, 32)
            x = j Mod 5
            y = Int(j / 5)
            
            'Debug.Print "x,y lo,hi ", i & "," & j & "  " & lo & "," & hi
            state(x, y, 0) = state(x, y, 0) Xor lo
            state(x, y, 1) = state(x, y, 1) Xor hi
            j = j + 1
        Loop
    
        newstate = keccak_f_1600(state)
        
        i = i + blocksize
    Loop
    
    'Squeeze state
    For i = 0 To 4
        For j = 0 To 4
            v1 = state(i, j, 0)
            v2 = state(i, j, 1)
            If v1 >= 2 ^ (32 - 1) Then v1 = v1 - 2 ^ (32)
            If v2 >= 2 ^ (32 - 1) Then v2 = v2 - 2 ^ (32)
            s1 = Hex(v1)
            s2 = Hex(v2)
            If Len(s1) < 8 Then s1 = String$(8 - Len(s1), "0") & s1
            If Len(s2) < 8 Then s2 = String$(8 - Len(s2), "0") & s2
            
            squeezeState(i, j) = LCase(s2 & s1)
            'Debug.Print i, j, squeezeState(i, j)
        Next j
    Next i
    
    ResStr = ""
    For j = 0 To 4
        For i = 0 To 4
            For k = 8 To 1 Step -1
                ResStr = ResStr & Mid(squeezeState(i, j), 2 * k - 1, 2)
            Next k
            'Debug.Print ResStr
        Next i
    Next j
    
    Keccak1600 = Left(ResStr, MsgLen / 4)
    
    '// if required, group message digest into bytes or words
    'if (opt.outFormat == 'hex-b') md = md.match(/.{2}/g).join(' ');
    'if (opt.outFormat == 'hex-w') md = md.match(/.{8,16}/g).join(' ');
    
    'Debug.Print "END HERE!"
    '550b320103b1f401"
    '550b32013b1f401
    'b87f88c72702fff1748e58b87e9141a42c0dbedc29a78cb0d4a5cd81a96abded
    'b87f88c72702fff1748e58b87e9141a42c0dbedc29a78cb0d4a5cd81a96abded52f214ef4fb788ba
    
    End Function
    
    
      
    Function keccak_f_1600(StateIn)
    
    nRounds = 24
    
    '2d array
    Dim RCs
    RCs = Array("0000000000000001", "0000000000008082", "800000000000808a", "8000000080008000", "000000000000808b", "0000000080000001", _
                "8000000080008081", "8000000000008009", "000000000000008a", "0000000000000088", "0000000080008009", "000000008000000a", _
                "000000008000808b", "800000000000008b", "8000000000008089", "8000000000008003", "8000000000008002", "8000000000000080", _
                "000000000000800a", "800000008000000a", "8000000080008081", "8000000000008080", "0000000080000001", "8000000080008008")
    Dim RC(0 To 23, 0 To 1) As Currency
    
    For R = 0 To UBound(RCs)
        RC(R, 0) = HexToDec_C(Right(RCs(R), 8))
        RC(R, 1) = HexToDec_C(Left(RCs(R), 8))
        'Put data back into Long range, as shifts are binary
        If RC(R, 0) >= 2 ^ (32 - 1) Then RC(R, 0) = RC(R, 0) - 2 ^ (32)
        If RC(R, 1) >= 2 ^ (32 - 1) Then RC(R, 1) = RC(R, 1) - 2 ^ (32)
        'Debug.Print "hi " & RC(R, 1) & "   lo " & RC(R, 0)
    Next R
    
    '// Keccak-f permutations
    For R = 0 To nRounds - 1
        'Debug.Print "r:" & R
        'Debug.Print "Keccak 2.3.2"
        'Debug.Print StateIn(0, 0, 0), StateIn(0, 0, 1)
    
        Dim C(0 To 4, 0 To 1) As Currency
        For x = 0 To 4
            C(x, 0) = StateIn(x, 0, 0)
            C(x, 1) = StateIn(x, 0, 1)
            For y = 1 To 4
                'Debug.Print "xy chi " & x & y & "  " & C(x, 1)
                'Debug.Print "xy clo " & x & y & "  " & C(x, 0)
                C(x, 1) = Xor_C(C(x, 1), StateIn(x, y, 1))
                C(x, 0) = Xor_C(C(x, 0), StateIn(x, y, 0))
            Next y
        Next x
        
        'Debug.Print "Keccak 2.3.2 bis"
        'Debug.Print StateIn(0, 0, 0), StateIn(0, 0, 1)
        
        For x = 0 To 4
            'Debug.Print "D hi- " & x & "  " & C((x + 4) Mod 5, 1)
            'Debug.Print "D lo- " & x & "  " & C((x + 4) Mod 5, 0)
            Dim Rt(0 To 1) As Currency
            Rt(0) = C((x + 1) Mod 5, 0)
            Rt(1) = C((x + 1) Mod 5, 1)
            Rr = rotl(Rt, 1)
            'Debug.Print "D rot hi- " & x & "  " & Rr(1)
            'Debug.Print "D rot lo- " & x & "  " & Rr(0)
            
            hi = Xor_C(C((x + 4) Mod 5, 1), Rr(1))
            lo = Xor_C(C((x + 4) Mod 5, 0), Rr(0))
            Dim D(0 To 4, 0 To 1) As Currency
            D(x, 1) = hi
            D(x, 0) = lo
            For y = 0 To 4
                StateIn(x, y, 1) = Xor_C(StateIn(x, y, 1), D(x, 1))
                StateIn(x, y, 0) = Xor_C(StateIn(x, y, 0), D(x, 0))
            Next y
        Next x
        
        'Debug.Print "Keccak 2.3.4"
        'Debug.Print StateIn(0, 0, 0), StateIn(0, 0, 1)
        
        xa = 1
        ya = 0
        Dim tmp(0 To 1) As Currency
        Dim cur(0 To 1) As Currency
        'ReDim Rt(0 To 1) As Long
        cur(0) = StateIn(xa, ya, 0)
        cur(1) = StateIn(xa, ya, 1)
        For t = 0 To 23
            xb = ya
            yb = (2 * xa + 3 * ya) Mod 5
            'Debug.Print t, xb, yb
            tmp(0) = StateIn(xb, yb, 0)
            tmp(1) = StateIn(xb, yb, 1)
            
            Rr = rotl(cur, ((t + 1) * (t + 2) / 2) Mod 64)
            StateIn(xb, yb, 0) = Rr(0)
            StateIn(xb, yb, 1) = Rr(1)
            
            cur(0) = tmp(0)
            cur(1) = tmp(1)
            
            xa = xb
            ya = yb
        Next t
        
        
        'Debug.Print "Keccak 2.3.1"
        'Debug.Print StateIn(0, 0, 0), StateIn(0, 0, 1)
        
        For y = 0 To 4
            Erase C
            For x = 0 To 4
                C(x, 0) = StateIn(x, y, 0)
                C(x, 1) = StateIn(x, y, 1)
            Next x
            For x = 0 To 4
                StateIn(x, y, 1) = RightShiftZF(Xor_C(C(x, 1), And_C(Not_C(C((x + 1) Mod 5, 1)), C((x + 2) Mod 5, 1))), 0)
                StateIn(x, y, 0) = RightShiftZF(Xor_C(C(x, 0), And_C(Not_C(C((x + 1) Mod 5, 0)), C((x + 2) Mod 5, 0))), 0)
                'StateIn(x, y, 1) = RightShiftZF(C(x, 1) Xor ((Not C((x + 1) Mod 5, 1) And C((x + 2) Mod 5, 1))), 0)
                'StateIn(x, y, 0) = RightShiftZF(C(x, 0) Xor ((Not C((x + 1) Mod 5, 0) And C((x + 2) Mod 5, 0))), 0)
            Next x
        Next y
    
        'Debug.Print "Keccak 2.3.5"
        'Debug.Print StateIn(0, 0, 0), StateIn(0, 0, 1)
    
        'Debug.Print "a00-lo1:", StateIn(0, 0, 0), DecToBin_C(StateIn(0, 0, 0), 32)
        'Debug.Print "RCr-lo1:", RC(R, 0), DecToBin_C(StateIn(0, 0, 0), 32)
        
        StateIn(0, 0, 1) = RightShiftZF(Xor_C(StateIn(0, 0, 1), RC(R, 1)), 0)
        StateIn(0, 0, 0) = RightShiftZF(Xor_C(StateIn(0, 0, 0), RC(R, 0)), 0)
    
        'Debug.Print "a00-lo2:", StateIn(0, 0, 0), DecToBin_C(StateIn(0, 0, 0), 32)
        
    Next R
    
    End Function
    
    
    Function rotl(ObjIn() As Currency, n As Byte) As Currency()
        
        'Debug.Print "ROTL data: ", ObjIn(0), ObjIn(1), n
        
        Dim m As Byte
        'Rotate left
        Dim R(0 To 1) As Currency
        If n < 32 Then
            m = 32 - n
            lo_1 = LeftShift(ObjIn(0), n, 32)
            lo_2 = RightShiftZF(ObjIn(1), m, 32)
            hi_1 = LeftShift(ObjIn(1), n, 32)
            hi_2 = RightShiftZF(ObjIn(0), m, 32)
            
            lo = lo_1 Or lo_2
            hi = hi_1 Or hi_2
    '       const lo = this.lo<<n | this.hi>>>m;
    '       const hi = this.hi<<n | this.lo>>>m;
            R(0) = lo
            R(1) = hi
        ElseIf n = 32 Then
            R(0) = ObjIn(0)
            R(1) = ObjIn(1)
        ElseIf n > 32 Then
            n = n - 32
            m = 32 - n
            lo_1 = LeftShift(ObjIn(1), n, 32)
            lo_2 = RightShiftZF(ObjIn(0), m, 32)
            hi_1 = LeftShift(ObjIn(0), n, 32)
            hi_2 = RightShiftZF(ObjIn(1), m, 32)
            lo = lo_1 Or lo_2
            hi = hi_1 Or hi_2
    '       const lo = this.hi<<n | this.lo>>>m;
    '       const hi = this.lo<<n | this.hi>>>m;
            R(0) = lo
            R(1) = hi
        End If
        rotl = R()
        
    End Function
    
    'INSPRIRED BY:
    'https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Operators/Bitwise_Operators
    'https://www.mrexcel.com/forum/excel-questions/578667-use-dec2bin-function-vba-edit-macro.html
    'https://vbaf1.com/variables/data-types/
     
    Function DecToBin_C(DecimalIn As Variant, OutputLen As Byte, Optional IsSigned As Boolean = True) As String
    'need_DecToBin_C
        If IsSigned Then
            'Signed value in, e.g. len = 16 -> -32,768 to 32,767
            MinDecVal = CDec(-2 ^ (OutputLen - 1))
            MaxDecVal = CDec(2 ^ (OutputLen - 1) - 1)
        Else
            'Unsigned value in, e.g. len = 16  -> 0 to 65535
            MinDecVal = CDec(0)
            MaxDecVal = CDec(2 ^ OutputLen - 1)
        End If
        
        DecToBin2 = ""
        DecCalc = CDec(DecimalIn)
        If DecCalc < MinDecVal Or DecCalc > MaxDecVal Then
            'Error (6) 'overflow -> error normally off, giving back an empty string, but can switch it on
            DecToBin_C = DecToBin2
            Exit Function
        End If
        
        Do While DecimalIn <> 0
            DecToBin2 = Trim$(Str$(DecCalc - 2 * Int(DecCalc / 2))) & DecToBin2
            DecCalc = Int(DecCalc / 2)
            'Escape for maximum length (negative numbers):
            If Len(DecToBin2) = OutputLen Then Exit Do
        Loop
        DecToBin_C = Right$(String$(OutputLen, "0") & DecToBin2, OutputLen)
        
    End Function
    Function BinToDec_C(StringIn As String, Optional IsSigned As Boolean = True) As Variant
        'need_BinToDec_C
        'Input assumed to be a Signed number, otherwise use IsSigned = False
        Dim StrLen As Byte
        StrLen = Len(StringIn)
        BinToDec_C = 0
        If Left(StringIn, 1) = "1" And IsSigned Then
            'negative number, signed
             For i = 1 To Len(StringIn)
                If Mid(StringIn, StrLen + 1 - i, 1) = "0" Then
                    BinToDec_C = BinToDec_C + 2 ^ (i - 1)
                End If
            Next i
            BinToDec_C = -BinToDec_C - 1
        Else
            'positive number, can be signed or unsigned
            For i = 1 To Len(StringIn)
                If Mid(StringIn, StrLen + 1 - i, 1) = "1" Then
                    BinToDec_C = BinToDec_C + 2 ^ (i - 1)
                End If
            Next i
        End If
        
    End Function
    
    Function LeftShift(ValIn As Variant, Shift As Byte, Optional DefaultLen As Byte = 1, Optional IsSigned As Boolean = True) As Variant
        'need LeftShift
        '<<  Zero fill left shift - Shifts left by pushing zeros in from the right and let the leftmost bits fall off
        If DefaultLen = 1 Then
            ' DefaultLen -> will get the most appropriate value of 8 (byte), 16 (integer), 32 (long), 64 (longlong)
            DefaultLen = GetDefaultLen(ValIn, IsSigned)
        End If
        
        Dim TempStr As String
        TempStr = DecToBin_C(ValIn, DefaultLen, IsSigned)
        TempStr = Right$(TempStr & String$(Shift, "0"), DefaultLen)
        LeftShift = BinToDec_C(TempStr, IsSigned)
        
    End Function
    
    
    Function RightShiftZF(ValIn As Variant, Shift As Byte, Optional DefaultLen As Byte = 1, Optional IsSigned As Boolean = True) As Variant
        'need_RightShiftZF
        '>>> Zero fill right shift   Shifts right by pushing zeros in from the left, and let the rightmost bits fall off
        'Also called: Unsigned Right Shift [>>>]
        If DefaultLen = 1 Then
            ' DefaultLen -> will get the most appropriate value of 8 (byte), 16 (integer), 32 (long), 64 (longlong)
            DefaultLen = GetDefaultLen(ValIn, IsSigned)
        End If
        
        Dim TempStr As String
        TempStr = DecToBin_C(ValIn, DefaultLen, IsSigned)
        TempStr = Left$(String$(Shift, "0") & TempStr, DefaultLen)
        RightShiftZF = BinToDec_C(TempStr, IsSigned)
    End Function
    
    Function HexToDec_C(hexString As String) As Variant
    'need_HexToDec_C
        'https://stackoverflow.com/questions/40213758/convert-hex-string-to-unsigned-int-vba#40217566
        'cut off "&h" if present
        If Left(hexString, 2) = "&h" Or Left(hexString, 2) = "&H" Then hexString = Mid(hexString, 3)
    
        'cut off leading zeros
        While Left(hexString, 1) = "0"
            hexString = Mid(hexString, 2)
        Wend
        
        If hexString = "" Then hexString = "0"
        HexToDec_C = CDec("&h" & hexString)
        'correct value for 8 digits onle
        'Debug.Print hexString, HexToDec_C
        If HexToDec_C < 0 And Len(hexString) = 8 Then
            HexToDec_C = CDec("&h1" & hexString) - 4294967296#
        'cause overflow for 16 digits
        ElseIf HexToDec_C < 0 Then
            Error (6) 'overflow
        End If
    
    End Function
    Function GetDefaultLen(ValIn As Variant, IsSigned As Boolean) As Byte
    'need_GetDefaultLen
    If IsSigned Then
        'Signed value in, e.g. len = 16 -> -32,768 to 32,767
        If CDec(ValIn) >= -2 ^ (8 - 1) And CDec(ValIn) <= 2 ^ (8 - 1) - 1 Then
            GetDefaultLen = 8 '8 (byte)
        ElseIf CDec(ValIn) >= -2 ^ (16 - 1) And CDec(ValIn) <= 2 ^ (16 - 1) - 1 Then
            GetDefaultLen = 16 '16 (integer)
        ElseIf CDec(ValIn) >= -2 ^ (32 - 1) And CDec(ValIn) <= 2 ^ (32 - 1) - 1 Then
            GetDefaultLen = 32 '32 (long)
        ElseIf CDec(ValIn) >= -2 ^ (64 - 1) And CDec(ValIn) <= 2 ^ (64 - 1) - 1 Then
            GetDefaultLen = 64 '64 (longlong)
        Else
            'Number too big for function, return max value that Currency can represent
            GetDefaultLen = 96
        End If
    Else
        'Unsigned value in, e.g. len = 8  -> 0 to 255
        If CDec(ValIn) <= 2 ^ 8 - 1 And CDec(ValIn) >= 0 Then
            GetDefaultLen = 8 '8 (byte)
        ElseIf CDec(ValIn) <= 2 ^ 16 - 1 And CDec(ValIn) >= 0 Then
            GetDefaultLen = 16 '16 (integer)
        ElseIf CDec(ValIn) <= 2 ^ 32 - 1 And CDec(ValIn) >= 0 Then
            GetDefaultLen = 32 '32 (long)
        ElseIf CDec(ValIn) <= 2 ^ 64 - 1 And CDec(ValIn) >= 0 Then
            GetDefaultLen = 64 '64 (longlong)
        Else
            'Number too big for function, return max value that Currency can represent
            GetDefaultLen = 96
        End If
    End If
    
    End Function
    
    Function Not_C(ValIn1 As Variant, Optional IsSigned As Boolean = True) As Variant
        'need_Not_C
        Dim s3 As String
        Dim s1len As Byte
        d1 = CDec(ValIn1)
        
        UseDefault = True
        If IsSigned = True Then
            If d1 < -2 ^ (32 - 1) Or d1 > 2 ^ (32 - 1) - 1 Then UseDefault = False
        Else
            UseDefault = False
        End If
        
        If UseDefault Then
            Not_C = Not ValIn1
        Else
            'Check size and sign
            s1len = GetDefaultLen(d1, IsSigned)
            s1 = DecToBin_C(d1, s1len, IsSigned)
            s3 = ""
            For C = 1 To s1len
                If Mid(s1, C, 1) = "1" Then
                    s3 = s3 & "0"
                Else
                    s3 = s3 & "1"
                End If
            Next C
            Not_C = BinToDec_C(s3, IsSigned)
        End If
        
    End Function
    Function And_C(ValIn1 As Variant, ValIn2 As Variant, Optional IsSigned As Boolean = True) As Variant
    'need_And_C
        And_C = OrAndXor_C("AND", ValIn1, ValIn2, IsSigned)
    End Function
    
    Function Xor_C(ValIn1 As Variant, ValIn2 As Variant, Optional IsSigned As Boolean = True) As Variant
    'need_Xor_C
        Xor_C = OrAndXor_C("XOR", ValIn1, ValIn2, IsSigned)
    End Function
    Function OrAndXor_C(Func As String, ValIn1 As Variant, ValIn2 As Variant, Optional IsSigned As Boolean = True) As Variant
    'need_OrAndXor_C
        Dim s3 As String
        Dim maxlen As Byte
        d1 = CDec(ValIn1)
        d2 = CDec(ValIn2)
        Func = LCase(Func)
        
        UseDefault = True
        If IsSigned = True Then
            If d1 < -2 ^ (32 - 1) Or d1 > 2 ^ (32 - 1) - 1 Then UseDefault = False
            If d2 < -2 ^ (32 - 1) Or d2 > 2 ^ (32 - 1) - 1 Then UseDefault = False
        Else
            UseDefault = False
        End If
        
        If UseDefault Then
            If Func = "xor" Then
                OrAndXor_C = d1 Xor d2
            ElseIf Func = "or" Then
                OrAndXor_C = d1 Or d2
            ElseIf Func = "and" Then
                OrAndXor_C = d1 And d2
            Else
                OrAndXor_C = False
            End If
        Else
            If IsSigned Then
                'Too big for a 32 bit long, go for 64 bit
                s1 = DecToBin_C(d1, 64)
                s2 = DecToBin_C(d2, 64)
                s3 = ""
                For C = 1 To 64
                    If Func = "xor" Then
                        If Mid(s1, C, 1) = Mid(s2, C, 1) Then
                            s3 = s3 & "0"
                        Else
                            s3 = s3 & "1"
                        End If
                    ElseIf Func = "or" Then
                        If Mid(s1, C, 1) = 1 Or Mid(s2, C, 1) = 1 Then
                            s3 = s3 & "1"
                        Else
                            s3 = s3 & "0"
                        End If
                    ElseIf Func = "and" Then
                        If Mid(s1, C, 1) = 1 And Mid(s2, C, 1) = 1 Then
                            s3 = s3 & "1"
                        Else
                            s3 = s3 & "0"
                        End If
                    End If
                Next C
                OrAndXor_C = BinToDec_C(s3)
            Else
                'Treat as unsigned
                s1len = GetDefaultLen(d1, False)
                s2len = GetDefaultLen(d2, False)
                
                If s1len > s2len Then maxlen = s1len Else maxlen = s2len
                
                s1 = DecToBin_C(d1, maxlen, False)
                s2 = DecToBin_C(d2, maxlen, False)
                s3 = ""
                
                For C = 1 To maxlen
                    If Func = "xor" Then
                        If Mid(s1, C, 1) = Mid(s2, C, 1) Then
                            s3 = s3 & "0"
                        Else
                            s3 = s3 & "1"
                        End If
                    ElseIf Func = "or" Then
                        If Mid(s1, C, 1) = 1 Or Mid(s2, C, 1) = 1 Then
                            s3 = s3 & "1"
                        Else
                            s3 = s3 & "0"
                        End If
                    ElseIf Func = "and" Then
                        If Mid(s1, C, 1) = 1 And Mid(s2, C, 1) = 1 Then
                            s3 = s3 & "1"
                        Else
                            s3 = s3 & "0"
                        End If
                    End If
                Next C
                OrAndXor_C = BinToDec_C(s3, False)
            
            End If
        End If
    
    End Function
     
    Function Or_C(ValIn1 As Variant, ValIn2 As Variant, Optional IsSigned As Boolean = True) As Variant
        '不需要
        Or_C = OrAndXor_C("OR", ValIn1, ValIn2, IsSigned)
    End Function
    Function RightShift(ValIn As Variant, Shift As Byte, Optional DefaultLen As Byte = 1, Optional IsSigned As Boolean = True) As Variant
        '不需要
        '>>  Signed right shift  Shifts right by pushing copies of the leftmost bit in from the left, and let the rightmost bits fall off
        'Also called: Signed Right Shift [>>]
        If DefaultLen = 1 Then
            ' DefaultLen -> will get the most appropriate value of 8 (byte), 16 (integer), 32 (long), 64 (longlong)
            DefaultLen = GetDefaultLen(ValIn, IsSigned)
        End If
        
        Dim TempStr As String
        Dim FillStr As String
        TempStr = DecToBin_C(ValIn, DefaultLen, IsSigned)
        FillStr = Left(TempStr, 1)
        TempStr = Left$(String$(Shift, FillStr) & TempStr, DefaultLen)
        RightShift = BinToDec_C(TempStr, IsSigned)
        
    End Function
    Last edited by xiaoyao; Oct 27th, 2021 at 08:44 AM.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width