Classe pour convertir les bases

Commenter

Contenu du snippet

Cette class vous donne la possibilité de convertir en binaire, octal, decimal et hexadecimal ...

Source / Exemple : 


Option Explicit

Public Function IsHexadecimal(ByVal strNumber As String) As Boolean

' Variable compteur pour la position de la lettre.
Dim lngCounter As Long
'
Dim bolResult As Boolean
' Variable de test d'un caractère.
Dim strTest As String * 1
'
For lngCounter = 1 To Len(strNumber)
    '
    strTest = Mid(strNumber, lngCounter, 1)
    '
    Select Case strTest
        '
        Case 0 To 9
            '
            bolResult = True
        '
        Case "A"
            '
            bolResult = True
        '
        Case "B"
            '
            bolResult = True
        '
        Case "C"
            '
            bolResult = True
        '
        Case "D"
            '
            bolResult = True
        '
        Case "E"
            '
            bolResult = True
        '
        Case "F"
            '
            bolResult = True
        '
        Case Else
            '
            bolResult = False
            '
            Exit For
    End Select
Next lngCounter
'
IsHexadecimal = bolResult

End Function
Public Function IsOctal(ByVal strNumber As String) As Boolean

'
Dim lngCounter As Long
'
Dim strTemp As String * 1
'
Dim bolResult As Boolean
'
For lngCounter = 1 To Len(strNumber)
    '
    strTemp = Mid(strNumber, lngCounter, 1)
    '
    Select Case strTemp
        '
        Case 0 To 7
            '
            bolResult = True
        '
        Case Else
            '
            bolResult = False
            '
            Exit For
    End Select
Next lngCounter
'
IsOctal = bolResult

End Function
Public Function IsBinary(ByVal strNumber As String) As Boolean

' Compteur de caractères
Dim lngCounter As Long
' Variable qui retourne le résultat.
Dim bolResult As Long
' De 1 à la taille de la chaîne,
For lngCounter = 1 To Len(strNumber)
    ' Si une des lettres est 0 ou 1,
    If Mid(strNumber, lngCounter, 1) = "0" Or Mid(strNumber, lngCounter, 1) = "1" Then
        ' Retourne vrai comme valeur.
        bolResult = True
    ' Sinon,
    Else
        ' Retourne faux comme valeur.
        bolResult = False
        ' Sort de la boucle.
        Exit For
    End If
Next lngCounter
' Retourne la valeur de bolResult.
IsBinary = bolResult

End Function

Public Function IsDecimal(ByVal strNumber As String) As Boolean

'
Dim lngCounter As Long
'
Dim strTemp As String * 1
'
Dim bolResult As Boolean
'
For lngCounter = 1 To Len(strNumber)
    '
    strTemp = Mid(strNumber, lngCounter, 1)
    '
    Select Case strTemp
        '
        Case 0 To 9
            '
            bolResult = True
        '
        Case Else
            '
            bolResult = False
            '
            Exit For
    End Select
Next lngCounter
'
IsDecimal = bolResult

End Function
Public Function DecToBin(ByVal curNumber As Currency) As String

' Variable des résultats.
Dim curResult As Currency
' Variable des résultats temporaires.
Dim curTempResult As Currency
' Variable temporaire.
Dim curTemp As Currency
' Variable des résultats en hexadécimal.
Dim strTemp As String
' Mettre la valeur de lngNumber dans lngResult.
curResult = curNumber
' Faire,
Do
    ' Mettre e résultat dans la variable des résultats temporaires.
    curTempResult = curResult
    ' Diviser le nombre par 16 et prendre la partie entière.
    curResult = Int(curResult / 2)
    ' Le résultat moins curResult fois 16
    curTemp = (curTempResult - (curResult * 2))
    '
    If curTemp = 0 Then
        '
        strTemp = strTemp & "0"
    '
    ElseIf curTemp = 1 Then
        '
        strTemp = strTemp & "1"
    End If
