ANALYSEUR D'EXPRESSION ALGÉBRIQUE FACILEMENT EXTENSIBLE

'/-------------------------------------------------\
'|                                                 |
'|  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