VB进制转换源代码

优胜编程龚老师

VB进制转换源代码：

VB进制转换源代码

Function Bin2Dec(InputData As String) As Double
''
''  This converts Binary to Decimal
''
Dim DecOut As Double
Dim I As Integer
Dim LenBin As Double
Dim JOne As String

LenBin = Len(InputData)

''
''  Make sure that it is a Binary Number
''
For I = 1 To LenBin
JOne = Mid(InputData, I, 1)
   If JOne <> "0" And JOne <> "1" Then
     MsgBox "NOT A BINARY NUMBER", vbCritical
     Exit Function
   End If
Next I


DecOut = 0
For I = Len(InputData) To 1 Step -1
  If Mid(InputData, I, 1) = "1" Then
    DecOut = DecOut + 2 ^ (Len(InputData) - I)
  End If
Next I
        
  Bin2Dec = DecOut
        
End Function


Function Dec2Bin(InputData As Double) As String
''
''  Converts Decimal to Binary
''  This uses the Quotient Remainder method
''
Dim Quot As Double
Dim Remainder As Double
Dim BinOut As String
Dim I As Integer
Dim NewVal As Double
Dim TempString As String
Dim TempVal As Double
Dim BinTemp As String
Dim BinTemp1 As String
Dim PosDot As Integer
Dim Temp2 As String


''  Check to see if there is a decimal point or not
''
If InStr(1, CStr(InputData), ".") Then
  MsgBox "Only Whole Numbers can be converted", vbCritical
  GoTo eds
End If

BinOut = ""
NewVal = InputData


DoAgain:

''  Start the Calculations off
NewVal = (NewVal / 2)


''  If we have a remainder
If InStr(1, CStr(NewVal), ".") Then
  BinOut = BinOut + "1"
  
  '' Get rid of the Remainder
  NewVal = Format(NewVal, "#0")
  NewVal = (NewVal - 1)
  
   If NewVal < 1 Then
     GoTo DoneIt
   End If
Else
  BinOut = BinOut + "0"
   If NewVal < 1 Then
     GoTo DoneIt
   End If
End If


GoTo DoAgain

DoneIt:

BinTemp = ""

''  Reverse the Result
For I = Len(BinOut) To 1 Step -1
BinTemp1 = Mid(BinOut, I, 1)
BinTemp = BinTemp + BinTemp1
Next I

BinOut = BinTemp

'' Output the Result
Dec2Bin = BinOut


eds:
End Function


Function Bin2Hex(InputData As String) As String
''
''  Converts Binary to hex
''
Dim I As Integer
Dim LenBin As Integer
Dim JOne As String
Dim NumBlocks As Integer
Dim FullBin As String
Dim HexOut As String
Dim TempBinBlock As String
Dim TempHex As String

LenBin = Len(InputData)

''
''  Make sure that it is a Binary Number
''
For I = 1 To LenBin
JOne = Mid(InputData, I, 1)
   If JOne <> "0" And JOne <> "1" Then
     MsgBox "NOT A BINARY NUMBER", vbCritical
     Exit Function
   End If
Next I

''  Set the Variable to the Binary
''
FullBin = InputData

''
''  If the value is less than 4 in length, build it up.
''
If LenBin < 4 Then
If LenBin = 3 Then
  FullBin = "0" + FullBin
ElseIf LenBin = 2 Then
  FullBin = "00" + FullBin
ElseIf LenBin = 1 Then
  FullBin = "000" + FullBin
ElseIf LenBin = 0 Then
   MsgBox "Nothing Given..", vbCritical
   Exit Function
End If
  NumBlocks = 1
  GoTo DoBlocks
End If


If LenBin = 4 Then
  NumBlocks = 1
  GoTo DoBlocks
End If


If LenBin > 4 Then

Dim TempHold As Currency
Dim TempDiv As Currency
Dim AfterDot As Integer
Dim Pos As Integer

TempHold = Len(InputData)
TempDiv = (TempHold / 4)

''
''  Works by seeing whats after the deciomal place
''
Pos = InStr(1, CStr(TempDiv), ".")

If Pos = 0 Then
'' Divided by 4 perfectly
NumBlocks = TempDiv
GoTo DoBlocks
End If

AfterDot = Mid(CStr(TempDiv), (Pos + 1))

If AfterDot = 25 Then
  FullBin = "000" + FullBin
  NumBlocks = (Len(FullBin) / 4)
