Asimilador de funciones

Evalúa cadenas de texto como funciones reales de variable real. Funciona con métodos recursivos.
				Private Punto As Long, a() As Single
Private Salir As Boolean, Causa As String

Private Function ConvertirConE(ByVal Funcion As String) As String
Dim Pos As Long, Exponente As String
Dim I As Integer, Texto(1) As String

ConvertirConE = Funcion
I = 1
Do
Pos = InStr(I, ConvertirConE, "E", vbBinaryCompare)
If Pos <> 0 Then
Texto(0) = Mid$(ConvertirConE, 1, Pos - 1)
Exponente = "(" & Mid$(ConvertirConE, Pos + 1, 3) & ")"
Texto(1) = Mid$(ConvertirConE, Pos + 4, Len(ConvertirConE) - Pos)
ConvertirConE = Texto(0) & "*10^" & Exponente & Texto(1)
End If
I = Pos
Loop Until Pos = 0

End Function

Private Function BuscarMD(f As String, Inicio As Integer) As Integer
Dim I As Integer
Dim Caracter As String * 1
Dim PA As Boolean
Dim P As Integer
P = 0
PA = False
I = Inicio
Do
Caracter = Mid$(f, I, 1)
Select Case Caracter
Case "("
P = P - 1
Case ")"
P = P + 1
Case "*", "/"
If P = 0 Then
BuscarMD = I
Exit Do
End If
End Select
If I >= Len(f) And P = 0 Then
BuscarMD = Len(f) + 1
Exit Do
ElseIf I >= Len(f) And P <> 0 Then
MsgBox "Error de Parentesis"
Exit Do
End If
I = I + 1
Loop
End Function

Public Sub LeerIntervalo(ByVal Intervalo As String, ByRef a As Single, ByRef b As Single)
Dim Caracter As String * 1
Dim I As Integer, Correcto As Boolean
Dim Coma As Integer, ExisteComa As Boolean

Correcto = True
ExisteComa = False
Intervalo = Trim$(Intervalo)
If Intervalo = "" Then
MsgBox "Escriba el intervalo.", vbOKOnly, "Error de Ingreso"
Exit Sub
End If
If Mid$(Intervalo, 1, 1) <> "(" Or Mid$(Intervalo, Len(Intervalo), 1) <> ")" Then
Correcto = False
End If
If Correcto Then
For I = 2 To Len(Intervalo) - 1
Caracter = Mid$(Intervalo, I, 1)
If Caracter = "," And I <> 2 And I <> Len(Intervalo) - 1 Then
If ExisteComa Then
Correcto = False
Exit For
End If
Coma = I
ExisteComa = True
ElseIf Caracter = "," And (I = 2 Or I = Len(Intervalo) - 1) Then
Correcto = False
End If
Next I
End If
If Not Correcto Then
MsgBox "Se ha escrito el intervalo de manera incorrecta." & vbCrLf & _
"Intente escribirlo de la siguiente manera: (a,b)," & vbCrLf & _
"donde a y b son números reales o funciones dependientes" & vbCrLf & _
"de x evaluadas en x=0 (p.e. (ln(2)+1,3), (sen(x)+2,x+3) .", vbOKOnly, "Error de ingreso"
Exit Sub
End If
a = f(0, Mid$(Intervalo, 2, Coma - 2))
b = f(0, Mid$(Intervalo, Coma + 1, Len(Intervalo) - Coma - 1))

End Sub
Private Function LeerNumero(Funcion As String, Inicio As Integer) As String
Dim k As Integer, bPunto As Boolean
bPunto = False
k = Inicio
Do
Select Case Mid$(Funcion, k, 1)
Case "0" To "9"
LeerNumero = LeerNumero & Mid$(Funcion, k, 1)
Case ".", ","
If bPunto = False Then
LeerNumero = LeerNumero & ","
bPunto = True
Else
Causa = "Mal uso de puntos decimales"
Salir = True
Exit Function
End If
Case Else
Exit Do
End Select
k = k + 1
Loop
End Function

Private Function SigOperador(Funcion As String, Inicio As Integer) As Long
Dim I As Integer
Dim Caracter As String * 1
Dim PA As Boolean
Dim P As Integer
P = 0
PA = False
I = Inicio
Do
Caracter = Mid$(Funcion, I, 1)
Select Case Caracter
Case "("
P = P - 1
Case ")"
P = P + 1
Case "+", "-" ', "*", "/"
If P = 0 Then
SigOperador = I
Exit Do
End If
End Select
If I >= Len(Funcion) And P = 0 Then
SigOperador = Len(Funcion) + 1
Exit Do
ElseIf I >= Len(Funcion) And P <> 0 Then
Salir = True
Causa = "Error de paréntesis"
Exit Do
End If
I = I + 1
Loop
End Function

