[Source-Actualizacion 6] Operaciones aritmeticas con Hex, Oct, Binario y Decimal

Bueno esta clase la estuve haciendo para realizar un trabajo en mi Institución, (y para saltarme algunas cuestiones), se las dejo por si alguien la desea usar para lo que desees..

Si tiene errores favor de reportarmelos...

Se puede optener el resultado por o la:

* Normal
* por el Complemento de la Base... ( Sin Signo )

Falta optimizar algunas cosas... el CODIGO ESTA FUNCIONAL...

(Esto solo fue una chapusada...) Permiti las funciones tales como en la sintasys de las operaciones Aritmeticas...:

sin() --> Seno
kos() --> Coseno
tan() --> Tangente
log() --> Logaritmo
sqr() --> Raiz
sgn() --> Devuelve un entero que indica el signo de un número

Cls_InfraExp.cls

Código

 
'
'   /////////////////////////////////////////////////////////////
'   // Autor:   BlackZeroX ( Ortega Avila Miguel Angel )       //
'   // Autor:   Agradesimientos a Raul y Spyke (ExpReg)        //
'   //                                                         //
'   // Web:     http://InfrAngeluX.Sytes.Net/                  //
'   //                                                         //
'   //    |-> Pueden Distribuir Este Codigo siempre y cuando   //
'   // no se eliminen los creditos originales de este codigo   //
'   // No importando que sea modificado/editado o engrandesido //
'   // o achicado, si es en base a este codigo es requerido    //
'   // el agradacimiento al autor.                             //
'   /////////////////////////////////////////////////////////////
'   /////////////////////////////////////////////////////////////
'   /////////////////////////////////////////////////////////////
 
Option Explicit
Option Base 0
Option Compare Text
 
Public Enum Bases
    base16 = &H10
    base10 = &HA
    base8 = &H8
    base2 = &H2
End Enum
 
Public Enum ReturnType
    SinSigno = &H0
    ConSigno
End Enum
 
Private Const cError                As String = "<-Error->"
Private Const Str_Artimetica        As String = "\/*-+^()"
Private Const Str_IndexBases        As String = "0123456789abcdef"
Private Const Str_Funciones         As String = "sinkostanlogsqrsgn"
Private Obj_RunExpr                 As Object
Private Obj_ExpRegular              As Object
 
Public Property Get StrError() As String: StrError = cError: End Property
 
Private Function ParseExpresion(ByRef InExpresion As String, ByRef InBaseNow As Bases) As Boolean
Dim lng_Pos(1)          As Long
Dim lng_index           As Long
Dim Str_ToValidate      As String
 
    Str_ToValidate$ = Replace$(InExpresion, " ", "", 1, , vbTextCompare)
    For lng_index& = 1 To Len(Str_Funciones) Step 3
        Str_ToValidate$ = Replace$(Str_ToValidate$, Mid$(Str_Funciones, lng_index&, 3), "", 1, , vbTextCompare)
    Next
    For lng_index& = 1 To Len(Str_Artimetica)
        Str_ToValidate$ = Replace$(Str_ToValidate$, Mid$(Str_Artimetica, lng_index&, 1), "", 1, , vbTextCompare)
    Next
    If Not VerificFormat(Str_ToValidate$, InBaseNow) Then
        InExpresion = cError
        Exit Function
    End If
 
    InExpresion = " " & Replace$(InExpresion, " ", "", 1, , vbTextCompare) & " "
    For lng_index = 1 To Len(Str_Artimetica$)
        InExpresion = Replace$(InExpresion, Mid$(Str_Artimetica$, lng_index, 1), " " & Mid$(Str_Artimetica$, lng_index, 1) & " ", 1, , vbTextCompare)
    Next
    InExpresion = Replace$(InExpresion, "  ", "", 1, , vbTextCompare)
 
    If Not InBaseNow = base10 Then
        For lng_index = 1 To Len(Str_IndexBases)
            lng_Pos&(0) = InStr(lng_Pos&(1) + 1, InExpresion, " " & Mid$(Str_IndexBases$, lng_index, 1), vbTextCompare)
            If lng_Pos&(0) > 0 Then
                lng_Pos&(1) = InStr(lng_Pos&(0) + 1, InExpresion, " ", vbTextCompare)
                If lng_Pos&(1) - lng_Pos&(0) + 1 > 0 Then
                    InExpresion = Mid$(InExpresion, 1, lng_Pos&(0) - 1) & "(ConvSystem(" & Chr(34) & Mid$(InExpresion, lng_Pos&(0) + 1, lng_Pos&(1) - lng_Pos&(0) - 1) & Chr(34) & "," & InBaseNow & ",10)+0)" & Mid$(InExpresion, lng_Pos&(1))
                    lng_index = lng_index - 1
                End If
                lng_Pos&(1) = 0
            End If
        Next
    End If
 
    ParseExpresion = True
 
