• Home
 · 
• Math/Dates
 · 
• Convert between different bases ranging from 2 to 36

Convert between different bases ranging from 2 to 36

Convert between different bases ranging from 2 to 36

Rate Convert between different bases ranging from 2 to 36

• 1
• 2
• 3
• 4
• 5

(2(2 Vote))

Option Explicit
Option Compare Text

'// Then declare this constant
Private Const csValidChars As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

'// Then all we have to do is to write a public function like this...
Public Function BCon(ByVal InputValue As String, ByVal InputBase As Long, ByVal OutputBase As Long) As String

   '// Declare following variables
   Dim cuOutputCharCount As Currency, lInputCharCount As Long
   Dim lCounter As Long, sCompareWith As String, sChar As String
   Dim dDecimalChars As Double, lPos As Long, cuBitValue As Currency
   Dim cuDecimalValue As Currency, sOutput As String

   '// Turn on error trapping
   On Error Resume Next

   '// Check to see that both InputBase and OutputBase are between 2 and 36 inclusively
   If (InputBase < 2) Or (InputBase > 36) Then
      BCon = ""
      Exit Function
   End If

   If (OutputBase < 2) Or (OutputBase > 36) Then
      BCon = ""
      Exit Function
   End If

   '// Now initiate translation into 10-based value
   InputValue = Trim(InputValue)
   lInputCharCount = Len(InputValue)
   sCompareWith = Left$(csValidChars, InputBase)

   '// Check to see that input string is at least one character
   If lInputCharCount < 1 Then
      BCon = ""
      Exit Function
   End If

   '// Loop through each character in input string. Check for invalid characters according to input base
   For lCounter = 1 To lInputCharCount
      sChar = Mid$(InputValue, lCounter, 1)
      If InStr(1, sCompareWith, sChar, vbTextCompare) < 1 Then
         BCon = ""
         Exit Function
      End If
   Next

   If InputBase = OutputBase Then
      BCon = InputValue
      Exit Function
   End If

   '// Now get the number of decimal characters needed to hold input value
   dDecimalChars = lInputCharCount * Log(InputBase) / Log(10)

   '// If decimal string is longer than 14 characters then exit function
   If dDecimalChars > 14 Then
      BCon = ""
      Exit Function
   End If

   If InputBase = 10 Then
      cuDecimalValue = CCur(InputValue)
   Else
      '// Initiate calculation into decimal value
      cuBitValue = 1
      cuDecimalValue = 0

      '// As long there are characters left in input string, add their value into the decimal hold variable
      While Len(InputValue) > 0
         sChar = Right(InputValue, 1)
         lPos = InStr(1, sCompareWith, sChar, vbTextCompare) - 1
         cuDecimalValue = cuDecimalValue + lPos * cuBitValue
         cuBitValue = cuBitValue * InputBase
         InputValue = Left(InputValue, Len(InputValue) - 1)
      Wend

      '// Now we can do a trick. If output base is 10, we already have the decimal value...
      If OutputBase = 10 Then
         BCon = CStr(cuDecimalValue)
         Exit Function
      End If
   End If

   '// Calculate number of characters in output string. If not an integer round up to nearest integer
   cuOutputCharCount = 1 + Log(cuDecimalValue) / Log(OutputBase)

   '// Now we must convert the decimal value back into a string in the output base format
   cuBitValue = 1
   For lCounter = 2 To cuOutputCharCount
      cuBitValue = cuBitValue * OutputBase
   Next

   '// As long as we have a decimal value greater than 0, add a character to the output string
   sOutput = ""
   sCompareWith = Left$(csValidChars, OutputBase)
   While cuBitValue > 0
      lPos = cuDecimalValue \ cuBitValue
      sChar = Mid$(sCompareWith, 1 + lPos, 1)
      sOutput = sOutput & sChar
      cuDecimalValue = cuDecimalValue - lPos * cuBitValue
      cuBitValue = cuBitValue \ OutputBase
   Wend

   '// Strip leading zeros
   While Left$(sOutput, 1) < "1"
      sOutput = Right$(sOutput, Len(sOutput) - 1)
   Wend

   '// Let BCon function value be the output string in output base format
   BCon = sOutput

End Function