cFormula
Analizador de expresiones numéricas

(nueva versión)

Publicado el 09/Feb/99
Revisado el 10/Feb/99 (con mejoras)

Pulsa este link si quieres ver la revisión del 11/Ene/2001

Nota del 02/Nov/2002:
Te recomiendo que veas el contenido de esta página que te mantendrá al día



Un poco de historia: (un cuento de los del Guille)

Estaba yo atareadillo pensando en cómo mejorar la calculadora esa que tengo hecha en VB y se me ocurrió que sería interesante que se pudiera añadir funciones personalizadas o lo que es lo mismo, poder usar el número calculado en una función definida, por ejemplo para calcular porcentajes y algunas otras cosillas.

Lo primero que pensé fue en usar el módulo que tenía creado para evaluar expresiones, de esta forma reusaría un código válido, pero ese código no es tan válido, bueno, realmente funciona y si se saben las limitaciones, hasta es útil, de hecho se que le ha sido útil a un montón de gente (y a otras que ni siquiera me lo han dicho).

¿Cuales son las limitaciones del código anterior?
Pues que por ejemplo no evalua bien las "precedencias" de los operadores, digamos que tenemos esta expresión:
20+3*2
El resultado, si lo hicieramos con el VB sería: 26, pero en la utilidad esa que tengo daría 46, es decir primero suma y después multiplica; bueno, no es eso tampoco, sino que evalua de izquierda a derecha, para que funcionase correctamente habría que escribir la expresión de esta otra foirma: 20+ (3*2) y el resultado sería el esperado.

Con esta nueva versión ese "problemilla" está solucionado.

Pero aún hay más:
Ahora se permiten variables con cualquier longitud, (no recuerdo si antes también, pero es igual)
Y lo más importante: se pueden crear funciones propias o usar algunas del VB, hasta ahora he "evaluado" estas funciones:
Rnd, Int, Fix, Abs, Atn, Cos, Sin, Tan, Exp, Log, Sgn, además de las derivadas: Sec, CoSec, CoTan, estas últimas usando las funciones anteriores.

Una cosa que hay que decir, es que las variables pueden actuar como funciones, me explico:
Si tenemos declaradas las variables A y B con unos valores y creamos: C = A+B, cuando se use la variable C, realmente se estará evaluando la suma de A + B; esto es un  dato importante, aunque en esta implementación no se pueden asignar variables al vuelo, (es decir: hay que declararlas primero para poder usarlas), en una revisión posterior, se permitirá, (espero), poder definirlas en la misma expresión que se pase para evaluar.

En la clase cFormula también encontrarás un par de funciones que amplían la función InStr del VB:
MultInStr que sirve para buscar múltiples coincidencias de cadenas, devolviendo la que esté más al principio de la cadena.
RInStr que busca desde el final (esta función ya está implementada en el VB6, aunque "mi" versión es más compatible con la InStr del VB, al menos en lo que al formato de los parámetros)

 

Ya está bien de historias, veamos el código:

El código de ejemplo también lo he añadido, ya que en él se ve cómo usar esta clase, que como verás es super-fácil de usar e implementar.

Veamos primero el form de ejemplo, con parte del código, y después el código completo de la clase.
Por supuesto puedes bajarte el zip con todo el código, el link lo tienes al final de la página.

Y como siempre, espero tus comentarios sobre esta clase y si te parece interesante o si le ves algún fallo... que de seguro los habrá.

Como adelanto de lo que podrás encontrar en la nueva versión (que aún está por hacerse):
---Definir nuevas variables dentro de la misma expresión
---Usar funciones de manejo de cadenas de caracteres
---Evaluar expresiones con IF/THEN y seguramente uso de bucles FOR/NEXT, DO/LOOP, etc...
Aunque no sé para cuando será, ni si serán posibles todas estas cosas... todo se andará...


Novedades del 10/Feb/99:

Ahora permite definir variables en la misma expresión, se admiten funciones con más de un parámetro e incluso con un número variable de parámetros y algunos otros arreglillos...

Así que, bájate el código nuevo y échale un vistazo. (formulas2a.zip 17.3 KB)

NOTA: Por ahora el código aquí mostrado es el de la versión del 09/Feb/99, en cuanto pueda lo cambio.


 

form de ejemplo para usar con cFormulas
Como puedes ver, puedes definir tus propias funciones y variables que usen funciones.

Ahora parte del código que hace que este form funcione:

'
Private Sub cmdCalcular_Click()
    ' Comprobar si funciona el tema de ParseFormula
    Dim i As Long
    Dim j As Long
    Dim sFormula As String
    Dim sParams As String
    Dim sName As String
    
    Set tFormulas = Nothing
    Set tFormulas = New cFormulas
    ' Añadir las variables que están en el List1
    With List1
        For i = 0 To .ListCount - 1
            j = InStr(.List(i), "=")
            tFormulas.NewVariable Left$(.List(i), j - 1), Mid$(.List(i), j + 1)
        Next
    End With
    ' Añadir las funciones que están en el List3
    ' Nota: Aunque se borre alguna de las "intrínsecas", se volverán a tener
    ' ya que se asignan con el Class Initialize y en este procedimiento
    ' se elimina y se vuelve a crear la clase.
    With List3
        For i = 0 To .ListCount - 1
            j = InStr(.List(i), "=")
            sName = Trim$(Left$(.List(i), j - 1))
            sFormula = Mid$(.List(i), j + 1)
            j = InStr(sFormula, "|")
            sParams = Trim$(Mid$(sFormula, j + 1))
            sFormula = Trim$(Left$(sFormula, j - 1))
            tFormulas.NewFunction sName, sParams, sFormula
        Next
    End With
    
    ' Si se quiere calcular la fórmula, pero mostrando antes como queda
    ' después de asignar las variables, etc.
    sFormula = tFormulas.ParseFormula(Text1(cTxtFormula))
    'Label1(6) = sFormula & " = " & tFormulas.Calcular(sFormula)
    Label1(6) = sFormula
    Label1(cLblResultado) = tFormulas.Calcular(sFormula)
    Label1(6) = sFormula & " = " & Label1(cLblResultado)
    
    ' Para calcularlo directamente
    'Label1(cLblResultado) = tFormulas.Formula(Text1(cTxtFormula))
    
    ' Esto es para que se vean las variables y funciones que se han usado
    List2.Clear
    tFormulas.ShowVariables List2
    List3.Clear
    tFormulas.ShowFunctions List3
End Sub

Ahora el código de la clase, este es algo más largo.

'
'----------------------------------------------------------------------------------
'cFormulas                                                              (06/Feb/99)
'   Clase para evaluar expresiones
'
'©Guillermo 'guille' Som, 1999 <mensaje@elguille.info>
'----------------------------------------------------------------------------------
'Revisión del  7/Feb/99 Ahora se evaluan correctamente los operadores con más
'                       precedencia, en este orden: % ^ * / \ + -
'                       También se permiten paréntesis no balanceados,
'                       al menos los de apertura.
'                       Si faltan los de cierre se añaden al final.
'                       Se permiten definir Funciones y usar algunas internas
'                       siempre que no necesiten parámetros (por ahora Rnd)
'Revisión del  9/Feb/99 Se pueden usar funciones internas con parámetros:
'                       Por ahora: Int, Fix, Abs, Sgn, Sqr, Cos, Sin, Tan, Atn, Exp
'                       Log
'----------------------------------------------------------------------------------
' Esta es una nueva implementación del módulo Formula.bas y la clase cEvalOp
' Aunque los métodos usados son totalmente diferentes y realmente no es una
' mejora, están basados en dichos módulos... o casi...
'
'Por el código anterior: (c)Guillermo 'guille' Som, 1991-98
'----------------------------------------------------------------------------------
Option Explicit
Option Compare Text

' Funciones Internas soportadas en el programa,
' debe indicarse el paréntesis y un espacio de separación
Const FunVBNum As String = "Int( Fix( Abs( Sgn( Sqr( Cos( Sin( Tan( Atn( Exp( Log( "
' Símbolos a usar para separar los Tokens
Private Simbols As String
' Signos a usar para comentarios
Private RemSimbs As String

' Tipo para las variables
Private Type tVariable
    Name As String
    Value As String
End Type
' Array de variables
Private aVariables() As tVariable

' Tipo para las funciones
Private Type tFunctions
    Name As String
    Params As String
    Formula As String
    'Descripcion As String
End Type
' Array de funciones
Private aFunctions() As tFunctions


Private Function aToken(ByRef sF As String, ByRef sSimbol As String) As String
    '------------------------------------------------------------------------------
    ' Devuelve el siguiente TOKEN y el Símbolo siguiente
    ' un Token es una variable, instrucción, función o número
    '
    ' Los parámetros se deben especificar por referencia ya que se modifican:
    '   sF          Cadena con la fórmula o expresión a Tokenizar
    '   sSimbol     El símbolo u operador a usar
    ' Se devolverá la cadena con lo hallado o una cadena vacía si no hay nada
    '------------------------------------------------------------------------------
    Dim j As Long
    Dim sSimbs As String
    
    ' Usar los símbolos normales y los usados para los comentarios
    sSimbs = Simbols & RemSimbs & " " & Chr$(34)
    
    ' Si la cadena de entrada está vacía o sólo tiene blancos
    If Len(Trim$(sF)) = 0 Then
        aToken = ""
        sF = ""
    Else
        j = MultInStr(sF, sSimbs, sSimbol)
        ' El valor devuelto será el símbolo que esté más a la izquierda
        If j = 0 Then
            ' Devolver la cadena completa
            aToken = sF
            sF = ""
        Else
            ' Devolver lo hallado hasta el token
            aToken = Left$(sF, j - 1)
            sF = Mid$(sF, j + Len(sSimbol))
            ' Si el número está en notación científica xxxEyyy
            If Right$(aToken, 1) = "E" Then
                aToken = aToken & sSimbol & Left$(sF, 2)
                sF = Mid$(sF, 3)
                sSimbol = ""
            End If
        End If
    End If
End Function


