petit module qui permet de calculer a partir d'un textbox (on passe un "string" a la fonction et elle renvoi le resultat sous un "string" egalement)
toutes les fonctions principales sont presentes (trigo., log, ...)
bien sur les priorites sont respectes et les multiplication implicite sont automatiquement executes "3(5+8)" est interprete comme "3*(5+8)".
Source / Exemple :
Public c() As String
Public y As Integer
Public Function calc(chaine As String) As String
Dim test As String
Dim retour As String
Dim x As Integer
'renvoi "0" si la chaine est nul
If chaine = "" Then
calc = "0"
Exit Function
End If
'remplacement des "," par "."
test = Replace(chaine, ",", ".")
'remplacement des espaces par rien
test = Replace(test, " ", "")
'remplacement des "cr" et "lf" par rien
test = Replace(test, vbCr, "")
test = Replace(test, vbLf, "")
'test si toutes les parenteses sont presentes
If parenteses(test) = False Then
calc = "erreur de parenteses"
Exit Function
End If
'verification s'il n'y a pas de caracteres superieurs a 128
For x = 1 To Len(test)
If Asc(Mid$(test, x, 1)) > 128 Then
calc = "erreur"
Exit Function
End If
Next x
'simplification
test = Replace(test, "++", "+")
test = Replace(test, "+-", "-")
test = Replace(test, "-+", "-")
test = Replace(test, "--", "+")
test = Replace(test, "pi", "3.14159265358979323846")
'conversion des fonctions mathematiques en caracteres superieurs a 128
test = Replace(test, "harccotan", Chr$(228), , , vbTextCompare)
test = Replace(test, "arccotan", Chr$(216), , , vbTextCompare)
test = Replace(test, "harctan", Chr$(225), , , vbTextCompare)
test = Replace(test, "hcotan", Chr$(222), , , vbTextCompare)
test = Replace(test, "cotan", Chr$(211), , , vbTextCompare)
test = Replace(test, "htan", Chr$(219), , , vbTextCompare)
test = Replace(test, "tan", Chr$(207), , , vbTextCompare)
test = Replace(test, "atn", Chr$(200), , , vbTextCompare)
test = Replace(test, "harccosec", Chr$(227), , , vbTextCompare)
test = Replace(test, "arccosec", Chr$(215), , , vbTextCompare)
test = Replace(test, "harccos", Chr$(224), , , vbTextCompare)
test = Replace(test, "hcosec", Chr$(221), , , vbTextCompare)
test = Replace(test, "arccos", Chr$(213), , , vbTextCompare)
test = Replace(test, "cosec", Chr$(210), , , vbTextCompare)
test = Replace(test, "hcos", Chr$(217), , , vbTextCompare)
test = Replace(test, "cos", Chr$(201), , , vbTextCompare)
test = Replace(test, "harcsec", Chr$(226), , , vbTextCompare)
test = Replace(test, "arcsec", Chr$(214), , , vbTextCompare)
test = Replace(test, "hsec", Chr$(220), , , vbTextCompare)
test = Replace(test, "sec", Chr$(209), , , vbTextCompare)
test = Replace(test, "ln", Chr$(208), , , vbTextCompare)
test = Replace(test, "exp", Chr$(202), , , vbTextCompare)
test = Replace(test, "sqr", Chr$(203), , , vbTextCompare)
test = Replace(test, "log", Chr$(204), , , vbTextCompare)
test = Replace(test, "int", Chr$(229), , , vbTextCompare)
test = Replace(test, "abs", Chr$(230), , , vbTextCompare)
test = Replace(test, "mod", Chr$(250), , , vbTextCompare)
test = Replace(test, "harcsin", Chr$(223), , , vbTextCompare)
test = Replace(test, "arcsin", Chr$(212), , , vbTextCompare)
test = Replace(test, "hsin", Chr$(218), , , vbTextCompare)
test = Replace(test, "sin", Chr$(205), , , vbTextCompare)
test = Replace(test, "e", "2.71828182845904523536")
'mise en tableau de l'equation
retour = tableau(test)
If retour <> "ok" Then
calc = retour
Exit Function
End If
'calcul de l'equation dans le tableau
calc = calc_eq()
End Function
Private Function parenteses(test As String) As Boolean
'test s'il y a autant de parentese ouvertes que fermes
'et test si elles sont dans le bon sens
Dim x As Integer
Dim y As Integer
y = 0
For x = 1 To Len(test)
If Mid$(test, x, 1) = "(" Then y = y + 1
If Mid$(test, x, 1) = ")" Then y = y - 1
If y < 0 Then Exit For
Next x
If y = 0 Then
parenteses = True
Else
parenteses = False
End If
End Function
Private Function tableau(test As String) As String
'mise en tableau de l'equation
'et test si l'equation est ok
Dim car As String
Dim x As Integer
Dim car_avant As String
Dim fin As Boolean
fin = False
car_avant = " " 'pour ne pas gener la procedure
y = -1
For x = 1 To Len(test)
car = Mid$(test, x, 1)
If x = Len(test) Then fin = True
Select Case car
Case Chr$(200), Chr$(201), Chr$(202), Chr$(203), Chr$(204), Chr$(205), Chr$(206), Chr$(207), Chr$(208), Chr$(209), Chr$(210), Chr$(211), Chr$(212), Chr$(213), Chr$(214), Chr$(215), Chr$(216), Chr$(217), Chr$(218), Chr$(219), Chr$(220), Chr$(221), Chr$(222), Chr$(223), Chr$(224), Chr$(225), Chr$(226), Chr$(227), Chr$(228), Chr$(229), Chr$(230)
If macro_test(car, car_avant, fin) <> "ok" Then
tableau = "erreur d'ecriture au caracteres n°" + Str$(x)
Exit Function
End If
Case "+", "*", "/", "^", Chr$(250)
If fin = True Then
tableau = "erreur d'ecriture au caracteres n°" + Str$(x)
Exit Function
End If
If car_avant = ")" Or (Asc(car_avant) > 47 And Asc(car_avant) < 58) Then
Call nouveau(car)
Else
tableau = "erreur d'ecriture au caracteres n°" + Str$(x)
Exit Function
End If
Case "-"
If fin = True Then
tableau = "erreur d'ecriture au caracteres n°" + Str$(x)
Exit Function
End If
If car_avant = ")" Or (Asc(car_avant) > 47 And Asc(car_avant) < 58) Then
Call nouveau(car)
Else
If car_avant = " " Or Asc(car_avant) > 199 Or car_avant = "*" Or car_avant = "/" Or car_avant = "^" Or car_avant = "(" Then
'c'est peut etre un signe
Call nouveau(car)
car = " " + car
Else
tableau = "erreur d'ecriture au caracteres n°" + Str$(x)
Exit Function
End If
End If
Case "("
If fin = True Then
tableau = "erreur d'ecriture au caracteres n°" + Str$(x)
Exit Function
End If
If car_avant = "+" Or car_avant = "-" Or car_avant = "*" Or car_avant = "/" Or car_avant = "^" Or car_avant = "(" Or car_avant = " " Or Asc(car_avant) > 199 Then
Call nouveau(car)
Else
If car_avant = ")" Or (Asc(car_avant) > 47 And Asc(car_avant) < 58) Then
Call nouveau("*")
Call nouveau(car)
Else
If car_avant = " -" Then
c(y) = " " + car
Else
tableau = "erreur d'ecriture au caracteres n°" + Str$(x)
Exit Function
End If
End If
End If
Case ")"
If car_avant = ")" Or (Asc(car_avant) > 47 And Asc(car_avant) < 58) Then
Call nouveau(car)
Else
tableau = "erreur d'ecriture au caracteres n°" + Str$(x)
Exit Function
End If
Case "."
If fin = True Then
tableau = "erreur d'ecriture au caracteres n°" + Str$(x)
Exit Function
End If
If car_avant = "+" Or car_avant = "-" Or car_avant = "*" Or car_avant = "/" Or car_avant = "^" Or car_avant = "(" Or car_avant = " " Or Asc(car_avant) > 199 Then
Call nouveau("0" + car)
Else
If car_avant = ")" Then
Call nouveau("*")
Call nouveau("0" + car)
Else
If ((Asc(car_avant) > 47 And Asc(car_avant) < 58) And InStr(1, c(y), ".") = 0) Then
c(y) = c(y) + car
Else
If car_avant = " -" Then
c(y) = "-0" + car
Else
tableau = "erreur d'ecriture au caracteres n°" + Str$(x)
Exit Function
End If
End If
End If
End If
Case Else
If Asc(car) > 47 And Asc(car) < 58 Then
If car_avant = "+" Or car_avant = "-" Or car_avant = "*" Or car_avant = "/" Or car_avant = "^" Or car_avant = "(" Or Asc(car_avant) > 199 Or car_avant = " " Then
Call nouveau(car)
Else
If car_avant = "." Or Asc(car_avant) > 47 And Asc(car_avant) < 58 Or car_avant = " -" Then
c(y) = c(y) + car
Else
If car_avant = ")" Then
Call nouveau("*")
Call nouveau(car)
Else
If c(y) = " -" Then
c(y) = "-" + car
Else
tableau = "erreur d'ecriture au caracteres n°" + Str$(x)
Exit Function
End If
End If
End If
End If
Else
tableau = "erreur d'ecriture au caracteres n°" + Str$(x)
Exit Function
End If
End Select
car_avant = car
Next x
tableau = "ok"
End Function
Private Function macro_test(car As String, car_avant As String, fin As Boolean) As String
macro_test = "ok"
If fin = True Then
macro_test = "erreur d'ecriture au caracteres n°"
Exit Function
End If
If car_avant = "+" Or car_avant = "-" Or car_avant = "*" Or car_avant = "/" Or car_avant = "^" Or car_avant = "(" Or car_avant = " " Or Asc(car_avant) > 199 Then
Call nouveau(car)
Else
If (Asc(car_avant) > 47 And Asc(car_avant) < 58) Or car_avant = ")" Then
Call nouveau("*")
Call nouveau(car)
Else
If car_avant = " -" Then
c(y) = " " + car
Else
macro_test = "erreur d'ecriture au caracteres n°"
Exit Function
End If
End If
End If
End Function
Private Sub nouveau(car As String)
'additionne une case avec le nouveau caractere dans le tableau
y = y + 1
ReDim Preserve c(y)
c(y) = car
End Sub
Private Function par() As Integer
'recherche la premiere fermeture de parenteses
Dim x As Integer
For x = 0 To y
If c(x) = ")" Then
par = x - 1
Exit Function
End If
Next x
par = -1 'il n'y a plus de parentheses
End Function
Private Sub reorganisation(position As Integer, q As Integer)
'suppression d'un certain nomnres de case dans le tableau
Dim x As Integer
For x = position To y - q
c(x) = c(x + q)
Next x
ReDim Preserve c(y - q)
y = y - q
End Sub
Private Function calcul(operateur As Integer) As String
'calcul selon le type d'operation
Dim x As Double
Dim inv As Boolean
x = Val(c(operateur + 1))
If InStr(c(operateur), " ") > 0 Then
c(operateur) = Replace(c(operateur), " ", "")
inv = True
Else
inv = False
End If
On Error GoTo fin
Select Case c(operateur)
Case "+"
c(operateur - 1) = Replace(Str(Val(c(operateur - 1)) + x), " ", "")
Case "-"
c(operateur - 1) = Replace(Str(Val(c(operateur - 1)) - x), " ", "")
Case "*"
c(operateur - 1) = Replace(Str(Val(c(operateur - 1)) * x), " ", "")
Case "/"
c(operateur - 1) = Replace(Str(Val(c(operateur - 1)) / x), " ", "")
Case "^"
c(operateur - 1) = Replace(Str(Val(c(operateur - 1)) ^ x), " ", "")
Case Chr$(200)
'Atn(x)
c(operateur) = Replace(Str(Atn(x)), " ", "")
Case Chr$(201)
'Cos(x)
c(operateur) = Replace(Str(Cos(x)), " ", "")
Case Chr$(202)
'Exp(x)
c(operateur) = Replace(Str(Exp(x)), " ", "")
Case Chr$(203)
'Sqr(x)
c(operateur) = Replace(Str(Sqr(x)), " ", "")
Case Chr$(204)
'Log10(x) = Log(x) / Log(10)
c(operateur) = Replace(Str(Log(x) / Log(10)), " ", "")
Case Chr$(205)
'Sin(x)
c(operateur) = Replace(Str(Sin(x)), " ", "")
Case Chr$(207)
'Tan(x)
c(operateur) = Replace(Str(Tan(x)), " ", "")
Case Chr$(208)
'Ln(x)
c(operateur) = Replace(Str(Log(x)), " ", "")
Case Chr$(209)
'Sec(x) = 1 / Cos(x)
c(operateur) = Replace(Str(1 / Cos(x)), " ", "")
Case Chr$(210)
'Cosec(x) = 1 / Sin(x)
c(operateur) = Replace(Str(1 / Sin(x)), " ", "")
Case Chr$(211)
'Cotan(x) = 1 / Tan(x)
c(operateur) = Replace(Str(1 / Tan(x)), " ", "")
Case Chr$(212)
'Arcsin(X) = Atn(x / Sqr(-x * x + 1))
c(operateur) = Replace(Str(Atn(x / Sqr(-x * x + 1))), " ", "")
Case Chr$(213)
'Arccos(x) = Atn(-x / Sqr(-x * x + 1)) + 2 * Atn(1)
c(operateur) = Replace(Str(Atn(-x / Sqr(-x * x + 1)) + 2 * Atn(1)), " ", "")
Case Chr$(214)
'Arcsec(x) = Atn(x / Sqr(x * x ? 1)) + Sgn((x) ? 1) * (2 * Atn(1))
c(operateur) = Replace(Str(Atn(x / Sqr(x * x - 1)) + Sgn((x) - 1) * (2 * Atn(1))), " ", "")
Case Chr$(215)
'Arccosec(x) = Atn(x / Sqr(x * x ? 1)) + (Sgn(x) ? 1) * (2 * Atn(1))
c(operateur) = Replace(Str(Atn(x / Sqr(x * x - 1)) + (Sgn(x) - 1) * (2 * Atn(1))), " ", "")
Case Chr$(216)
'Arccotan(x) = Atn(x) + 2 * Atn(1)
c(operateur) = Replace(Str(Atn(x) + 2 * Atn(1)), " ", "")
Case Chr$(217)
'HCos(x) = (Exp(x) + Exp(-x)) / 2
c(operateur) = Replace(Str((Exp(x) + Exp(-x)) / 2), " ", "")
Case Chr$(218)
'HSin(x) = (Exp(x) ? Exp(-x)) / 2
c(operateur) = Replace(Str((Exp(x) - Exp(-x)) / 2), " ", "")
Case Chr$(219)
'HTan(x) = (Exp(x) ? Exp(-x)) / (Exp(x) + Exp(-x))
c(operateur) = Replace(Str((Exp(x) - Exp(-x)) / (Exp(x) + Exp(-x))), " ", "")
Case Chr$(220)
'HSec(x) = 2 / (Exp(x) + Exp(-x))
c(operateur) = Replace(Str(2 / (Exp(x) + Exp(-x))), " ", "")
Case Chr$(221)
'HCosec(x) = 2 / (Exp(x) ? Exp(-x))
c(operateur) = Replace(Str(2 / (Exp(x) - Exp(-x))), " ", "")
Case Chr$(222)
'HCotan(x) = (Exp(x) + Exp(-x)) / (Exp(x) ? Exp(-x))
c(operateur) = Replace(Str((Exp(x) + Exp(-x)) / (Exp(x) - Exp(-x))), " ", "")
Case Chr$(223)
'HArcsin(x) = Log(x + Sqr(x * x + 1))
c(operateur) = Replace(Str(Log(x + Sqr(x * x + 1))), " ", "")
Case Chr$(224)
'HArccos(x) = Log(x + Sqr(x * x ? 1))
c(operateur) = Replace(Str(Log(x + Sqr(x * x - 1))), " ", "")
Case Chr$(225)
'HArctan(x) = Log((1 + x) / (1 ? x)) / 2
c(operateur) = Replace(Str(Log(x + Sqr(x * x - 1))), " ", "")
Case Chr$(226)
'Harcsec(x) = Log((Sqr(-x * x + 1) + 1) / x)
c(operateur) = Replace(Str(Log((Sqr(-x * x + 1) + 1) / x)), " ", "")
Case Chr$(227)
'HArccosec(x) = Log((Sgn(x) * Sqr(x * x + 1) + 1) / x)
c(operateur) = Replace(Str(Log((Sgn(x) * Sqr(x * x + 1) + 1) / x)), " ", "")
Case Chr$(228)
'HArccotan(x) = Log((x + 1) / (x ? 1)) / 2
c(operateur) = Replace(Str(Log((x + 1) / (x - 1)) / 2), " ", "")
Case Chr$(229)
'int
c(operateur) = Replace(Str(Int(x)), " ", "")
Case Chr$(230)
'int
c(operateur) = Replace(Str(Abs(x)), " ", "")
Case Chr$(250)
c(operateur - 1) = Replace(Str(Val(c(operateur - 1)) Mod x), " ", "")
End Select
If inv = True Then
c(operateur) = Str(0 - Val(c(operateur)))
End If
calcul = "ok"
Exit Function
fin:
calcul = Error
End Function
Private Function calc_eq()
'calcul de l'equation dans le tableau
Dim retour As String
Dim x As Integer
Dim debut As Integer
Dim fin As Integer
'tant qu'il ne reste pas une seule case dans le tableau, calcul l'equation
Do Until y = 0
'recherche s 'il y a encore des parenteses
fin = par()
If fin > -1 Then
'il y a encore des parentheses
For x = fin To 0 Step -1
If c(x) = "(" Or c(x) = " (" Then
debut = x + 1
Exit For
End If
Next x
Else
'il n 'y a plus de parentheses
fin = y
debut = 0
End If
retour = calc_simple(debut, fin)
If retour <> "ok" Then
calc_eq = retour
Exit Function
End If
Loop
calc_eq = c(0)
End Function
Private Function calc_simple(debut As Integer, fin As Integer) As String
'cherche l'operateur prioritaire entre debut et fin
'1er-fonction
'2em-exposant
'3em-multiplication ou division
'4em-addition ou soustraction
's'il n'y a pas d'operateur alors simplification
Dim position As Integer
Dim retour As String
'recherche d'une fonction dans les limites (par la fin !)
For position = fin To debut Step -1
'If Len(c(position)) = 1 And Asc(c(position)) > 199 Then
If Asc(Replace(c(position), " ", "")) > 199 And Asc(Replace(c(position), " ", "")) < 250 Then
'il y a une fonction !
calc_simple = calcul(position)
'simplification s'il n'y a pas d'erreur
If calc_simple = "ok" Then
'simplification
Call reorganisation(position + 1, 1)
End If
Exit Function
End If
Next position
'recherche d'un exposant dans les limites
For position = debut To fin
'If Len(c(position)) = 1 And c(position) = "^" Then
If c(position) = "^" Then
'il y a un exposant !
calc_simple = calcul(position)
'simplification s'il n'y a pas d'erreur
If calc_simple = "ok" Then
'simplification
Call reorganisation(position, 2)
End If
Exit Function
End If
Next position
'recherche d'une multiplication, d'une division ou d'un modulo dans les limites
For position = debut To fin
'If Len(c(position)) = 1 And (c(position) = "*" Or c(position) = "/") Then
If c(position) = "*" Or c(position) = "/" Or c(position) = Chr$(250) Then
'il y a une multiplication ou division !
calc_simple = calcul(position)
'simplification s'il n'y a pas d'erreur
If calc_simple = "ok" Then
'simplification
Call reorganisation(position, 2)
End If
Exit Function
End If
Next position
'recherche d'une addition ou soustraction dans les limites
For position = debut To fin
'If Len(c(position)) = 1 And (c(position) = "+" Or c(position) = "-") Then
If c(position) = "+" Or c(position) = "-" Then
'il y a une addition ou soustraction !
calc_simple = calcul(position)
If calc_simple = "ok" Then
'simplification
Call reorganisation(position, 2)
End If
Exit Function
End If
Next position
'il n'y a pas d'operateur, essai de simplification !
'si debut=fin, test s'il y a des parenthese et si oui alors suppression
'si non test s'il ne reste pas une seule case dans le tableau
If debut = fin And debut > 0 And fin < y And (c(debut - 1) = "(" Or c(debut - 1) = " (") And c(fin + 1) = ")" Then
If c(debut - 1) = " (" Then
'inversion du signe
c(debut) = Str(0 - Val(c(debut)))
End If
Call reorganisation(debut - 1, 1)
Call reorganisation(fin, 1)
calc_simple = "ok"
Else
If y = 1 Then
calc_simple = "ok"
Else
calc_simple = "erreur"
End If
End If
End Function
Conclusion :
voila, j'espere avoir aide quelques personnes qui comme moi ont cherches longtemps ce code sans le trouver.
si certains ont des commentaires ou des ameliorations, qu'ils me le disent, ce serat avec plaisir.
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.