home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / VeryLongCo46152142002.psc / ModConvert.bas < prev    next >
Encoding:
BASIC Source File  |  2002-01-04  |  6.9 KB  |  173 lines
  1. Attribute VB_Name = "ModConvert"
  2. Option Compare Text
  3.  
  4. 'Most used bases
  5. Public Const B_BIN As Integer = 2
  6. Public Const B_OCT As Integer = 8
  7. Public Const B_DEC As Integer = 10
  8. Public Const B_HEX As Integer = 16
  9. 'Some separators
  10. Public Const DEFAULT_SEPARATOR As String = "."
  11. Public Const COMMA_SEPARATOR As String = ","
  12.  
  13. Private Digits(0 To 35) As String 'Bases digits
  14. Private INum() As Integer 'Input number
  15. Private ONum() As Integer 'Output number
  16. Private IBase As Integer 'Input base
  17. Private OBase As Integer 'Output base
  18.  
  19. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  20. 'VeryLongConvert : function that converts a huge number as string from a base to
  21. '                  another one
  22. '
  23. '                  Version : 1.01
  24. '                  Author:  Guillaume GIFFARD
  25. '                  Date : 01/03/2002
  26. '                  Mail : Guiland@mail.com
  27. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  28. 'INPUTS :  * Word As String : the huge number to convert
  29. '
  30. '          * FromBase As Integer : the base in witch Word is written
  31. '
  32. '          * ToBase As Integer : the base in witch Word is to convert
  33. '
  34. '          * Separator As String : this Optional variable is the decimal separator,
  35. '          usely the point
  36. '
  37. '          FromBase and ToBase are integers from 2 to 36
  38. '
  39. 'OUTPUTS : * the function returns the huge number value converted from FromBase to
  40. '          ToBase as string. It returns "" if Word is empty or if FromBase or
  41. '          ToBase is not between 2 and 36
  42. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  43. Public Function VeryLongConvert(Word As String, FromBase As Integer, ToBase As Integer, Optional Separator As String = DEFAULT_SEPARATOR) As String
  44.     If Word = "" Or FromBase < 2 Or FromBase > 36 Or ToBase < 2 Or ToBase > 36 Then Exit Function
  45.     If Digits(35) <> "Z" Then InitDigits
  46.     Call StringToArray(Word, FromBase, Separator)
  47.     Convert (ToBase)
  48.     VeryLongConvert = DeleteZeros(ArrayToString(Separator), Separator)
  49. End Function
  50.  
  51. 'Saves the bases digits in an array
  52. Private Sub InitDigits()
  53.     For i = 0 To 9
  54.         Digits(i) = i
  55.     Next i
  56.     For i = 10 To 35
  57.         Digits(i) = Chr(i + 55)
  58.     Next i
  59. End Sub
  60.  
  61. 'Saves a number as string in an array of integers
  62. 'Each cell of the array in one digit of the number
  63. Private Sub StringToArray(Word As String, Base As Integer, Optional Separator As String = DEFAULT_SEPARATOR)
  64.     If Word = "" Or Base < 2 Or Base > 36 Then Exit Sub
  65.     Dim Point As Integer, Min As Integer, Max As Integer, NoPoint As Integer
  66.     IBase = Base
  67.     Point = InStr(1, Word, Separator, vbTextCompare)
  68.     If Point = 0 Then
  69.         Max = Len(Word) - 1
  70.         Min = 0
  71.     Else
  72.         Max = Point - 2
  73.         Min = Point - Len(Word) + Len(Separator) - 1
  74.     End If
  75.     ReDim INum(Min To Max)
  76.     For i = 0 To Len(Word) - 1
  77.         If i <= Len(Word) - Point And i >= Len(Word) - Point - Len(Separator) + 1 Then
  78.             NoPoint = NoPoint - 1
  79.         Else
  80.             INum(Min + i + NoPoint) = Number(Left(Right(Word, i + 1), 1), IBase)
  81.         End If
  82.     Next i
  83. End Sub
  84.  
  85. 'Returns the number corresponding to a digit as string if the digit is allowed
  86. 'by the base. e.g. : C is allowed in hexadecimal but not in decimal or in octal
  87. Private Function Number(Digit As String, Base As Integer) As Integer
  88.     If Digit = "" Or Base < 2 Or Base > 36 Then Exit Function
  89.     For i = 0 To 35
  90.         If i = Base Then Exit Function
  91.         If UCase(Digit) = Digits(i) Then Number = i
  92.     Next i
  93. End Function
  94.  
  95. 'THE sub that converts INum to ONum with IBase and OBase
  96. Private Sub Convert(Base As Integer)
  97.     If Base < 2 Or Base > 36 Then Exit Sub
  98.     Dim Max As Integer, Min As Integer
  99.     Dim TmpNum() As Integer, Tmp2Num() As Integer
  100.  
  101.     OBase = Base
  102.     Max = RoundOverInt(Int((UBound(INum, 1) + 1) * Log(IBase) / Log(OBase)))
  103.     Min = Int(LBound(INum, 1) * Log(IBase) / Log(OBase))
  104.     ReDim ONum(Min To Max)
  105.     i = 0 'LBound(ONum, 1)
  106.     Call DivideVeryLong(INum, OBase, TmpNum, ONum(i), IBase)
  107.     i = i + 1
  108.     Do Until i > UBound(ONum, 1)
  109.         Call DivideVeryLong(TmpNum, OBase, Tmp2Num, ONum(i), IBase)
  110.         ReDim TmpNum(LBound(Tmp2Num, 1) To UBound(Tmp2Num, 1))
  111.         For j = LBound(Tmp2Num, 1) To UBound(Tmp2Num, 1)
  112.             TmpNum(j) = Tmp2Num(j)
  113.         Next j
  114.         i = i + 1
  115.     Loop
  116. End Sub
  117.  
  118. 'round numbers to the closest higher integer
  119. 'e.g. : 3.9 gives 4 ; 3.4 gives 4 ; 3 gives 3
  120. Private Function RoundOverInt(Value As Double) As Double
  121.     If Value = Int(Value) Then RoundOverInt = Value Else RoundOverInt = Int(Value) + 1
  122. End Function
  123.  
  124. 'Divides a huge number by an integer and returns the huge quotient and the remainder
  125. Private Sub DivideVeryLong(Numerator() As Integer, Denominator As Integer, QuotientOut() As Integer, Remainder As Integer, Base As Integer)
  126.     Dim Tmp As Long, Decal As Long
  127.     ReDim QuotientOut(LBound(Numerator, 1) To UBound(Numerator, 1))
  128.     Tmp = 0
  129.     Decal = 0
  130.     For i = UBound(Numerator, 1) To 0 Step -1 'LBound(Numerator, 1) Step -1
  131.         Tmp = Tmp * Base + Numerator(i)
  132.         QuotientOut(i - Decal) = Tmp \ Denominator
  133.         'If QuotientOut(i - Decal) = 0 And Decal = i - 1 Then
  134.         '    Decal = Decal - 1
  135.         '    ReDim QuotientOut(LBound(Numerator, 1) To UBound(Numerator, 1) - Decal)
  136.         'End If
  137.         Tmp = Tmp - QuotientOut(i - Decal) * Denominator
  138.     Next i
  139.     Remainder = Tmp
  140. End Sub
  141.  
  142. 'Saves an array in a string
  143. Private Function ArrayToString(Optional Separator As String = DEFAULT_SEPARATOR) As String
  144.     For i = UBound(ONum, 1) To LBound(ONum, 1) Step -1
  145.         If i = -1 Then ArrayToString = ArrayToString & Separator
  146.         ArrayToString = ArrayToString & Digits(ONum(i))
  147.     Next i
  148. End Function
  149.  
  150. 'Deletes zeros before and after the number as string and, if possible, deletes the
  151. 'separator
  152. Private Function DeleteZeros(Word As String, Optional Separator As String = DEFAULT_SEPARATOR) As String
  153.     Dim Point As Integer, WordTmp As String
  154.     WordTmp = Word
  155.     Do
  156.         Point = InStr(1, WordTmp, "0", vbTextCompare)
  157.         If Point = 1 Then WordTmp = Right(WordTmp, Len(WordTmp) - 1) Else Exit Do
  158.     Loop
  159.     If InStr(1, WordTmp, Separator, vbTextCompare) <> 0 Then
  160.         Do
  161.             Point = InStr(Len(WordTmp) - 1, WordTmp, "0", vbTextCompare)
  162.             If Point = Len(WordTmp) - 1 Then WordTmp = Left(WordTmp, Len(WordTmp) - 1) Else Exit Do
  163.         Loop
  164.         Do
  165.             Point = InStr(Len(WordTmp) - 1, WordTmp, "0", vbTextCompare)
  166.             If Point = Len(WordTmp) Then WordTmp = Left(WordTmp, Len(WordTmp) - 1) Else Exit Do
  167.         Loop
  168.     End If
  169.     If WordTmp = "" Then WordTmp = "0"
  170.     If InStr(1, WordTmp, Separator, vbTextCompare) = Len(WordTmp) - Len(Separator) + 1 Then WordTmp = Left(WordTmp, Len(WordTmp) - Len(Separator))
  171.     DeleteZeros = WordTmp
  172. End Function
  173.