Public Function MultInStr(ByVal String1 As String, ByVal String2 As String, _
                          Optional ByRef sSimb As String, Optional ByVal Start As Long = 1) As Long
    '------------------------------------------------------------------------------
    ' Siempre se especificarán los tres parámetros,
    ' opcionalmente, el último será la posición de inicio o 1 si no se indica
    '
    ' Busca en la String1 cualquiera de los caracteres de la String2,
    ' devolviendo la posición del que esté más a la izquierda.
    ' El parámetro sSep se pasará por referencia y en él se devolverá
    ' el separador hallado.
    '
    ' En String2 se deberán separar con espacios los caracteres a buscar
    '------------------------------------------------------------------------------
    Dim j As Long
    Dim sTmp As String
    ' La posición con un valor menor
    Dim elMenor As Long
    ' Caracter de separación
    Const sSep As String = " "
    
    ' Hacer un bucle entre cada uno de los valores indicados en String2
    elMenor = 0
    If Start <= Len(String1) Then
        String2 = Trim$(String2) & sSep
        ' Se buscarán todas las subcadenas de String2
        Do
            j = InStr(String2, sSep)
            If j Then
                sTmp = Left$(String2, j - 1)
                String2 = Mid$(String2, j + Len(sSep))
                If Len(sTmp) Then
                    j = InStr(Start, String1, sTmp)
                Else
                    j = 0
                End If
                If j Then
                    If elMenor = 0 Or elMenor > j Then
                        elMenor = j
                        sSimb = sTmp
                    End If
                    ' Si es la posición de inicio, no habrá ninguno menor
                    ' así que salimos del bucle
                    If elMenor = Start Then
                        String2 = ""
                    End If
                End If
            Else
                String2 = ""
            End If
        Loop While Len(String2)
    End If
    MultInStr = elMenor
End Function


Private Sub Class_Initialize()
    '------------------------------------------------------------------------------
    ' Iniciar algunos valores y algunas de las funciones internas del VB
    ' soportadas por esta clase, (ver la constante FunVBNum)
    '------------------------------------------------------------------------------
    Dim i As Long
    Dim j As Long
    Dim sName As String
    Dim sFunVB As String
    '
    ' Símbolos
    Simbols = ":= < > = >= <= ( ) ^ * / \ - + $ ! # @ { } [ ] "
    ' Comentarios
    RemSimbs = "' ; // "
    ' Inicializar el array con el elemento cero, que no se usará
    ReDim aVariables(0)
    ReDim aFunctions(0)
    
    ' Función Rnd del VB
    NewFunction "Rnd", "", "@Rnd"
    ' Añadir las declaradas en la constante FunVar
    ' Las funciones deben estar separadas por espacios y acabar con el (
    ' por ejemplo: "Int( Fix( "
    '
    sFunVB = FunVBNum
    Do
        i = InStr(sFunVB, "( ")
        If i Then
            sName = Left$(sFunVB, i - 1)
            sFunVB = Mid$(sFunVB, i + 2)
            NewFunction sName, "Num", "@" & sName & "(Num)"
        End If
    Loop While Len(sFunVB)
    ' Añadir otras para que sirvan de ejemplo
    ' No usar el signo @ si hacen uso de algunas de las definidas
    ' sino el resultado sería el de esa función... esto habrá que arreglarlo...
    NewFunction "Sec", "Num", "1/Cos(Num)"
    NewFunction "CoSec", "Num", "1/Sin(Num)"
    NewFunction "CoTan", "Num", "1/Tan(Num)"
    '
End Sub


Public Function IsVariable(ByVal sName As String) As Long
    '------------------------------------------------------------------------------
    ' Comprueba si es una variable,
    ' de ser así, devolverá el índice en el array de variables
    ' o cero si no se ha hallado.
    ' En caso de no hallar la variable, la añade con el valor cero
    '------------------------------------------------------------------------------
    Dim i As Long
    Dim sVar As String
    Dim sVal As String
    
    sName = Trim$(sName)
    IsVariable = 0
    If Len(sName) Then
        For i = 1 To UBound(aVariables)
            If aVariables(i).Name = sName Then
                IsVariable = i
                Exit For
            End If
        Next
    End If
    ' Si no existe la variable
    If IsVariable = 0 Then
        ' y no es un número
        If Len(sName) Then
            If Not IsNumeric(sName) Then
                ' Este caso ya no se dará, pero por si las moscas       (08/Feb/99)
                sVar = sName
                If Right$(sName, 1) = "E" Then
                    sName = sName & "-02"
                End If
                ' Por si es un número con E
                BuscarCifra sName, sVal
                NewVariable sVar, sVal
                IsVariable = UBound(aVariables)
            End If
        End If
    End If
End Function


Public Function IsFunction(ByVal sName As String) As Long
    '------------------------------------------------------------------------------
    ' Comprueba si es una función,
    ' de ser así, devolverá el índice en el array de fórmulas
    ' o cero si no se ha hallado
    '------------------------------------------------------------------------------
    Dim i As Long
    
    sName = Trim$(sName)
    IsFunction = 0
    If Len(sName) Then
        For i = 1 To UBound(aFunctions)
            If aFunctions(i).Name = sName Then
                IsFunction = i
                Exit For
            End If
        Next
    End If
End Function


