BitShift

'Ôóíêöèÿ îñóùåñòâëÿåò ïîáèòîâûé ñäâèã öåëîãî ÷èñëà number â ñòîðîíó ñòàðøèõ ðàçðÿäîâ íà êîëè÷åñòâî,
'ðàâíîå bitCount (â ñëó÷àå îòðèöàòåëüíîãî bitCount - ñäâèã â ñòîðîíó ìëàäøèõ ðàçðÿäîâ).
Public 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