End Function
 
 
Public Function ConvSystem(ByVal vDataIn$, ByVal inFrom As Bases, ByVal inDest As Bases, Optional ByRef Opciones As ReturnType = ConSigno) As Variant
Dim isNegative          As Boolean
    If Not (inFrom = inDest And inFrom = base10) Then
        '   //  Puedo usar unas cuantas Obviaciones Directas.. aun que mejor usare la conversion larga...
        If inFrom = base10 Then
            ConvSystem = Dec2Base(Val(vDataIn$), inDest, Opciones)
        Else
            isNegative = Val(vDataIn$) < 0
            If Not isNegative Then
                ConvSystem = Dec2Base(Base2Dec(vDataIn$, inFrom), inDest, Opciones)
            Else
                If inFrom = base16 Then
                    ConvSystem = Dec2Base(Base2Dec(vDataIn$, inFrom) * -1, inDest, Opciones)
                Else
                    ConvSystem = Dec2Base(Base2Dec(Val(vDataIn$), inFrom) * -1, inDest, Opciones)
                End If
            End If
        End If
    Else
        ConvSystem = vDataIn$
    End If
End Function
 
Public Function GetAritmeticExpresion(ByVal Expresion As String, ByRef InBase As Bases, Optional ByVal Opciones As ReturnType = ConSigno) As String
    If Obj_RunExpr Is Nothing Then Exit Function
    If ParseExpresion(Expresion, InBase) Then
        Expresion = Replace$(Expresion, "kos", "cos", 1, , vbTextCompare)
        With Obj_RunExpr
            If Not (InBase = base10 And Opciones = SinSigno) Then
                If InBase = base10 Then
                    GetAritmeticExpresion = Dec2Base(.Eval(Expresion$), InBase, Opciones)
                Else
                    GetAritmeticExpresion = Dec2Base(CLng(.Eval(Expresion$)), InBase, Opciones)
                End If
            Else
                If InBase = base10 Then
                    GetAritmeticExpresion = .Eval(Expresion)
                Else
                    GetAritmeticExpresion = CLng(.Eval(Expresion))
                End If
            End If
        End With
    Else
        GetAritmeticExpresion = cError
    End If
End Function
 
Public Function GetMaxBase(ByRef ThisBase As Bases) As String
    Select Case ThisBase
        Case base16:    GetMaxBase = "F"
        Case Else:      GetMaxBase = CStr(ThisBase - 1)
    End Select
End Function
 
Public Function Dec2Base(ByVal inval As Double, ByRef InBase As Bases, Optional ByRef Opciones As ReturnType = ConSigno) As String
Dim isNegative          As Boolean
Dim Lng_LeninVal          As Long
    isNegative = inval < 0
    Dec2Base = inval
    If isNegative Then
        Dec2Base = (inval * -1)
        If Not InBase = base10 Then Dec2Base = pDec2Base(Val(Dec2Base), InBase)
        If Opciones = SinSigno Then
            Lng_LeninVal = Len(Dec2Base)
            Dec2Base = pDec2Base(Base2Dec(String(Lng_LeninVal, GetMaxBase(InBase)), InBase) - (inval * -1) + 1, InBase)
            Dec2Base = String$(10, GetMaxBase(InBase)) & String$(Lng_LeninVal - Len(Dec2Base), "0") & Dec2Base
            If InBase = base8 Then Dec2Base = "1" & Dec2Base
        End If
    Else
        If Not InBase = base10 Then Dec2Base = pDec2Base(inval, InBase)
    End If