Loop Until curResult = 0
'
DecToBin = strTemp

End Function

Public Function DecToOct(ByVal curNumber As Currency) As Currency

' Variable des résultats.
Dim curResult As Currency
' Variable des résultats temporaires.
Dim curTempResult As Currency
' Variable temporaire.
Dim curTemp As Currency
'
Dim strTemp As String
' Mettre la valeur de lngNumber dans lngResult.
curResult = curNumber
' Faire,
Do
    ' Mettre e résultat dans la variable des résultats temporaires.
    curTempResult = curResult
    ' Diviser le nombre par 8 et prendre la partie entière.
    curResult = Int(curResult / 8)
    ' Le résultat moins curResult fois 16
    curTemp = (curTempResult - (curResult * 8))
    '
    Select Case curTemp
        '
        Case 0 To 7
            '
            strTemp = strTemp & curTemp
    End Select
Loop Until curResult = 0
'
DecToOct = strTemp

End Function
Public Function BinToDec(ByVal strNumber As String) As Currency

' Variable compteur pour la position de la lettre.
Dim lngCounter As Long
' Variable du résultat finale.
Dim curFinal As Currency
' Variable pour le nombre de chaque position.
Dim curNumber As Currency
' Tableau des sommes des résultats.
Dim curResults() As Currency
' Variable de test d'un caractère.
Dim strTest As String * 1
'
For lngCounter = 0 To Len(strNumber) - 1
    '
    strTest = Mid(strNumber, lngCounter + 1, 1)
    '
    Select Case strTest
        '
        Case 0 To 1
            '
            curNumber = strTest
    End Select
    ' Redimenssionner le tableau de résultats.
    ReDim Preserve curResults(lngCounter)
    '
    curResults(lngCounter) = curNumber * (2 ^ lngCounter)
Next lngCounter
'
For lngCounter = 0 To UBound(curResults())
    '
    curFinal = curFinal + curResults(lngCounter)
Next lngCounter

BinToDec = curFinal

End Function

Public Function OctToDec(ByVal strNumber As String) As Currency

' Variable compteur pour la position de la lettre.
Dim lngCounter As Long
' Variable du résultat finale.
Dim curFinal As Currency
' Variable pour le nombre de chaque position.
Dim curNumber As Currency
' Tableau des sommes des résultats.
Dim curResults() As Currency
' Variable de test d'un caractère.
Dim strTest As String * 1
'
For lngCounter = 0 To Len(strNumber) - 1
    '
    strTest = Mid(strNumber, lngCounter + 1, 1)
    '
    Select Case strTest
        '
        Case 0 To 7
            '
            curNumber = strTest
    End Select
    ' Redimenssionner le tableau de résultats.
    ReDim Preserve curResults(lngCounter)
    '
    curResults(lngCounter) = curNumber * (8 ^ lngCounter)
Next lngCounter
'
For lngCounter = 0 To UBound(curResults())
    '
    curFinal = curFinal + curResults(lngCounter)
Next lngCounter

OctToDec = curFinal

End Function
Public Function DecToHex(ByVal curNumber As Currency) As String

' Variable des résultats.
Dim curResult As Currency
' Variable des résultats temporaires.
Dim curTempResult As Currency
' Variable temporaire.
Dim curTemp As Currency
' Variable des résultats en hexadécimal.
Dim strTemp As String
' Mettre la valeur de lngNumber dans lngResult.
curResult = curNumber
' Faire,
Do
    ' Mettre e résultat dans la variable des résultats temporaires.
    curTempResult = curResult
    ' Diviser le nombre par 16 et prendre la partie entière.
    curResult = Int(curResult / 16)
    '
    If curResult = 0 Then
        '
        curTemp = curTempResult
    '
    Else
        ' Le résultat moins curResult fois 16
        curTemp = (curTempResult - (curResult * 16))
    End If
        '
        Select Case curTemp
            '
            Case 0 To 9
                '
                strTemp = strTemp & curTemp
            '
            Case 10
                '
                strTemp = strTemp & "A"
            '
            Case 11
                '
                strTemp = strTemp & "B"
            '
            Case 12
                '
                strTemp = strTemp & "C"
            '
            Case 13
                '
                strTemp = strTemp & "D"
            '
            Case 14
                '
                strTemp = strTemp & "E"
            '
            Case 15
                '
                strTemp = strTemp & "F"
        End Select
