BitShift

Attribute VB_Name = "BitShift"

'Функция осуществляет побитовый сдвиг целого числа number в сторону старших разрядов на количество,
'равное bitCount (в случае отрицательного bitCount - сдвиг в сторону младших разрядов).
Function Shift(ByVal number As Variant, ByVal bitCount As Long) As Variant
    Dim i As Long, size As Long, mask As Variant, mask_ As Variant, vtype As VbVarType
    Dim tolow As Boolean, signed As Boolean, signchange As Boolean
    vtype = VarType(number)
    Select Case vtype
        Case vbByte
            size = 8
            signed = False
        Case vbInteger
            size = 16
            signed = True
        Case vbLong
            size = 32
            signed = True
        Case vbCurrency
            size = 64
            signed = True
        Case Else
            Err.Raise 5, "Shift", "Аргумент number должен быть целочисленным (типа Byte, Integer, Long или Currency)."
    End Select
    If bitCount = 0 Then
        Shift = number
        Exit Function
    ElseIf bitCount < 0 Then
        bitCount = -bitCount
        tolow = True
    End If
    If bitCount < size Then
        Select Case True
            Case Not tolow And Not signed
                mask = 1
                For i = 1 To size - 1
                    mask = mask * 2
                Next i
                mask = mask - 1
                For i = 1 To bitCount
                    number = (number And mask) * 2
                Next i
            Case Not tolow And signed
                If vtype = vbCurrency Then
                    mask_ = 0.0001@
                    mask = -mask_
                Else
                    mask = -1
                    mask_ = 1
                End If
                For i = 1 To size - 2
                    mask = mask * 2
                    mask_ = mask_ * 2
                Next i
                mask = mask * 2
                For i = 1 To bitCount
                    number = number And Not mask 'Обнуляем знаковый разряд.
                    If (number And mask_) = mask_ Then 'Если есть бит перед знаковым разрядом...
                        number = number And Not mask_ '...то убираем его.
                        signchange = True
                    End If
                    number = number * 2 'Осуществляем сдвиг в сторону старших разрядов.
                    If signchange Then  'Если был убран бит перед знаковым разрядом...
                        number = number Or mask   '...то вставляем его в знаковый разряд.
                        signchange = False
                    End If
                Next i
            Case tolow And Not signed
                For i = 1 To bitCount
                    number = number \ 2
                Next i
            Case tolow And signed
                If vtype = vbCurrency Then
                    mask_ = CCur(1) / CCur(10000)
                    mask = -mask_
                Else
                    mask = -1
                    mask_ = 1
                End If
                For i = 1 To size - 2
                    mask = mask * 2
                    mask_ = mask_ * 2
                Next i
                mask = mask * 2
                For i = 1 To bitCount
                    If (number And mask) = mask Then 'Если есть бит в знаковом разряде...
                        number = number And Not mask '...то обнуляем знаковый разряд.
                        signchange = True
                    End If
                    number = number \ 2 'Осуществляем сдвиг в сторону младших разрядов.
                    If signchange Then  'Если был убран бит из знакового разряда...
                        number = number Or mask_  '...то вставляем его в бит перед знаковым разрядом.
                        signchange = False
                    End If
                Next i
        End Select
        Shift = number
    Else
        Select Case vtype
            Case vbByte
                Shift = CByte(0)
            Case vbInteger
                Shift = 0
            Case vbLong
                Shift = 0&
            Case vbCurrency
                Shift = 0@
        End Select
    End If
End Function