ElseIf AfterDot = 5 Then
  FullBin = "00" + FullBin
  NumBlocks = (Len(FullBin) / 4)
ElseIf AfterDot = 75 Then
  FullBin = "0" + FullBin
  NumBlocks = (Len(FullBin) / 4)
Else
  MsgBox "Big Time Screw up happened, WAHHHHHHHHHHH", vbInformation
  Exit Function
End If


  GoTo DoBlocks
End If


''
''  The rest will process the now built up number
''
DoBlocks:

HexOut = ""


For I = 1 To Len(FullBin) Step 4
  TempBinBlock = Mid(FullBin, I, 4)

If TempBinBlock = "0000" Then
  HexOut = HexOut + "0"
ElseIf TempBinBlock = "0001" Then
  HexOut = HexOut + "1"
ElseIf TempBinBlock = "0010" Then
  HexOut = HexOut + "2"
ElseIf TempBinBlock = "0011" Then
  HexOut = HexOut + "3"
ElseIf TempBinBlock = "0100" Then
  HexOut = HexOut + "4"
ElseIf TempBinBlock = "0101" Then
  HexOut = HexOut + "5"
ElseIf TempBinBlock = "0110" Then
  HexOut = HexOut + "6"
ElseIf TempBinBlock = "0111" Then
  HexOut = HexOut + "7"
ElseIf TempBinBlock = "1000" Then
  HexOut = HexOut + "8"
ElseIf TempBinBlock = "1001" Then
  HexOut = HexOut + "9"
ElseIf TempBinBlock = "1010" Then
  HexOut = HexOut + "A"
ElseIf TempBinBlock = "1011" Then
  HexOut = HexOut + "B"
ElseIf TempBinBlock = "1100" Then
  HexOut = HexOut + "C"
ElseIf TempBinBlock = "1101" Then
  HexOut = HexOut + "D"
ElseIf TempBinBlock = "1110" Then
  HexOut = HexOut + "E"
ElseIf TempBinBlock = "1111" Then
  HexOut = HexOut + "F"
End If

Next I


Bin2Hex = HexOut

eds:
End Function


Function Hex2Bin(InputData As String) As String


''
''
''  PLEASE NOTE THAT THIS FUNCTION DOES
''
''            NOT
''
''  STRIP THE EXTRA ZEROS OFF THE FRONT OF THE
''  BINARY ANSWER.
''


''
''  Converts Hexadecimal to Binary
''
Dim I As Integer
Dim BinOut As String
Dim Lenhex As Integer


''  The length of the input
''
InputData = UCase(InputData)
Lenhex = Len(InputData)


For I = 1 To Lenhex

If IsNumeric(Mid(InputData, I, 1)) Then
  ''
  GoTo NumOk
ElseIf Mid(InputData, I, 1) = "A" Then
  GoTo NumOk
ElseIf Mid(InputData, I, 1) = "B" Then
  GoTo NumOk
ElseIf Mid(InputData, I, 1) = "C" Then
  GoTo NumOk
ElseIf Mid(InputData, I, 1) = "D" Then
  GoTo NumOk
ElseIf Mid(InputData, I, 1) = "E" Then
  GoTo NumOk
ElseIf Mid(InputData, I, 1) = "F" Then
  GoTo NumOk
Else
  MsgBox "Number given is not in Hex format", vbCritical
  Exit Function
End If

NumOk:
Next I

BinOut = ""


''
''  Convert the Number to Binary
''
For I = 1 To Lenhex

If Mid(InputData, I, 1) = "0" Then
  BinOut = BinOut + "0000"
ElseIf Mid(InputData, I, 1) = "1" Then
  BinOut = BinOut + "0001"
ElseIf Mid(InputData, I, 1) = "2" Then
  BinOut = BinOut + "0010"
ElseIf Mid(InputData, I, 1) = "3" Then
  BinOut = BinOut + "0011"
ElseIf Mid(InputData, I, 1) = "4" Then
  BinOut = BinOut + "0100"
ElseIf Mid(InputData, I, 1) = "5" Then
  BinOut = BinOut + "0101"
ElseIf Mid(InputData, I, 1) = "6" Then
  BinOut = BinOut + "0110"
ElseIf Mid(InputData, I, 1) = "7" Then
  BinOut = BinOut + "0111"