End Function
 
Private Function pDec2Base(ByRef inval As Double, ByRef InBase As Bases) As String
Dim lng_Aux#(1)
    lng_Aux#(0) = (inval# \ InBase)
    lng_Aux#(1) = (inval# Mod InBase)
    If inval < InBase Then
        If InBase = base16 Then
            pDec2Base = Hex(lng_Aux#(1))
        Else
            pDec2Base = lng_Aux#(1)
        End If
    Else
        If InBase = base16 Then
            pDec2Base = pDec2Base(lng_Aux#(0), InBase) & Hex(lng_Aux#(1))
        Else
            pDec2Base = pDec2Base(lng_Aux#(0), InBase) & lng_Aux#(1)
        End If
    End If
End Function
 
'   //  Hex no afecta a bases inferiores por ello lo dejo.
Private Function Base2Dec(ByRef inval As String, ByRef InBase As Bases) As Double
Dim lng_lenStr&
Dim lng_Pointer&
Dim lng_Potencia&
    lng_lenStr& = Len(inval)
    lng_Potencia& = 0
    For lng_Pointer& = lng_lenStr& To InStr(1, inval, "-") + 1 Step -1
       Base2Dec = Base2Dec + CLng("&H" & Mid$(inval, lng_Pointer, 1)) * InBase ^ lng_Potencia&
        lng_Potencia& = lng_Potencia& + 1
    Next lng_Pointer&
End Function
 
Public Function VerificFormat(ByVal InStrData As String, InBase As Bases) As Boolean
    If Obj_ExpRegular Is Nothing Then Exit Function
    With Obj_ExpRegular
        Select Case InBase
            Case base16:    .Pattern = "^[0-9a-fA-F]+$"
            Case base10:    .Pattern = "^[0-9]+$"
            Case base8:     .Pattern = "^[0-7]+$"
            Case base2:     .Pattern = "^[0-1]+$"
        End Select
        VerificFormat = .test(InStrData)
    End With
End Function
 
Private Sub Class_Initialize()
    Set Obj_RunExpr = CreateObject("ScriptControl")
    Set Obj_ExpRegular = CreateObject("VBScript.RegExp")
    With Obj_RunExpr
        .Language = "vbscript"
        Call .AddObject("InfraClass", Me, True)
    End With
End Sub
 
Private Sub Class_Terminate()
    Set Obj_RunExpr = Nothing
    Set Obj_ExpRegular = Nothing
End Sub

Ejemplo en Uso:

Código

 
Private Sub Form_Load()
Dim c As New Cls_InfraExp
Const Operacion As String = "11-1111*(111/111*111)"
    With c
        MsgBox "Operacion Hexadecimal" & vbCrLf & _
               "Operacion Sin Signo --> " & .GetAritmeticExpresion(Operacion, base16, ConSigno) & vbCrLf & _
               "Operacion Con Signo --> " & .GetAritmeticExpresion(Operacion, base16, SinSigno)
        MsgBox "Operacion Decimal" & vbCrLf & _
               "Operacion Sin Signo --> " & .GetAritmeticExpresion(Operacion, base10, ConSigno) & vbCrLf & _
               "Operacion Con Signo --> " & .GetAritmeticExpresion(Operacion, base10, SinSigno)
        MsgBox "Operacion Octal" & vbCrLf & _
               "Operacion Sin Signo --> " & .GetAritmeticExpresion(Operacion, base8, ConSigno) & vbCrLf & _
               "Operacion Con Signo --> " & .GetAritmeticExpresion(Operacion, base8, SinSigno)
        MsgBox "Operacion Binaria" & vbCrLf & _
               "Operacion Sin Signo --> " & .GetAritmeticExpresion(Operacion, base2, ConSigno) & vbCrLf & _
               "Operacion Con Signo --> " & .GetAritmeticExpresion(Operacion, base2, SinSigno)
    End With
End Sub

Dulce Infierno Lunar!¡.