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...:
Cls_InfraExp.cls
Ejemplo en Uso:
Dulce Infierno Lunar!¡.
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 (Vb) [Seleccionar]
'
' /////////////////////////////////////////////////////////////
' // 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 (vb) [Seleccionar]
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!¡.