modnumbase.bas

AD9954源码

Attribute VB_Name = "modNumBase"
Option Explicit
'Converts a Decimal number to a binary string
'Note - Converts floating point numbers to integer values
'Handles negative numbers by creating a 2's Compliment
'binary  string
Public Function cbaseDec2Bin(ByVal Number As Variant, ByVal numbits As Integer) As String
    Dim cntr As Integer
    Dim TempVal As Variant
    Dim Remainder As Variant
    Dim NumNeg As Boolean
    TempVal = CDec(Number)
    Remainder = CDec(0)
       
    If Number < 0 Then
        NumNeg = True
        'Make positive
        TempVal = Abs(TempVal)
        'Add one to make it 2's compliment
        TempVal = TempVal - 1
    Else
        NumNeg = False
    End If
                    
    For cntr = 0 To 95
        Remainder = DecMod(TempVal, 2)
        TempVal = TempVal / 2
        TempVal = DecFix(TempVal)
        If Remainder = 1 Then
            'If the number was negative then insert a "0" else insert a "1"
            If NumNeg = True Then
                cbaseDec2Bin = "0" & cbaseDec2Bin
            Else
                cbaseDec2Bin = "1" & cbaseDec2Bin
            End If
        Else
            'If the number was negative then insert a "1" else insert a "0"
            If NumNeg = True Then
                cbaseDec2Bin = "1" & cbaseDec2Bin
            Else
                cbaseDec2Bin = "0" & cbaseDec2Bin
            End If
        End If
    Next
    
    'Trim the output string  to the number of bits specified
    cbaseDec2Bin = Right(cbaseDec2Bin, numbits)
    
End Function
Function cbaseDec2Hex(ByVal Number As Variant, ByVal NumDigits As Integer) As String
    Dim cntr As Integer
    Dim TempVal As Variant
    Dim Remainder As Variant
    Dim NumNeg As Boolean

    Remainder = CDec(0)
    TempVal = CDec(Number)
    
    For cntr = 0 To 24
        'Divide and get the remainder
        Remainder = DecMod(TempVal, 16)
        'Truncate the remainder
        TempVal = DecFix(TempVal / 16)
        
        'Add in the hex remainder to the return string
        cbaseDec2Hex = Hex(Remainder) & cbaseDec2Hex
    Next cntr
    
    'Make sure you return the right number of digits
    If NumDigits <= Len(cbaseDec2Hex) Then
        cbaseDec2Hex = Right(cbaseDec2Hex, NumDigits)
    Else
        cbaseDec2Hex = String(NumDigits - Len(cbaseDec2Hex), "0") & cbaseDec2Hex
    End If
End Function

'Converts a Decimal number to a binary string
'Note - Converts floating point numbers to integer values
'Public Function cbaseDec2Bin1(ByVal Number As Variant, ByVal numbits As Integer) As String
'    Dim cntr As Integer
'    Dim TempDec As Variant
'    Dim iBitVal As Integer
'    TempDec = CDec(0)
'
'    If Not IsNumeric(Number) Then
'        'Raise an error
'        Err.Raise 5, "cbaseDec2Bin()", "Invalid Parameter: Number can only be a whole number no fractional numbers."
'    Else
'        'Truncate the fractional part of number off
'        TempDec = DecFix(Number)
'
'        'Convert the value to a binary string
'        For cntr = numbits - 1 To 0 Step -1
'            'Get the first bit value
'            iBitVal = DecFix(TempDec / 2 ^ cntr)
'            'Check the string value of the bit to the output string
'            If iBitVal = 1 Then
'                cbaseDec2Bin = cbaseDec2Bin & "1"
'                'Trim off the bit checked
'                TempDec = TempDec - (2 ^ cntr)
'            Else
'                cbaseDec2Bin = cbaseDec2Bin & "0"
'            End If
'        Next cntr
'        'The return string has been assembled
'    End If
'End Function
'02/08/00 - Replaced "." with "GetDecSeperator(False)" for internationalization
'Truncates the fractional portion off of a decimal value
Public Function DecFix(ByVal Number As Variant) As Variant
    Dim ConvertStr As String
    Dim DecSepLoc As Integer
    Dim StrVal As String
    
    'Get the string value of the number
    StrVal = CStr(Number)
    
    'Get the decimal
    DecSepLoc = InStr(1, StrVal, GetDecSeparator(False))
    
    If DecSepLoc And (DecSepLoc <> Len(StrVal)) And DecSepLoc <> 1 Then
        'Truncate the fractional part of the number
        ConvertStr = Left(StrVal, DecSepLoc - 1)
    Else
        If DecSepLoc = 1 Then
            ConvertStr = "0"
        Else
            ConvertStr = CStr(Number)
        End If
    End If
    
    'If for some odd reason convertstr is "" then return 0
    If ConvertStr = "" Then
        ConvertStr = "0"
    End If
    
    'Return the truncated value
    DecFix = CDec(ConvertStr)
