my1.bas

VB6, paralell port, I2C, parse intel HEX

Attribute VB_Name = "Bitwise"
Option Explicit

Declare Function GetTickCount Lib "kernel32" () As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public OnBits(31) As Long

Public Function LShiftLong(ByVal Value As Long, ByVal shift As Integer) As Long
    If (Value And (2 ^ (31 - shift))) Then GoTo OverFlow
    LShiftLong = ((Value And OnBits(31 - shift)) * (2 ^ shift))
    Exit Function
OverFlow:
    LShiftLong = ((Value And OnBits(31 - (shift + 1))) * (2 ^ (shift))) Or &H80000000
End Function

Public Function RShiftLong(ByVal Value As Long, ByVal shift As Integer) As Long
    Dim hi As Long
    If (Value And &H80000000) Then hi = &H40000000
    RShiftLong = (Value And &H7FFFFFFE) \ (2 ^ shift)
    RShiftLong = (RShiftLong Or (hi \ (2 ^ (shift - 1))))
End Function
 
Public Sub MakeOnBits()
    Dim j As Integer
    Dim v As Long
    For j = 0 To 30
        v = v + (2 ^ j)
        OnBits(j) = v
    Next j
    OnBits(j) = v + &H80000000
End Sub

Public Function CalcBCC(ByVal start As Byte, ByVal str As String) As Byte
    Dim i As Integer
    CalcBCC = start
    For i = 1 To Len(str)
        CalcBCC = CalcBCC Xor Asc(Mid(str, i, 1))
    Next
    CalcBCC = CalcBCC And &HFF
End Function

Public Function MsgM(ByVal str As String) As Boolean
frmMAIN.StatusBar.Panels.Item(1).Text = str
End Function

Public Function MsgM2(ByVal str As String) As Boolean
frmMAIN.StatusBar.Panels.Item(2).Text = str
End Function

Public Function BinStrToIntVal(ByVal strBin As String) As Integer
Dim intDec As Integer, intPoint As Long
intDec = 0
For intPoint = Len(strBin) To 1 Step -1
If Mid$(strBin, intPoint, 1) = "1" Then
    intDec = intDec + (2 ^ (8 - intPoint))
End If
Next intPoint
BinStrToIntVal = intDec
End Function


Public Function IntValToBinStr(ByVal intInt As Integer) As String
Dim strBin As String, intPoint As Integer
strBin = ""
For intPoint = 7 To 0 Step -1 'Convert hex to binary
If intInt >= (2 ^ intPoint) Then
    strBin = strBin + "1"
    intInt = intInt - (2 ^ intPoint)
Else
    strBin = strBin + "0"
End If
Next intPoint
IntValToBinStr = strBin
End Function

Public Function HexStrToBinStr(ByVal strHex As String) As String
Dim intHex As Integer, strBin As String, intPoint As Integer
intHex = Val("&H" + strHex)
strBin = ""
For intPoint = 7 To 0 Step -1
If intHex >= (2 ^ intPoint) Then
    strBin = strBin + "1"
    intHex = intHex - (2 ^ intPoint)
Else
    strBin = strBin + "0"
End If
Next intPoint
HexStrToBinStr = strBin
End Function

Public Function BinStrToHexStr(ByVal strBin As String) As String
Dim intDec As Integer, intPoint As Long
intDec = 0
For intPoint = Len(strBin) To 1 Step -1 'Convert binary to decimal
If Mid$(strBin, intPoint, 1) = "1" Then
    intDec = intDec + (2 ^ (8 - intPoint))
End If
Next intPoint
If intDec < 16 Then
    BinStrToHexStr = "0" + Hex(intDec) ' Ensure leading zero
Else
    BinStrToHexStr = Hex(intDec)
End If
End Function

Public Function HexStrToIntVal(ByVal strHex As String) As Integer
HexStrToIntVal = Val("&H" + strHex)
End Function

Public Function IntValToHexStr(ByVal intInt As Long, ByVal l As Integer) As String
IntValToHexStr = Hex(intInt)
While Len(IntValToHexStr) < l
IntValToHexStr = "0" & IntValToHexStr
Wend
End Function

Public Function ParseHEX(ByVal strInput As String) As String
Dim intL_nibble As String, intR_nibble As String
Select Case Len(strInput)
Case 0
    strInput = "00" ' Make sure string is 2 chars with leading zeros
Case 1
    strInput = "0" + strInput ' Make sure string is 2 chars with leading zeros
End Select
intR_nibble = Right$(strInput, 1) ' Right nibble
intL_nibble = Left$(strInput, 1) ' Left nibble
intR_nibble = Hex(Val("&H" + intR_nibble)) ' Parse the user input to legitimate hex
intL_nibble = Hex(Val("&H" + intL_nibble))
If Len(intR_nibble) = 0 Then intR_nibble = "0"
If Len(intL_nibble) = 0 Then intL_nibble = "0"
ParseHEX = intL_nibble + intR_nibble ' The parsed hex input
End Function