Public Function FunctionVal(ByVal sName As String) As String
    '------------------------------------------------------------------------------
    ' Comprueba si sName contiene una fórmula interna
    ' Estará en el formato: @FormulaInterna
    ' Sólo será válido para funciones que no necesiten parámetros
    ' Ahora se permite un parámetro en las funciones soportadas         (08/Feb/99)
    '------------------------------------------------------------------------------
    Dim i As Long
    Dim sValue As String
    Dim sParams As String
    Dim sNameFun As String
    
    sName = Trim$(sName)
    i = InStr(sName, "@")
    If i Then
        sValue = Left$(sName, i - 1) & Mid$(sName, i + 1)
        ' Si es Rnd
        i = InStr(sValue, "Rnd")
        ' El formato será Rnd [* valor]
        If i Then
            sName = Left$(sValue, i - 1) & "(" & Rnd & ")" & Mid$(sValue, i + 3)
        End If
        '//////////////////////////////////////////////////////////////////////////
        ' Si es alguna de las definidas en la constante FunVBNum
        ' sNameFun devolverá el nombre de la función hallada
        i = MultInStr(sValue, FunVBNum, sNameFun)
        ' El formato será NombreFunción(expresión)
        If i Then
            sName = Mid$(sValue, i + 3)
            sParams = Parametros(sName)
            ' Calcular los parámetros
            sParams = Calcular(sParams)
            ' Convertir el parámetro para usar con estas funciones numéricas
            Select Case sNameFun
            Case "Int("
                sParams = Int(sParams)
            Case "Fix("
                sParams = Fix(sParams)
            Case "Abs("
                sParams = Abs(sParams)
            Case "Sgn("
                sParams = Sgn(sParams)
            Case "Sqr("
                sParams = Sqr(sParams)
            Case "Cos("
                sParams = Cos(sParams)
            Case "Sin("
                sParams = Sin(sParams)
            Case "Tan("
                sParams = Tan(sParams)
            Case "Atn("
                sParams = Atn(sParams)
            Case "Exp("
                sParams = Exp(sParams)
            Case "Log("
                sParams = Log(sParams)
            End Select
            sName = "(" & sParams & ")" & sName
        End If
        '//////////////////////////////////////////////////////////////////////////
    End If
    FunctionVal = sName
End Function


Public Function VariableVal(ByVal sName As String) As String
    '------------------------------------------------------------------------------
    ' Comprueba si es una variable,
    ' de ser así, devolverá el contenido o valor de esa variable
    '
    ' Las variables estarán en un array
    '------------------------------------------------------------------------------
    Dim i As Long
    Dim sValue As String
    
    sName = Trim$(sName)
    sValue = ""
    If Len(sName) Then
        For i = 1 To UBound(aVariables)
            If aVariables(i).Name = sName Then
                sValue = aVariables(i).Value
                Exit For
            End If
        Next
    End If
    VariableVal = sValue
End Function


Public Sub NewFunction(ByVal sName As String, ByVal sParams As String, ByVal sFormula As String)
    '------------------------------------------------------------------------------
    ' Asigna una nueva función al array de funciones
    ' Los parámetros serán el nombre, los parámetros y la fórmula a usar
    '
    ' Si la función indicada ya existe, se sustituirán los valores especificados
    '------------------------------------------------------------------------------
    Dim i As Long
    Dim Hallado As Boolean
    Dim NumF As Long
    
    sName = Trim$(sName)
    sParams = Trim$(sParams)
    sFormula = Trim$(sFormula)
    
    NumF = UBound(aFunctions)
    Hallado = False
    ' Comprobar si la función ya existe
    For i = 1 To NumF
        ' Si es así, asignar el nuevo valor
        If aFunctions(i).Name = sName Then
            aFunctions(i).Params = sParams
            aFunctions(i).Formula = sFormula
            Hallado = True
            Exit For
        End If
    Next
    ' Si no se ha hallado la función, añadirla
    If Not Hallado Then
        NumF = NumF + 1
        ReDim Preserve aFunctions(0 To NumF)
        With aFunctions(NumF)
            .Name = sName
            .Params = sParams
            .Formula = sFormula
        End With
    End If
End Sub


Public Sub NewVariable(ByVal sName As String, ByVal sValue As String)
    '------------------------------------------------------------------------------
    ' Asigna una nueva variable al array de variables
    ' Los parámetros serán el nombre y el valor
    '
    ' Si la variable indicada ya existe, se sustituirá el valor por el indicado
    '------------------------------------------------------------------------------
    Dim i As Long
    Dim Hallado As Boolean
    Dim NumVars As Long
    
    sName = Trim$(sName)
    sValue = Trim$(sValue)
    
    NumVars = UBound(aVariables)
    Hallado = False
    ' Comprobar si la variable ya existe
    For i = 1 To NumVars
        ' Si es así, asignar el nuevo valor
        If aVariables(i).Name = sName Then
            aVariables(i).Value = sValue
            Hallado = True
            Exit For
        End If
    Next
    ' Si no se ha hallado la variable, añadir una nueva
    If Not Hallado Then
        NumVars = NumVars + 1
        ReDim Preserve aVariables(0 To NumVars)
        With aVariables(NumVars)
            .Name = sName
            .Value = sValue
        End With
    End If
End Sub


