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.
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 <[email protected]>
'----------------------------------------------------------------------------------
'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)