ElseIf Mid(InputData, I, 1) = "8" Then
  BinOut = BinOut + "1000"
ElseIf Mid(InputData, I, 1) = "9" Then
  BinOut = BinOut + "1001"
ElseIf Mid(InputData, I, 1) = "A" Then
  BinOut = BinOut + "1010"
ElseIf Mid(InputData, I, 1) = "B" Then
  BinOut = BinOut + "1011"
ElseIf Mid(InputData, I, 1) = "C" Then
  BinOut = BinOut + "1100"
ElseIf Mid(InputData, I, 1) = "D" Then
  BinOut = BinOut + "1101"
ElseIf Mid(InputData, I, 1) = "E" Then
  BinOut = BinOut + "1110"
ElseIf Mid(InputData, I, 1) = "F" Then
  BinOut = BinOut + "1111"
Else
  MsgBox "Something is Screwed up, Wahhhhhhhhhhh", vbCritical
End If


Next I


Hex2Bin = BinOut

eds:
End Function


Function Hex2Dec(InputData As String) As Double
''
''  Converts Hexadecimal to Decimal
''
Dim I As Integer
Dim DecOut As Double
Dim Lenhex As Integer
Dim HexStep As Double


'' Zeroise the output
DecOut = 0

''  The length of the input
''
InputData = UCase(InputData)
Lenhex = Len(InputData)

''
''  Check to make sure its a valid Hex Number
''
For I = 1 To Lenhex

If IsNumeric(Mid(InputData, I, 1)) Then
  ''
  GoTo NumOk
ElseIf Mid(InputData, I, 1) = "A" Then
  GoTo NumOk
ElseIf Mid(InputData, I, 1) = "B" Then
  GoTo NumOk
ElseIf Mid(InputData, I, 1) = "C" Then
  GoTo NumOk
ElseIf Mid(InputData, I, 1) = "D" Then
  GoTo NumOk
ElseIf Mid(InputData, I, 1) = "E" Then
  GoTo NumOk
ElseIf Mid(InputData, I, 1) = "F" Then
  GoTo NumOk
Else
  MsgBox "Number given is not in Hex format", vbCritical
  Exit Function
End If

NumOk:
Next I

HexStep = 0

''
''
''  Convert the Number to Decimal
''
For I = Lenhex To 1 Step -1

HexStep = HexStep * 16
If HexStep = 0 Then
  HexStep = 1
End If

If Mid(InputData, I, 1) = "0" Then
   DecOut = DecOut + (0 * HexStep)
ElseIf Mid(InputData, I, 1) = "1" Then
   DecOut = DecOut + (1 * HexStep)
ElseIf Mid(InputData, I, 1) = "2" Then
   DecOut = DecOut + (2 * HexStep)
ElseIf Mid(InputData, I, 1) = "3" Then
   DecOut = DecOut + (3 * HexStep)
ElseIf Mid(InputData, I, 1) = "4" Then
   DecOut = DecOut + (4 * HexStep)
ElseIf Mid(InputData, I, 1) = "5" Then
   DecOut = DecOut + (5 * HexStep)
ElseIf Mid(InputData, I, 1) = "6" Then
   DecOut = DecOut + (6 * HexStep)
ElseIf Mid(InputData, I, 1) = "7" Then
   DecOut = DecOut + (7 * HexStep)
ElseIf Mid(InputData, I, 1) = "8" Then
   DecOut = DecOut + (8 * HexStep)
ElseIf Mid(InputData, I, 1) = "9" Then
   DecOut = DecOut + (9 * HexStep)
ElseIf Mid(InputData, I, 1) = "A" Then
   DecOut = DecOut + (10 * HexStep)
ElseIf Mid(InputData, I, 1) = "B" Then
   DecOut = DecOut + (11 * HexStep)
ElseIf Mid(InputData, I, 1) = "C" Then
   DecOut = DecOut + (12 * HexStep)
ElseIf Mid(InputData, I, 1) = "D" Then
   DecOut = DecOut + (13 * HexStep)
ElseIf Mid(InputData, I, 1) = "E" Then
   DecOut = DecOut + (14 * HexStep)
ElseIf Mid(InputData, I, 1) = "F" Then
   DecOut = DecOut + (15 * HexStep)
Else
   MsgBox "Something is Screwed up, Wahhhhhhhhhhh", vbCritical
End If

Next I


Hex2Dec = DecOut

eds:
End Function