Private Function ProdCoc(Funcion As String, Inicio As Integer) As Long
Dim I As Integer
Dim Caracter As String * 1
Dim PA As Boolean
Dim P As Integer
P = 0
PA = False
I = Inicio
Do
Caracter = Mid$(Funcion, I, 1)
Select Case Caracter
Case "("
P = P - 1
Case ")"
P = P + 1
Case "*", "/"
If P = 0 Then
ProdCoc = I
Exit Do
End If
End Select
If I >= Len(Funcion) And P = 0 Then
ProdCoc = Len(Funcion) + 1
Exit Do
ElseIf I >= Len(Funcion) And P <> 0 Then
Causa = "Error de Parentesis"
Salir = True
Exit Do
End If
I = I + 1
Loop
End Function
Private Function VerificarF(Funcion As String) As Boolean
Dim I As Integer
Dim P As Integer
Dim Par As String * 1

VerificarF = True
For I = 1 To Len(Funcion)
Par = Mid$(Funcion, I, 1)
If Par = "(" Then P = P - 1
If Par = ")" Then P = P + 1
Next I
If P <> 0 Then VerificarF = False
End Function

Private Function BuscarParentesis(Funcion As String, Inicio) As Integer
Dim I As Integer
Dim P As Integer
Dim Caracter As String * 1
I = Inicio
P = 0
Do
Caracter = Mid$(Funcion, I, 1)
If Caracter = "(" Then P = P - 1
If Caracter = ")" Then
P = P + 1
BuscarParentesis = I
End If

If I > Len(Funcion) Then
Causa = "Error de Parentesis"
Salir = True
Exit Do
End If
I = I + 1
Loop Until P = 0
End Function

Public Function f(T As Double, Func As String) As Double
Dim Caracter As String * 1
Dim I As Integer, k As Long, h As Long
Dim FuncS As String
Dim Numero As String, Tv As Double
Dim X As Single
'On Error GoTo Errores

Salir = False
Causa = ""