Public Function ParseFormula(ByVal sF As String) As String
    '------------------------------------------------------------------------------
    ' Analiza la fórmula indicada, sustituyendo las variables y funciones
    ' por sus valores, después habrá que calcular el resultado devuelto.
    ' En esta función se analizan las variables y funciones, dejando el valor
    ' que devolverían.
    ' Si la variable o función tiene otras variables o funciones se analizan
    ' y se ponen los valores devueltos.
    '------------------------------------------------------------------------------
    Dim sFormula As String
    Dim sToken As String
    Dim i As Long
    Dim sOp As String
    Dim sVar As String
    Dim qFuncion As Long
    Dim sParams As String
    Dim sFunFormula As String
    Dim j As Long
    Dim k As Long
    
    Do
        ' Asignar a sToken el siguiente elemento a procesar
        sOp = ""
        sToken = aToken(sF, sOp)
        ' Si no es una función ni una variable, usar el valor indicado
        If Len(sToken) Then
            ' Si no es una variable o función
            If Not IsFuncOrVar(sToken) Then
                sFormula = sFormula & sToken & sOp
            Else
                ' Comprobar si el Token es una variable,
                ' si es así sustituirla por el valor
                sVar = VariableVal(sToken)
                If Len(sVar) Then
                    ' Comprobar si la variable contiene otras variables
                    ' o funciones
                    sVar = ParseFormula(sVar)
                    ' Asigna a sToken el valor obtenido
                    sToken = Calcular(sVar)
                End If
                ' Comprobar si el Token es una función
                qFuncion = IsFunction(sToken)
                ' Si es una función, qFuncion tiene el índice de la función
                If qFuncion Then
                    ' Asignar los parámetros que usa la función
                    ' (en principio sólo se admite un parámetro)
                    sVar = aFunctions(qFuncion).Params
                    ' La fórmula a usar para esta función
                    sFunFormula = aFunctions(qFuncion).Formula
                    ' Si admite parámetros
                    If Len(sVar) Then
                        '//////////////////////////////////////////////////////////
                        ' Usar la funcion Parametros para analizar los prámetros
                        '//////////////////////////////////////////////////////////
                        If sOp = "(" Then
                            sF = sOp & sF
                            sParams = Parametros(sF)
                            If Len(sParams) Then
                                sOp = ""
                            End If
                        End If
                        If Len(sParams) Then
                            ' Comprobar si los parámetros contienen alguna variable
                            ' u otra función
                            sParams = ParseFormula(sParams)
                            '
                            ' Sustituir los parámetros por los indicados en la fórmula
                            ' (en principio sólo se admite uno)
                            ' Sustituir en la fórmula el nombre de la variable
                            ' por el parámetro
                            '
                            Do
                                i = InStr(sFunFormula, sVar)
                                If i Then
                                    ' Poner los parámetros dentro de paréntesis
                                    sFunFormula = Left$(sFunFormula, i - 1) & "(" & sParams & ")" & _ 
						  Mid$(sFunFormula, i + Len(sVar))
                                End If
                            Loop While i
                        End If
                    End If
                    ' Si tiene @FuncionInterna
                    ' usar esa función
                    sVar = ""
                    sVar = FunctionVal(sFunFormula)
                    If Len(sVar) Then
                        sFunFormula = ParseFormula(sVar)
                    End If
                    sFormula = sFormula & Calcular(sFunFormula & sOp & sF)
                    sF = ""
                Else
                    sFormula = sFormula & sToken & sOp
                End If
            End If
        Else
            sFormula = sFormula & sToken & sOp
        End If
        '
    Loop While Len(sF)
    ' Devolver la expresión lista para calcular el valor
    ParseFormula = sFormula
End Function


