mod_movebit.bas

一个根据s7200协议写的驱动控件

Attribute VB_Name = "mod_movebit"
'1.逻辑左移
Public Function BSHL(OPR As Byte, n As Integer) As Byte
Dim BD As Byte
Dim i As Integer
BD = OPR
For i = 1 To n - 1
BD = (BD And &H7F) * 2 '将D7位屏蔽左移，防止字节溢出
Next i
CF = BD And &H80 '判断D7位是否进位
SHL = (BD And &H7F) * 2
End Function

'2.逻辑右移
Public Function BSHR(OPR As Byte, n As Integer) As Byte
Dim BD As Byte
Dim i As Integer
BD = OPR
For i = 1 To n - 1
BD = BD \ 2 '右移
Next i
CF = BD And 1 '判断D0位是否进位
SHR = BD \ 2
End Function
'3.算术右移
Public Function SAR(OPR As Byte, n As Integer) As Byte
Dim BD As Byte
Dim i As Integer
Dim Fg1 As Byte
BD = OPR
Fg1 = BD And &H80
For i = 1 To n - 1
BD = BD \ 2 '右移
Next i
CF = BD And 1 '判断D0位是否进位
BD = BD \ 2 '右移
SAR = BD Or Fg1
End Function

'4.循环左移

Public Function ROL(OPR As Byte, n As Integer) As Byte
Dim BD As Byte
Dim i As Integer
Dim Fg1 As Byte
BD = OPR
For i = 1 To n
Fg1 = (BD And &H80) \ 128 '判断D7位是否进位
BD = ((BD And &H7F) * 2) Or Fg1 '带进位左移
Next i
CF = Fg1
ROL = BD
End Function
 

'5.循环右移

Public Function ROR(OPR As Byte, n As Integer) As Byte
Dim BD As Byte
Dim i As Integer
Dim Fg1 As Byte
Dim Fg2 As Byte
BD = OPR
For i = 1 To n
Fg1 = (BD And 1) * 128 '判断D0位是否进位
BD = (BD \ 2) Or Fg1 '带进位右移
Next i
CF = Fg1
ROR = BD
End Function
 

'6.进位循环左移

Public Function RCL(OPR As Byte, n As Integer) As Byte
Dim BD As Byte
Dim i As Integer
Dim Fg1 As Byte
Dim Fg2 As Byte
BD = OPR
Fg2 = CF And 1
For i = 1 To n
Fg1 = (BD And &H80) \ 128 '判断D7位是否进位
BD = ((BD And &H7F) * 2) Or Fg2 '带进位左移
Fg2 = Fg1
Next i
CF = Fg1
RCL = BD
End Function
 

'7.进位循环右移

Public Function RCR(OPR As Byte, n As Integer) As Byte
Dim BD As Byte
Dim i As Integer
Dim Fg1 As Byte
Dim Fg2 As Byte
BD = OPR
Fg2 = CF And 128
For i = 1 To n
Fg1 = (BD And 1) * 128 '判断D0位是否进位
BD = (BD \ 2) Or Fg2 '带进位右移
Fg2 = Fg1
Next i
CF = Fg1
RCR = BD
End Function

Function LShiftWord(ByVal w As Integer, ByVal c As Integer) As Integer
          BugAssert c >= 0 And c <= 15
          Dim dw     As Long
          dw = w * Power2(c)
          If dw And &H8000& Then
                  LShiftWord = CInt(dw And &H7FFF&) Or &H8000
          Else
                  LShiftWord = dw And &HFFFF&
          End If
End Function

'逻辑左移
Public Function SHL(ByRef Num As Variant, Optional ByVal iCL As Byte = 1) As Boolean
Dim i As Byte
Dim bMask As Byte, iMask As Integer, lMask As Long
Select Case VarType(Num)
Case 2 '16 bits
  For i = 1 To iCL
    iMask = 0
    If (Num And &H4000) <> 0 Then iMask = &H8000
    Num = (Num And &H3FFF) * 2 Or iMask
  Next
Case 3 '32 bits
  For i = 1 To iCL
    lMask = 0
    If (Num And &H40000000) <> 0 Then lMask = &H80000000
    Num = (Num And &H3FFFFFFF) * 2 Or lMask
  Next
Case 17 '8 bits
  For i = 1 To iCL
    bMask = 0
    If (Num And &H40) <> 0 Then bMask = &H80
    Num = (Num And &H3F) * 2 Or bMask
  Next
Case Else
  SHL = False
  Exit Function
End Select
SHL = True
End Function
'逻辑右移
Public Function SHR(ByRef Num As Variant, Optional ByVal iCL As Byte = 1) As Boolean
Dim i As Byte
Dim bMask As Byte, iMask As Integer, lMask As Long
Select Case VarType(Num)
Case 2 '16 bits
  For i = 1 To iCL
    iMask = 0
    If (Num And &H8000) <> 0 Then iMask = &H4000
    Num = (Num And &H7FFF) \ 2 Or iMask
  Next
Case 3 '32 bits
  For i = 1 To iCL
    lMask = 0
    If (Num And &H80000000) <> 0 Then lMask = &H40000000
    Num = (Num And &H7FFFFFFF) \ 2 Or lMask
  Next
Case 17 '8 bits
  For i = 1 To iCL
    bMask = 0
    If (Num And &H80) <> 0 Then bMask = &H40
    Num = (Num And &H7F) \ 2 Or bMask
  Next
Case Else
  SHR = False
  Exit Function
End Select
SHR = True
End Function