For I = 1 To Len(Func)
Caracter = Mid$(Func, I, 1)
Select Case Caracter
Case "x"
f = T
Case "0" To "9"
Numero = Caracter & LeerNumero(Func, I + 1)
If Salir Then GoTo Fin
f = CSng(Numero)
I = Len(Numero)
Case "+", "-"
k = SigOperador(Func, I + 1) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 1, k - I)
f = f + Val(Caracter & "1") * f(T, FuncS)
I = I + Len(FuncS)
Case "("
k = BuscarParentesis(Func, I) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 1, k - I)
f = f(T, FuncS)
I = I + Len(FuncS) + 1
Case "*"
k = SigOperador(Func, I + 1) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 1, k - I)
f = f * f(T, FuncS)
I = I + Len(FuncS)
Case "/"
k = SigOperador(Func, I + 1) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 1, k - I)
Tv = f(T, FuncS)
If Tv <> 0 Then
f = f / Tv
Else
Causa = "División por cero"
Exit Function
End If
I = I + Len(FuncS)
Case "^"
h = ProdCoc(Func, I + 1) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 1, h - I)
If f <> 0 And f(T, FuncS) > 0 Then
f = f ^ f(T, FuncS)
Else
Causa = "División por cero"
Exit Function
End If
I = I + Len(FuncS)
Case "s"
Select Case Mid$(Func, I, 4)
Case "sen("
k = BuscarParentesis(Func, I + 3) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 4, k - (I + 3))
f = Sin(f(T, FuncS))
I = I + Len(FuncS) + 4
Case "sec("
k = BuscarParentesis(Func, I + 3) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 4, k - (I + 3))
Tv = Cos(f(T, FuncS))
If Tv <> 0 Then
f = Tv ^ -1
Else
Causa = "División por cero"
Exit Function
End If
I = I + Len(FuncS) + 4
Case "sig("
Dim Z As Single
k = BuscarParentesis(Func, I + 3) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 4, k - (I + 3))
Z = f(T, FuncS)
If Z > 0 Then f = 1
If Z = 0 Then f = 0
If Z < 0 Then f = -1
I = I + Len(FuncS) + 4
End Select
Select Case Mid$(Func, I, 5)
Case "senh("
k = BuscarParentesis(Func, I + 4) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 5, k - (I + 4))
f = (Exp(f(T, FuncS)) - Exp(-f(T, FuncS))) / 2
I = I + Len(FuncS) + 5
Case "sech("
k = BuscarParentesis(Func, I + 4) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 5, k - (I + 4))
f = f(T, "1/cosh(" & FuncS & ")")
I = I + Len(FuncS) + 5
End Select
Case "t"
If Mid$(Func, I, 4) = "tan(" Then
k = BuscarParentesis(Func, I + 3) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 4, k - (I + 3))
Tv = Cos(f(T, FuncS))
If Tv <> 0 Then
f = Tan(f(T, FuncS))
Else
Causa = "División por cero"
Exit Function
End If
I = I + Len(FuncS) + 4
ElseIf Mid$(Func, I, 5) = "tanh(" Then
k = BuscarParentesis(Func, I + 4) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 5, k - (I + 4))
f = f(T, "senh(" & FuncS & ")/cosh(" & FuncS & ")")
I = I + Len(FuncS) + 5
End If
Case "c"
Select Case Mid$(Func, I, 4)
Case "cos("
k = BuscarParentesis(Func, I + 3) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 4, k - (I + 3))
f = Cos(f(T, FuncS))
I = I + Len(FuncS) + 4
Case "csc("
k = BuscarParentesis(Func, I + 3) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 4, k - (I + 3))
Tv = Sin(f(T, FuncS))
If Tv <> 0 Then
f = Sin(f(T, FuncS)) ^ -1
Else
Causa = "División por cero"
Exit Function
End If
I = I + Len(FuncS) + 4
Case "cot("
k = BuscarParentesis(Func, I + 3) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 4, k - (I + 3))
Tv = Sin(f(T, FuncS))
If Tv <> 0 Then
f = Tan(f(T, FuncS)) ^ -1
Else
Causa = "División por cero"
Exit Function
End If
I = I + Len(FuncS) + 4
End Select
Select Case Mid$(Func, I, 5)
Case "cosh("
k = BuscarParentesis(Func, I + 4) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 5, k - (I + 4))
f = (Exp(f(T, FuncS)) + Exp(-f(T, FuncS))) / 2
I = I + Len(FuncS) + 5
Case "csch("
k = BuscarParentesis(Func, I + 4) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 5, k - (I + 4))
I = I + Len(FuncS) + 5
Tv = f(T, "senh(" & FuncS & ")")
If Tv <> 0 Then
f = ((Exp(f(T, FuncS)) - Exp(-f(T, FuncS))) / 2) ^ -1
Else
Causa = "División por cero"
Exit Function
End If
Case "coth("
k = BuscarParentesis(Func, I + 4) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 5, k - (I + 4))
I = I + Len(FuncS) + 5
Tv = f(T, "tanh(" & FuncS & ")")
If Tv <> 0 Then
f = f(T, "cosh(" & FuncS & ")/senh(" & FuncS & ")")
Else
Causa = "División por cero"
Exit Function
End If
End Select
Case "e"
If Mid$(Func, I, 4) = "exp(" Then
k = BuscarParentesis(Func, I + 3) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 4, k - (I + 3))
f = Exp(f(T, FuncS))
I = I + Len(FuncS) + 4
Else
GoTo FuncionDesconocida
End If
Case "a"
Select Case Mid$(Func, I, 5)
Case "atan("
k = BuscarParentesis(Func, I + 4) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 5, k - (I + 4))
I = I + Len(FuncS) + 5
f = Atn(f(T, FuncS))
Case "asen("
k = BuscarParentesis(Func, I + 4) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 5, k - (I + 4))
I = I + Len(FuncS) + 5
X = f(T, FuncS)
f = Atn(X / Sqr(-X * X + 1))
Case "acos("
k = BuscarParentesis(Func, I + 4) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 5, k - (I + 4))
I = I + Len(FuncS) + 5
X = f(T, FuncS)
f = Atn(-X / Sqr(-X * X + 1)) + 2 * Atn(1)
Case "asec("
k = BuscarParentesis(Func, I + 4) - 1
If Salir Then GoTo Fin
I = I + Len(FuncS) + 5
FuncS = Mid$(Func, I + 5, k - (I + 4))
X = f(T, FuncS)
f = Atn(X / Sqr(X * X - 1)) + Sgn(X - 1) * 2 * Atn(1)
Case "acsc("
k = BuscarParentesis(Func, I + 4) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 5, k - (I + 4))
I = I + Len(FuncS) + 5
X = f(T, FuncS)
f = Atn(X / Sqr(X * X - 1)) + Sgn(X - 1) * 2 * Atn(1)
End Select
Select Case Mid$(Func, I, 6)
Case "acosc("
k = BuscarParentesis(Func, I + 5) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 6, k - (I + 5))
I = I + Len(FuncS) + 6
X = f(T, FuncS)
f = Atn(X / Sqr(X * X - 1)) + Sgn(X - 1) * 2 * Atn(1)
Case "acotg("
k = BuscarParentesis(Func, I + 5) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 6, k - (I + 5))
I = I + Len(FuncS) + 6
X = f(T, FuncS)
f = Atn(X) + 2 * Atn(1)
Case "asenh("
k = BuscarParentesis(Func, I + 5) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 6, k - (I + 5))
I = I + Len(FuncS) + 6
X = f(T, FuncS)
f = Log(X + Sqr(X * X + 1))

