(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.
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 SubAhora 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 FunctionY eso es todo. Si quieres bajarte todo el código, pulsa este link (formulas2.zip 13.1 KB)