Public Function Calcular(ByVal sFormula As String) As String
    '------------------------------------------------------------------------------
    ' Calcula el resultado de la expresión que entra en sFormula        (22/Oct/91)
    ' Modificado por la cuenta de la vieja...                     (01.12  7/May/93)
    '------------------------------------------------------------------------------
    Dim Operador As String
    Dim Cifra1 As String
    Dim Cifra2 As String
    Dim n1 As Double
    Dim n2 As Double
    Dim n3 As Double
    Dim i As Long
    Dim pn As Long
    Dim strP As String
    '
    Dim sOperadores As String
    ' Estos son los símbolos a buscar para el operador anterior
    ' se deben incluir los paréntesis ya que estos separan precedencias
    Const cOperadores = "%^*/\+-()"
    Dim j As Long
    Dim k As Long
    Dim j1 As Long
    Dim k1 As Long
    Dim n As Long
    Dim kk As Long
    '
    ' Quitarle los espacios extras
    sFormula = Trim$(sFormula)
    '
    '//////////////////////////////////////////////////////////////////////////////
    ' Para analizar siguiendo las operaciones de más "peso",            (07/Feb/99)
    ' se buscarán operaciones en este orden % ^ * / \ + -
    ' y si se encuentran, se incluirán entre paréntesis para que se procesen
    ' antes que el resto:
    ' 25 + 100 * 3 se convertiría en: 25 + (100 * 3)
    '
    ' Buscar cada uno de los operadores y añadir los paréntesis necesarios
    ' No se incluyen la suma y resta ya que son las que menos peso tienen
    sOperadores = "% ^ * / \ "
    ' Sólo procesar si tiene uno de los operadores
    If MultInStr(sFormula, sOperadores, Operador) Then
        Cifra1 = sFormula
        n = Len(Cifra1)
        For i = 1 To Len(sOperadores) Step 2
            Operador = Mid$(sOperadores, i, 1)
            ' Se debería buscar de atrás para delante
            ' (ya se busca)
            pn = RInStr(n, Cifra1, Operador)
            If pn Then
                ' Tenemos ese operador
                ' buscar el signo anterior
                k = 0
                For j = pn - 1 To 1 Step -1
                    k = InStr(cOperadores, Mid$(Cifra1, j, 1))
                    If k Then
                        ' Sólo procesar si el signo anterior es diferente de )
                        If Mid$(cOperadores, k, 1) <> ")" Then
                            ' Buscar el signo siguiente
                            k1 = 0
                            For j1 = pn + 1 To Len(Cifra1)
                                k1 = InStr(cOperadores, Mid$(Cifra1, j1, 1))
                                If k1 Then
                                    ' Añadirle los paréntesis
                                    ' Si se multiplica por un número negativo
                                    k = MultInStr(Cifra1, "*- /- \- ")
                                    If k Then
                                        Cifra1 = Left$(Cifra1, j) & "(" & Mid$(Cifra1, j + 1, j1 - j - 2) & _
						")" & Mid$(Cifra1, k)
                                    Else
                                        If Right$(Mid$(Cifra1, j + 1, j1 - j - 1) & ")" & Mid$(Cifra1, j1, 1), 3) = "*)(" Then
                                            Cifra1 = Left$(Cifra1, j) & "(" & Mid$(Cifra1, j + 1, j1 - j - 2) & _
							Mid$(Cifra1, j1 - 1) & ")"
                                        Else
                                            Cifra1 = Left$(Cifra1, j) & "(" & Mid$(Cifra1, j + 1, j1 - j - 1) & _ 
							")" & Mid$(Cifra1, j1)
                                        End If
                                    End If
                                    Exit For
                                End If
                            Next
                            ' Si no hay ningún signo siguiente
                            If k1 = 0 Then
                                Cifra1 = Left$(Cifra1, j) & "(" & Mid$(Cifra1, j + 1) & ")"
                            End If
                        End If
                        Exit For
                    End If
                Next
                pn = RInStr(n, Cifra1, Operador)
                n = pn - 1
                i = i - 2
            End If
        Next
        sFormula = Cifra1
    End If
    '
    '//////////////////////////////////////////////////////////////////////////////
    '
    ' Buscar paréntesis e ir procesando las expresiones.
    Do While InStr(sFormula, "(")
        pn = InStr(sFormula, ")")
        ' Si hay paréntesis de cierre
        If pn Then
            For i = pn To 1 Step -1
                If Mid$(sFormula, i, 1) = "(" Then
                    ' Calcular lo que está entre paréntesis
                    strP = Mid$(sFormula, i + 1, pn - i - 1)
                    strP = Calcular(strP)
                    sFormula = Left$(sFormula, i - 1) & strP & Mid$(sFormula, pn + 1)
                    Exit For
                End If
            Next
        Else
            sFormula = sFormula & ")"
        End If
    Loop
    
    ' Si la fórmula a procesar tiene algún operador
    sOperadores = "% ^ * / \ + - "
    If MultInStr(sFormula, sOperadores, Operador) Then
        Operador = ""
        Cifra1 = ""
        Cifra2 = ""
        Do
            ' Buscar la primera cifra
            If Len(sFormula) Then
                If Cifra1 = "" Then
                    BuscarCifra sFormula, Cifra1
                End If
                Operador = Left$(sFormula, 1)
                sFormula = Mid$(sFormula, 2)
                ' Buscar la segunda cifra
                BuscarCifra sFormula, Cifra2
                '
                If Len(Cifra1) Then
                    n1 = CDbl(Cifra1)
                End If
                ' Esto es necesario por si no se ponen los paréntesis de apertura
                If Len(Cifra2) Then
                    n2 = CDbl(Cifra2)
                End If
                ' Efectuar el cálculo
                Select Case Operador
                Case "+"
                    n3 = n1 + n2
                Case "-"
                    n3 = n1 - n2
                Case "*"
                    n3 = n1 * n2
                ' Si se divide por cero, se devuelve cero en lugar de dar error
                Case "/"
                    If n2 <> 0# Then
                        n3 = n1 / n2
                    Else
                        n3 = 0#
                    End If
                Case "\"
                    If n2 <> 0# Then
                        n3 = n1 \ n2
                    Else
                        n3 = 0#
                    End If
                Case "^"
                    n3 = n1 ^ n2
                ' Cálculo de porcentajes:
                ' 100 % 25 = 25 (100 * (25 / 100))
                Case "%"
                    n3 = n1 * (n2 / 100#)
                ' Si no es una operación reconocida, devolver la suma,
                ' ya que esto puede ocurrir con los valores asignados a variables
                Case Else
                    ' Por si se incluye una palabra que no está declarada
                    ' (variable o función)
                    If Len(Cifra1 & Cifra2) Then
                        If Len(Cifra1) = 0 Then
                            Cifra1 = "0"
                        End If
                        If Len(Cifra2) = 0 Then
                            Cifra2 = "0"
                        End If
                        n3 = CDbl(Cifra1) + CDbl(Cifra2)
                    Else
                        n3 = 0
                    End If
                End Select
                Cifra1 = CStr(n3)
            Else
                Exit Do
            End If
        Loop While Operador <> ""
        Calcular = CStr(n3)
    Else
        ' Si no tiene ningún operador, devolver la fórmula
        Calcular = sFormula
    End If
End Function


Public Function RInStr(ByVal v1 As Variant, ByVal v2 As Variant, _
                        Optional ByVal v3 As Variant) As Long
    '------------------------------------------------------------------------------
    ' Devuelve la posición de v2 en v1, empezando por atrás
    '------------------------------------------------------------------------------
    Dim i As Long
    Dim sTmp As String
    Dim s1 As String
    Dim s2 As String
    Dim posIni As Long
    
    If IsMissing(v3) Then
        ' Si no se especifican los tres parámetros
        s1 = CStr(v1)       ' La primera cadena
        s2 = CStr(v2)       ' la segunda cadena
        posIni = Len(s1)    ' el último caracter de la cadena
    Else
        posIni = CLng(v1)   ' la posición por la que empezar
        s1 = CStr(v2)       ' la primera cadena (segundo parámetro)
        s2 = CStr(v3)       ' la segunda cadena (tercer parámetro)
    End If
    ' Valor inicial de la búsqueda, si no se encuentra, es cero
    RInStr = 0
    ' Siempre se empieza a buscar por el final
    For i = posIni - Len(s2) + 1 To 1 Step -1
        ' Tomar el número de caracteres que tenga la segunda cadena
        sTmp = Mid$(s1, i, Len(s2))     ' Si son iguales...
        If sTmp = s2 Then               ' esa es la posición
            RInStr = i
            Exit For
        End If
    Next
End Function


Private Sub BuscarCifra(ByRef Expresion As String, ByRef Cifra As String)
    '------------------------------------------------------------------------------
    ' Buscar en Expresion una cifra                                ( 5 / 10/May/93)
    ' Devuelve la cifra y el resto de la expresión
    '------------------------------------------------------------------------------
    Const OPERADORES = "+-*/\^%"
    Const CIFRAS = "0123456789., "
    Const POSITIVO = 1, NEGATIVO = -1
    
    Dim Signo As Long
    Dim ultima As Long
    Dim i As Long
    Dim n As String
    Dim sCifras As String
    Dim sSigno As String
    
    ' Quitar los espacios del principio
    Expresion = LTrim$(Expresion)
    
    Signo = POSITIVO                    'Comprobar si es un número negativo
    If Left$(Expresion, 1) = "-" Then
        Signo = NEGATIVO
        Expresion = Mid$(Expresion, 2)
    End If
    
    ultima = 0
    n = ""
    For i = 1 To Len(Expresion)
        If InStr(CIFRAS, Mid$(Expresion, i, 1)) Then
            n = n + Mid$(Expresion, i, 1)
            ultima = i
        Else
            Exit For
        End If
    Next i
    ' El val funciona sólo si el decimal es el punto,
    ' cuando es una coma toma sólo la parte entera
    If Len(n) Then
        ' Convertir adecuadamente los decimales
        n = ConvDecimal(n)
        Cifra = CStr((n) * Signo)
    Else
        Cifra = ""
    End If
    Expresion = LTrim$(Mid$(Expresion, ultima + 1))
    If Left$(Expresion, 1) = "E" Then
        ultima = Val(Mid$(Expresion, 3))
        sSigno = Mid$(Expresion, 2, 1)
        n = ""
        For i = 1 To ultima
            n = n & "0"
        Next
        n = "1" & n
        If sSigno = "-" Then
            Cifra = (Cifra) / (n)
        Else
            Cifra = (Cifra) * (n)
        End If
        Expresion = Mid$(Expresion, 5)
    End If
End Sub


Public Function ConvDecimal(ByVal strNum As String, _
                            Optional ByRef sDecimal As String = ",", _
                            Optional ByRef sDecimalNo As String = ".") As String
    '------------------------------------------------------------------------------
    ' Asigna el signo decimal adecuado (o lo intenta)                   (10/Ene/99)
    ' Devuelve una cadena con el signo decimal del sistema
    '------------------------------------------------------------------------------
    Dim sNumero As String
    Dim i As Long
    Dim j As Long
    
    ' Averiguar el signo decimal
    sNumero = Format$(25.5, "#.#")
    If InStr(sNumero, ".") Then
        sDecimal = "."
        sDecimalNo = ","
    Else
        sDecimal = ","
        sDecimalNo = "."
    End If
    
    strNum = Trim$(strNum)
    If Left$(strNum, 1) = sDecimalNo Then
        Mid$(strNum, 1, 1) = sDecimal
    End If
    
    ' Si el número introducido contiene signos no decimales
    j = 0
    i = 1
    Do
        i = InStr(i, strNum, sDecimalNo)
        If i Then
            j = j + 1
            i = i + 1
        End If
    Loop While i
    
    If j = 1 Then
        ' Cambiar ese símbolo por un espacio, si sólo hay uno de esos signos
        i = InStr(strNum, sDecimalNo)
        If i Then
            If InStr(strNum, sDecimal) Then
                Mid$(strNum, i, 1) = " "
            Else
                Mid$(strNum, i, 1) = sDecimal
            End If
        End If
    Else
        ' En caso de que tenga más de uno de estos símbolos
        ' convertirlos de manera adecuada.
        ' Por ejemplo:
        ' si el signo decimal es la coma:
        '   1,250.45 sería 1.250,45 y quedaría en 1250,45
        ' si el signo decimal es el punto:
        '   1.250,45 sería 1,250.45 y quedaría en 1250.45
        '
        ' Aunque no se arreglará un número erróneo:
        ' si el signo decimal es la coma:
        '   1,250,45 será lo mismo que 1,25
        '   12,500.25 será lo mismo que 12,50
        ' si el signo decimal es el punto:
        '   1.250.45 será lo mismo que 1.25
        '   12.500,25 será lo mismo que 12.50
        '
        i = 1
        Do
            i = InStr(i, strNum, sDecimalNo)
            If i Then
                j = j - 1
                If j = 0 Then
                    Mid$(strNum, i, 1) = sDecimal
                Else
                    Mid$(strNum, i, 1) = " "
                End If
                i = i + 1
            End If
        Loop While i
    End If
    
    j = 0
    ' Quitar los espacios que haya por medio
    Do
        i = InStr(strNum, " ")
        If i = 0 Then Exit Do
        strNum = Left$(strNum, i - 1) & Mid$(strNum, i + 1)
    Loop
    
    ConvDecimal = strNum
End Function


Private Sub Class_Terminate()
    Erase aVariables
    Erase aFunctions
End Sub


Public Sub ShowFunctions(aList As Variant)
    '------------------------------------------------------------------------------
    ' Devuelve las funciones y las fórmulas usadas en el formato:
    '   Nombre = Función | Parámentros
    ' El parámetro indicará una colección o un ListBox/ComboBox
    '------------------------------------------------------------------------------
    Dim i As Long
    
    For i = 1 To UBound(aFunctions)
        With aFunctions(i)
            If TypeOf aList Is Collection Then
                aList.Add .Name & " = " & .Formula & " | " & .Params
            Else
                aList.AddItem .Name & " = " & .Formula & " | " & .Params
            End If
        End With
    Next
End Sub


Public Sub ShowVariables(aList As Variant)
    '------------------------------------------------------------------------------
    ' Devuelve las variables y los valores en el formato:
    '   Nombre = Valor
    ' El parámetro indicará una colección o un ListBox/ComboBox
    '------------------------------------------------------------------------------
    Dim i As Long
    
    For i = 1 To UBound(aVariables)
        If TypeOf aList Is Collection Then
            aList.Add aVariables(i).Name & " = " & aVariables(i).Value
        Else
            aList.AddItem aVariables(i).Name & " = " & aVariables(i).Value
        End If
    Next
End Sub


Public Function Formula(ByVal sFormula As String) As String
    ' Esta función calcula directamente la fórmula pasada
    sFormula = ParseFormula(sFormula)
    Formula = Calcular(sFormula)
End Function


Public Function IsFuncOrVar(ByVal sName As String) As Boolean
    '------------------------------------------------------------------------------
    ' Comprobar si es una función o variable
    
    ' Es importante comprobar primero las funciones
    ' para que no se añada una función como si fuese una variable no declarada
    '------------------------------------------------------------------------------
    ' Si no es un número
    If Not IsNumeric(sName) Then
        If IsFunction(sName) Then
            IsFuncOrVar = True
        ElseIf IsVariable(sName) Then
            IsFuncOrVar = True
        End If
    End If
End Function


Private Function Parametros(ByRef sExp As String) As String
    '------------------------------------------------------------------------------
    ' Devolverá los parámetros de la expresión pasada por referencia    (08/Feb/99)
    ' Los parámetros deben estar encerrados entre paréntesis
    ' En sExp, se devolverá el resto de la cadena.
    '------------------------------------------------------------------------------
    Dim sParams As String
    Dim sExpAnt As String
    Dim i As Long
    Dim j As Long
    Dim k As Long
    '
    sExp = Trim$(sExp)
    sExpAnt = sExp
    '
    '
    ' Buscarlos, estarán entre paréntesis
    '
    If Left$(sExp, 1) = "(" Then
        sExp = Mid$(sExp, 2)
        ' Buscar el siguiente )
        k = 0
        j = 0
        For i = 1 To Len(sExp)
            If Mid$(sExp, i, 1) = "(" Then
                j = j + 1
            End If
            If Mid$(sExp, i, 1) = ")" Then
                j = j - 1
                If j = -1 Then
                    k = i
                    Exit For
                End If
            End If
        Next
        If k Then
            sParams = Left$(sExp, k - 1)
            sExp = Mid$(sExp, k + 1)
        End If
    Else
        sParams = ""
        sExp = sExpAnt
    End If
    Parametros = sParams
End Function

Y eso es todo. Si quieres bajarte todo el código, pulsa este link (formulas2.zip 13.1 KB)


ir al índice principal