Case "acosh("
k = BuscarParentesis(Func, I + 5) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 6, k - (I + 5))
I = I + Len(FuncS) + 6
X = f(T, FuncS)
f = Log(X + Sqr(X * X - 1))

Case "atanh("
k = BuscarParentesis(Func, I + 5) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 6, k - (I + 5))
I = I + Len(FuncS) + 6
X = f(T, FuncS)
f = Log((1 + X) / (1 - X)) / 2

Case "asech("
k = BuscarParentesis(Func, I + 5) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 6, k - (I + 5))
I = I + Len(FuncS) + 6
X = f(T, FuncS)
f = Log((Sqr(-X * X + 1) + 1) / X)

Case "acsch("
k = BuscarParentesis(Func, I + 5) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 6, k - (I + 5))
I = I + Len(FuncS) + 6
X = f(T, FuncS)
f = Log((Sgn(X) * Sqr(X * X + 1) + 1) / X)

Case "acoth("
k = BuscarParentesis(Func, I + 5) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 6, k - (I + 5))
I = I + Len(FuncS) + 6
X = f(T, FuncS)
f = Log((X + 1) / (X - 1)) / 2
End Select
If Mid$(Func, I, 4) = "abs(" Then
k = BuscarParentesis(Func, I + 3) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 4, k - (I + 3))
I = I + Len(FuncS) + 4
X = f(T, FuncS)
f = Abs(X)
End If

Case "l"
If Mid$(Func, I, 3) = "ln(" Then
k = BuscarParentesis(Func, I + 2) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 3, k - (I + 2))
I = I + Len(FuncS) + 3
Tv = f(T, FuncS)
If Tv > 0 Then
f = Log(Tv)
Else
Causa = "Argumento inválido"
Exit Function
End If
ElseIf Mid$(Func, I, 4) = "log(" Then
k = BuscarParentesis(Func, I + 3) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 4, k - (I + 3))
I = I + Len(FuncS) + 4
Tv = f(T, FuncS)
If Tv > 0 Then
f = Log(Tv) / Log(10)
Else
Causa = "Argumento inválido"
Exit Function
End If
End If
Case "r"
If Mid$(Func, I, 5) = "raiz(" Then
k = BuscarParentesis(Func, I + 4) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 5, k - (I + 4))
I = I + Len(FuncS) + 5
Tv = f(T, FuncS)
If Tv >= 0 Then
f = Sqr(f(T, FuncS))
Else
Causa = "Argumento inválido"
Exit Function
End If
End If
Case "u"
Dim u As Single
If Mid$(Func, I, 2) = "u(" Then
k = BuscarParentesis(Func, I + 1) - 1
If Salir Then GoTo Fin
FuncS = Mid$(Func, I + 2, k - (I + 1))
I = I + Len(FuncS) + 2
u = f(T, FuncS)
If u > 0 Then f = 1
If u <= 0 Then f = 0
End If
Case Else
FuncionDesconocida:
Causa = "Función no definida"
Exit Function
End Select
GoTo Fin
Errores:
Select Case Err.Number
Case 11, 5, 6
Err.Clear
End Select
Fin:
If Salir = True Then Exit For
Next I
End Function

Public Property Get CausaError() As String
CausaError = Causa
End Property


Descargar adjuntos
COMPARTE ESTE TUTORIAL

COMPARTIR EN FACEBOOK
COMPARTIR EN TWITTER
COMPARTIR EN LINKEDIN
COMPARTIR EN WHATSAPP
SIGUIENTE TUTORIAL