by Luis (2 Submissions)
Category: String Manipulation
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Sat 29th November 2003
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
This is would convert numbers whitout any overflowing problems (Dec,Bin,Hex,Oct)
VBcoders
'I recomend to put this in a module and add to a proyect when you need it
'But I works anywhere
'This code dont present to you the overflow error
'So is a great advantage to convert very large numbers
'This code you need to copy all if you want to all the function work correctly
'If you don't it will present some problem if the last ones
Function HextoBin(ByVal Numero As String) As String
Dim Bin, Res As String
Dim a As Long
For a = Len(Trim(Numero)) To 1 Step -1
Select Case Mid(Numero, a, 1)
Case "0": Bin = "0000"
Case "1": Bin = "0001"
Case "2": Bin = "0010"
Case "3": Bin = "0011"
Case "4": Bin = "0100"
Case "5": Bin = "0101"
Case "6": Bin = "0110"
Case "7": Bin = "0111"
Case "8": Bin = "1000"
Case "9": Bin = "1001"
Case "A": Bin = "1010"
Case "B": Bin = "1011"
Case "C": Bin = "1100"
Case "D": Bin = "1101"
Case "E": Bin = "1110"
Case "F": Bin = "1111"
Case Else
m = MsgBox("Su Numero no es Hexadecimal", vbCritical, "Error")
Exit For
End Select
Res = Bin + Res
Next a
For a = 1 To Len(Res)
If Mid(Res, a, 1) = "1" Then Exit For
Next a
Res = Mid(Res, a, Len(Res) - a + 1)
If Res = "" Then Res = "0"
HextoBin = Res
End Function
Function OcttoBin(ByVal Numero As String) As String
Dim Bin, Res As String
Dim a As Long
For a = Len(Trim(Numero)) To 1 Step -1
Select Case Mid(Numero, a, 1)
Case "0": Bin = "000"
Case "1": Bin = "001"
Case "2": Bin = "010"
Case "3": Bin = "011"
Case "4": Bin = "100"
Case "5": Bin = "101"
Case "6": Bin = "110"
Case "7": Bin = "111"
Case Else
m = MsgBox("Su Numero no es Octal", vbCritical, "Error")
Exit For
End Select
Res = Bin + Res
Next a
For a = 1 To Len(Res)
If Mid(Res, a, 1) = "1" Then Exit For
Next a
Res = Mid(Res, a, Len(Res) - a + 1)
If Res = "" Then Res = "0"
OcttoBin = Res
End Function
Function BintoHex(ByVal Numero As String) As String
Dim Hex, Res As String
Dim a, Conv As Long
Conv = 4 - (Len(Numero) - (Int(Len(Numero) / 4) * 4))
If Conv > 0 Then
For a = 1 To Conv
Numero = "0" + Numero
Next a
End If
For a = Len(Trim(Numero)) To 1 Step -4
Select Case Val(Mid(Numero, a - 3, 4))
Case 0: Hex = "0"
Case 1: Hex = "1"
Case 10: Hex = "2"
Case 11: Hex = "3"
Case 100: Hex = "4"
Case 101: Hex = "5"
Case 110: Hex = "6"
Case 111: Hex = "7"
Case 1000: Hex = "8"
Case 1001: Hex = "9"
Case 1010: Hex = "A"
Case 1011: Hex = "B"
Case 1100: Hex = "C"
Case 1101: Hex = "D"
Case 1110: Hex = "E"
Case 1111: Hex = "F"
Case Else
m = MsgBox("Su Numero no es Binario")
Exit For
End Select
Res = Hex + Res
Next a
If Res = "" Then Res = "0"
BintoHex = Res
End Function
Function BintoOct(ByVal Numero As String) As String
Dim Oct, Res As String
Dim a, Conv As Long
Conv = 3 - (Len(Numero) - (Int(Len(Numero) / 3) * 3))
If Conv > 0 Then
For a = 1 To Conv
Numero = "0" + Numero
Next a
End If
For a = Len(Trim(Numero)) To 1 Step -3
Select Case Val(Mid(Numero, a - 2, 3))
Case 0: Oct = "0"
Case 1: Oct = "1"
Case 10: Oct = "2"
Case 11: Oct = "3"
Case 100: Oct = "4"
Case 101: Oct = "5"
Case 110: Oct = "6"
Case 111: Oct = "7"
Case Else
m = MsgBox("Su Numero no es Binario")
Exit For
End Select
Res = Oct + Res
Next a
If Res = "" Then Res = "0"
BintoOct = Trim(Str(Val(Res)))
End Function
Function DectoBin(ByVal Numero As String) As String
Dim Res As String
Dim Conv As Long
If IsNumeric(Numero) Then
If Val(Numero) = 0 Then DectoBin = 0: Exit Function
Do While Not Val(Numero) = 0
Conv = Val(Numero) - (Int(Val(Numero) / 2) * 2)
If Conv = 0 Then
Res = "0" + Res: Numero = Str(Int(Val(Numero) / 2))
Else
Res = "1" + Res: Numero = Str(Int((Val(Numero) - 1) / 2))
End If
If Val(Numero) = 1 Then Res = "1" + Res: Exit Do
Loop
DectoBin = Res
Else
m = MsgBox("Su numero no es Decimal", vbCritical, "Error")
End If
End Function
Function BintoDec(ByVal Numero As String) As String
Dim Res As String
Dim a, Base As Long
Base = 0
For a = Len(Numero) To 1 Step -1
If Mid(Numero, a, 1) = "1" Then
Res = Str(Val(Res) + (2 ^ Base))
ElseIf mid(Numero) <> "0" Then
m = MsgBox("Su Numero no es Binario", vbCritical, "Error")
BintoDec = 0: Exit Function
End If
Base = Base + 1
Next a
BintoDec = Res
End Function
Function DectoHex(ByVal Numero As String) As String
DectoHex = DectoBin(BintoHex(Numero))
End Function
Function DectoOct(ByVal Numero As String) As String
DectoOct = DectoBin(BintoOct(Numero))
End Function
Function HextoDec(ByVal Numero As String) As String
HextoDec = HextoBin(BintoDec(Numero))
End Function
Function OcttoDec(ByVal Numero As String) As String
OcttoDec = OcttoBin(BintoDec(Numero))
End Function
Function HextoOct(ByVal Numero As String) As String
HextoOct = BintoOct(HextoBin(Numero))
End Function
Function OcttoHex(ByVal Numero As String) As String
OcttoHex = BintoHex(OcttoBin(Numero))
End Function
'This code is provided by Luis
'[email protected]
No comments have been posted about This is would convert numbers whitout any overflowing problems (Dec,Bin,Hex,Oct). Why not be the first to post a comment about This is would convert numbers whitout any overflowing problems (Dec,Bin,Hex,Oct).