End Function
'Converts a binary string into a decimal value
Public Function cbaseBinS2Dec(ByVal BinStr As String) As Variant
    Dim BSLen As Integer
    Dim retval As Variant
    Dim cntr As Integer
    Dim ChrPtr As Integer
    
    If Len(BinStr) > 111 And IsNumeric(BinStr) Then
        'Error
        Err.Raise 5, "cbaseBinS2Dec()", "To many bits: Can only convert 111 bit string!!!"
    Else
        'Get the length of the string
        BSLen = Len(BinStr)
        
        'Initailize retval as a decimal value
        retval = CDec(0)
        
        'Inirialize the charater ptr
        ChrPtr = BSLen
        
        'Convert then string
        For cntr = 0 To BSLen - 1
            
            'If the character is a "1" then add the bit
            If Mid(BinStr, ChrPtr, 1) = "1" Then
                retval = retval + 2 ^ cntr
            End If
            
            'Decrement the character pointer
            ChrPtr = ChrPtr - 1
        Next cntr
        
        cbaseBinS2Dec = CDec(retval)
    End If
End Function
'Converts a binary string into a decimal value
Public Function cbaseSignedBinS2Dec(ByVal BinStr As String) As Variant
    Dim BSLen As Integer
    Dim retval As Variant
    Dim cntr As Integer
    Dim ChrPtr As Integer
    Dim isNeg As Boolean
    
    If Len(BinStr) > 111 And IsNumeric(BinStr) Then
        'Error
        Err.Raise 5, "cbaseBinS2Dec()", "To many bits: Can only convert 111 bit string!!!"
    Else
        'Check to see if it is negative
        If Left(BinStr, 1) = "1" Then
            isNeg = True
        End If
    
        If isNeg = False Then
            'If it wasn't negative then convert normaly
            retval = cbaseBinS2Dec(BinStr)
        Else
            'Compliment the binary string and convert normaly
            BinStr = ComplBinStr(BinStr)
            retval = cbaseBinS2Dec(BinStr)
            'Subtract 1 to get the correct answer
            retval = (retval + 1) * -1
        End If
        
        'Return the calculated value
        cbaseSignedBinS2Dec = retval
    End If
End Function

'Converts a decimal value to a hex string
'Inputs
'   Num - Number to be converted
'   DigitsToDisplay - Number of digits to display
Public Function cbaseHex(ByVal num As Variant, Optional ByVal DigitsToDisplay As Integer = 0) As String
    Dim Digits2Add As Integer
    Const MaxLongVal = 2147483647
'    Dim iCntr As Integer
'    Dim iNibble As Integer
'    Dim sNibble As Integer
    Dim dCNum As Variant
    dCNum = CDec(0)
    
    If IsNumeric(num) Then
        'Convert the value to hex
'        cbaseHex = Hex(DecFix(Num))
        dCNum = num
        Do
            'Convert the first nibble to hex
            cbaseHex = Hex(DecMod(dCNum, 16)) & cbaseHex
            'Remove the first nibble from the value
            dCNum = DecFix(dCNum / 16)
        Loop While dCNum <> 0
        
        
        'Add on any leading 0's that are needed
        If DigitsToDisplay > Len(cbaseHex) Then
            'Calculate the digits to add
            Digits2Add = DigitsToDisplay - Len(cbaseHex)
            'Add the missing digits to the output string
            cbaseHex = String(Digits2Add, 48) & cbaseHex
        End If
    Else
        'Error
        Err.Raise 5, "cbaseHex()", "Num can only be a numeric value."
        Exit Function
    End If
End Function

'Converts a hex string into a decimal value properly
Public Function cbaseHexStr2Dec(ByVal HexStr As String) As Variant
    Dim cntr As Integer
    Dim sNibble As String