'
' /////////////////////////////////////////////////////////////
' // 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