Loop Until curResult = 0
' Retourne le nombre en hexadecimal
DecToHex = strTemp

End Function

Public Function HexToDec(ByVal strNumber As String) As Currency

' Variable compteur pour la position de la lettre.
Dim lngCounter As Long
' Variable du résultat finale.
Dim curFinal As Currency
' Variable pour le nombre de chaque position.
Dim curNumber As Currency
' Tableau des sommes des résultats.
Dim curResults() As Currency
' Variable de test d'un caractère.
Dim strTest As String * 1
'
For lngCounter = 0 To Len(strNumber) - 1
    '
    strTest = Mid(strNumber, lngCounter + 1, 1)
    '
    Select Case strTest
        '
        Case 0 To 9
            '
            curNumber = strTest
        '
        Case "A"
            '
            curNumber = 10
        '
        Case "B"
            '
            curNumber = 11
        '
        Case "C"
            '
            curNumber = 12
        '
        Case "D"
            '
            curNumber = 13
        '
        Case "E"
            '
            curNumber = 14
        '
        Case "F"
            '
            curNumber = 15
    End Select
    ' Redimenssionner le tableau de résultats.
    ReDim Preserve curResults(lngCounter)
    '
    curResults(lngCounter) = curNumber * (16 ^ lngCounter)
Next lngCounter
'
For lngCounter = 0 To UBound(curResults())
    '
    curFinal = curFinal + curResults(lngCounter)
Next lngCounter

HexToDec = curFinal

End Function

Public Function BinToOct(ByVal strNumber As String) As Currency

'
Dim curResult1 As Currency
'
Dim curResult2 As Currency
'
curResult1 = Me.BinToDec(strNumber)
'
curResult2 = Me.DecToOct(curResult1)
'
BinToOct = curResult2

End Function

Public Function BinToHex(ByVal strNumber As String) As String

'
'
Dim curResult1 As Currency
'
Dim curResult2 As String
'
curResult1 = Me.BinToDec(strNumber)
'
curResult2 = Me.DecToHex(curResult1)
'
BinToHex = curResult2

End Function

Public Function OctToBin(ByVal curNumber As Currency) As String

'
Dim curResult1 As Currency
'
Dim curResult2 As String
'
curResult1 = Me.OctToDec(curNumber)
'
curResult2 = Me.DecToBin(curResult1)
'
OctToBin = curResult2

End Function

Public Function OctToHex(ByVal curNumber As Currency) As String

'
Dim curResult1 As Currency
'
Dim curResult2 As String
'
curResult1 = Me.OctToDec(curNumber)
'
curResult2 = Me.DecToHex(curResult1)
'
OctToHex = curResult2

End Function

Public Function HexToBin(ByVal strNumber As String) As String

'
Dim curResult1 As Currency
'
Dim curResult2 As String
'
curResult1 = Me.HexToDec(strNumber)
'
curResult2 = Me.DecToBin(curResult1)
'
HexToBin = curResult2

End Function

Public Function HexToOct(ByVal strNumber As String) As Currency

'
Dim curResult1 As Currency
'
Dim curResult2 As Currency
'
curResult1 = Me.HexToDec(strNumber)
'
curResult2 = Me.DecToOct(curResult1)
'
HexToOct = curResult2

End Function

Conclusion :


Si il y a des bugs veuillez me le faire savoir s.v.p.
MERCI

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (FunkySteps)