Soyez le premier à donner votre avis sur cette source.
Vue 6 634 fois - Téléchargée 333 fois
'/-------------------------------------------------\ '| | '| TITRE : Analyseur d'expression arithmétique | '| | '| Expression supposrtées : | '| Opérateurs de base : +,-,*,/,^ | '| Parenthèses : () | '| Fonctions : SIN,ABS,SQR | '| | '| BUGS connus de l'auteur : | '| 2*-5 donne -5 (*)Corrigé par mr_saturne | '| | '| Caractéristique du code : | '| Facilement extensible | '\-------------------------------------------------/ Function evaluer(calc As String) Dim fact() As String Dim oper() As String Dim fpos As Integer Dim n As String Dim ffin As Integer ReDim fact(1) As String ReDim oper(1) As String Dim test_neg As Integer '******************************************** '**IMPLEMENTATION DES FONCTIONS SPECIFIQUES** '******************************************** 'Cosinus Do Until InStr(calc, "cos") = 0 fpos = InStr(calc, "cos") n = "" If fpos > 0 Then For ix = fpos + 3 To Len(calc) If IsNumeric(Mid(calc, ix, 1)) Or Mid(calc, ix, 1) = "." Then n = n + Mid(calc, ix, 1) Else Exit For Next ix calc = Replace(calc, "cos" + LTrim(str(n)), LTrim(str(Cos(n * 3.1415 / 180)))) End If Loop 'Sinus Do Until InStr(calc, "sin") = 0 fpos = InStr(calc, "sin") n = "" If fpos > 0 Then For ix = fpos + 3 To Len(calc) If IsNumeric(Mid(calc, ix, 1)) Or Mid(calc, ix, 1) = "." Then n = n + Mid(calc, ix, 1) Else Exit For Next ix calc = Replace(calc, "sin" + LTrim(str(n)), LTrim(str(Sin(n * 3.1415 / 180)))) End If Loop 'Racine carée Do Until InStr(calc, "sqr") = 0 fpos = InStr(calc, "sqr") n = "" If fpos > 0 Then For ix = fpos + 3 To Len(calc) If IsNumeric(Mid(calc, ix, 1)) Or Mid(calc, ix, 1) = "." Then n = n + Mid(calc, ix, 1) Else Exit For Next ix calc = Replace(calc, "sqr" + LTrim(str(n)), LTrim(str(Sqr(n)))) End If Loop 'Valeure absolue Do Until InStr(calc, "abs") = 0 fpos = InStr(calc, "abs") n = "" If fpos > 0 Then For ix = fpos + 3 To Len(calc) If IsNumeric(Mid(calc, ix, 1)) Or Mid(calc, ix, 1) = "." Or Mid(calc, ix, 1) = "-" Then n = n + Mid(calc, ix, 1) Else Exit For Next ix calc = Replace(calc, "abs" + LTrim(str(n)), LTrim(str(Abs(n)))) End If Loop '******************************************** '**RECHERCHE DES FACTEURS ET DES OPERATEURS** '******************************************** For ix = 1 To Len(calc) ' debut de boucle Select Case Mid(calc, ix, 1) ' recherche des operateurs Case "^": ' exponenciation ReDim Preserve fact(UBound(fact()) + 1) As String ' Ajouter un indice dans les facteurs oper(UBound(oper)) = "^" ' Ajouter l'operateur à la liste ReDim Preserve oper(UBound(oper()) + 1) As String ' Ajouter un indice dans les opérateurs Case "*": ' multiplication ReDim Preserve fact(UBound(fact()) + 1) As String oper(UBound(oper)) = "*" ReDim Preserve oper(UBound(oper()) + 1) As String Case "/": ' division ReDim Preserve fact(UBound(fact()) + 1) As String oper(UBound(oper)) = "/" ReDim Preserve oper(UBound(oper()) + 1) As String Case "+": ' addition ReDim Preserve fact(UBound(fact()) + 1) As String oper(UBound(oper)) = "+" ReDim Preserve oper(UBound(oper()) + 1) As String Case "-": ' soustraction ReDim Preserve fact(UBound(fact()) + 1) As String oper(UBound(oper)) = "-" ReDim Preserve oper(UBound(oper()) + 1) As String Case Else: ' autres cas fact(UBound(fact)) = fact(UBound(fact)) + Mid(calc, ix, 1) ' ajouter le bout de chaine au dernier indice de fact End Select Next 'Remplace les chiffres négatifs rech: ix = 1 test_neg = 0 While ix < UBound(fact) 'parcours tous les facteurs If fact(ix) = "" And oper(ix) = "-" Then 'négatif trouvé fact(ix) = (-1) * fact(ix + 1) 'on remplace le vide par le facteur suivant en négatif For iy = ix To UBound(oper) - 1 oper(iy) = oper(iy + 1) 'on décale le tableau des opérateurs Next iy For iy = ix To UBound(fact) - 2 fact(iy + 1) = fact(iy + 2) 'on décale le tableau des facteurs Next iy fact(UBound(fact)) = "" 'on supprime le facteur obsolette test_neg = 1 End If ix = ix + 1 'on passe au suivant Wend If test_neg = 1 Then GoTo rech 'si un négatif a été trouvé on refait un passage 'Ajout des facteurs et des opérateurs dans les listes pour le deboguage List1.Clear List2.Clear For ix = 1 To UBound(fact) List1.AddItem (fact(ix)) Next ix For ix = 1 To UBound(oper) List2.AddItem (oper(ix)) Next ix '************************** '**CALCUL DE L'EXPRESSION** '************************** 'EXPONENTIELLE For ix = 1 To UBound(fact) ' Parcourir tous les facteurs If oper(ix) = "^" Then ' Si on trouve oper(ix)="^" fact(ix) = LTrim(str(Val(fact(ix)) ^ Val(fact(ix + 1)))) ' Calculer le nouveau facteur For iy = ix To UBound(oper) - 1 oper(iy) = oper(iy + 1) ' > Enlever un operateur et décaller le tableau Next iy For iy = ix To UBound(fact) - 2 fact(iy + 1) = fact(iy + 2) ' > Enlever un facteur et décaller le tableau Next iy fact(UBound(fact)) = "" ' Effacer le facteur obsolette End If Next ix 'MULTIPLICATION For ix = 1 To UBound(fact) If oper(ix) = "*" Then fact(ix) = LTrim(str(Val(fact(ix)) * Val(fact(ix + 1)))) For iy = ix To UBound(oper) - 1 oper(iy) = oper(iy + 1) Next iy For iy = ix To UBound(fact) - 2 fact(iy + 1) = fact(iy + 2) Next iy fact(UBound(fact)) = "" End If Next ix 'DIVISION For ix = 1 To UBound(fact) If oper(ix) = "/" Then fact(ix) = LTrim(str(Val(fact(ix)) / Val(fact(ix + 1)))) For iy = ix To UBound(oper) - 1 oper(iy) = oper(iy + 1) Next iy For iy = ix To UBound(fact) - 2 fact(iy + 1) = fact(iy + 2) Next iy fact(UBound(fact)) = "" End If Next ix 'ADDITION For ix = 1 To UBound(fact) If oper(ix) = "+" Then fact(ix) = LTrim(str(Val(fact(ix)) + Val(fact(ix + 1)))) For iy = ix To UBound(oper) - 1 oper(iy) = oper(iy + 1) Next iy For iy = ix To UBound(fact) - 2 fact(iy + 1) = fact(iy + 2) Next iy fact(UBound(fact)) = "" End If Next ix 'SOUSTRACTION For ix = 1 To UBound(fact) If oper(ix) = "-" Then fact(ix) = LTrim(str(Val(fact(ix)) - Val(fact(ix + 1)))) For iy = ix To UBound(oper) - 1 oper(iy) = oper(iy + 1) Next iy For iy = ix To UBound(fact) - 2 fact(iy + 1) = fact(iy + 2) Next iy fact(UBound(fact)) = "" End If Next ix For ix = 1 To UBound(fact) evaluer = evaluer + fact(ix) + oper(ix) ' Construction de la nouvelle expression. Next End Function Rem !!! Veuillez mentionner mon nom si vous comptez l'utiliser dans votre programme !!! Option Base 1 ' premier indice du tableau = 1 Sub calculer_Click() ' Au clicque sur le bouton 'MsgBox parenthese(calcul.Text) ' pour deboguage Do Until parenthese(calcul.Text) = "aucune" ' fair j'usqu'à ce que la fonction retourne "aucune" If parenthese(calcul.Text) = "error" Then MsgBox "ERREUR : parenthèse manquante ou mal placée " + Chr(10) + " le programme a tenté de retrouver l'erreur" + Chr(10) + " veuillez suprimer les parenthèses inutiles et appuyer sur calculer", vbCritical, "!!! ERREUR utilisateur !!!": Exit Sub ' si la fonction retourne une erreur calcul = Replace(calcul, "(" + parenthese(calcul.Text) + ")", evaluer(parenthese(calcul.Text))) ' Simplifier le calcul au operateur de base (plus de () ) Loop ' fin de boucle calcul = evaluer(calcul) ' evaluer l'expression simplifiée End Sub Function parenthese(calc As String) Dim pospo, pospf As String Rem rechecherche de la première parenthèse fermente pospf = InStr(1, calcul.Text, ")") If pospf <> 0 Then pospo = InStrRev(calcul.Text, "(", pospf) If pospo = 0 Then GoTo err1 parenthese = Mid(calcul.Text, pospo + 1, pospf - pospo - 1) Else parenthese = "aucune" End If Exit Function err1: parenthese = "error" End Function
Il semble qu'il ait corrigé ce bug.
Je pense qu'il y a un bug dans la résolution. Vérifie les 2 dernières lignes des opérations. 2+160027/4 = 2+40006.75 et non pas 40558.25. J'ai un autre programme qui donne le même résultat pour ce problème et lui aussi oubli d'additionner le 2. Lorsque je fait évaluer la dernière séquence la réponse est 40008.75 et si je résoud l'ensemble on retrouve 40558.25. Il y a un gros bug dans les 2 programmes ou c'est moi qui ne comprend rien.
Je le met pas là car ca va être illisible mais si ca t'interesse (ou qqun d'autre) demandes le moi par mail : mr_saturne@hotmail.com
Bravo pour ton travail en tous cas, ca m'a bien servit ;-)
Par contre, CQUI789 donne une piste ;-) C'est à toi de voir.
(Recherche aussi : Coloration Syntaxique)
@+
par contre, est ce que le bug a été réglé avec le temps? ou y a t-il eu une seconde version?
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.