Calcul d'apres un textbox

Soyez le premier à donner votre avis sur cette source.

Vue 5 039 fois - Téléchargée 445 fois

Description

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.

Codes Sources

A voir également

Ajouter un commentaire Commentaires
lololilizozo
Messages postés
28
Date d'inscription
jeudi 2 octobre 2008
Statut
Membre
Dernière intervention
2 octobre 2012

24 févr. 2011 à 21:46
mais de rien jouliana :-)
cs_jouliana
Messages postés
2
Date d'inscription
mercredi 23 février 2011
Statut
Membre
Dernière intervention
24 février 2011

24 févr. 2011 à 19:20
bon pogramme merci
lololilizozo
Messages postés
28
Date d'inscription
jeudi 2 octobre 2008
Statut
Membre
Dernière intervention
2 octobre 2012

2 août 2010 à 17:00
salut vicosta,
deja c'est une bonne nouvelle si mon code fait les bons calculs :-)
par contre tu peux enlever les "(0-...)" puisque maintenant mon code gere les "-" en tant que signe et pas seulement en operateur.
si j'ai pu aider quelqu'un avec mon code, je suis content.
a+
vicosta
Messages postés
178
Date d'inscription
lundi 5 juin 2006
Statut
Membre
Dernière intervention
30 novembre 2011

2 août 2010 à 11:11
j'ai vu une calculette sur lorisoft.org qui fait exactement le même travail. j'a testé la ligne
(0-5)((0-8)^5*sin(cos(5+8))-((0-45)-9)56/((0-8)+4*8))sin(0-4)*(0-78)
et le resultat est identique (em mode radians), donc ton code fonctionne bien au départ. Bonne continuation
BarthOlivier
Messages postés
132
Date d'inscription
mercredi 6 mars 2002
Statut
Membre
Dernière intervention
27 novembre 2012
1
1 août 2010 à 02:33
J'ai testé un peu et porté le code en C# c'est assez rapide, et résultats cohérents (pour les différents tests que j'ai faits)
Commentaires suffisamment détaillés ni trop peu, ni pas assez.
J'adopte.
Afficher les 16 commentaires

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.