Calculateur d'expressions mathematiques n°2

Commenter

Contenu du snippet

Pour calculer des équation du type "6V(9*9)+45(2+7²)" ...

Source / Exemple : 


PPublic Function Calcule(TheCalcul As String) As Double
    Dim NewCalcul As String, ThePos As Long, Parenthese As String, CParenthese As String, NegPos As Long, Pi As Double, i As Long, NextC As Double, AjoutSp As String
    
    NewCalcul = ("0+" & TheCalcul & "+0"): NewCalcul = UCase(NewCalcul): NewCalcul = Replace(NewCalcul, " ", "")    'Initialise le calcule
    NewCalcul = Replace(NewCalcul, ",", "."): NewCalcul = Replace(NewCalcul, "PI(", "PI*("): NewCalcul = Replace(NewCalcul, ")PI", ")*PI"): NewCalcul = Replace(NewCalcul, ")(", ")*(")
    NewCalcul = Replace(NewCalcul, ")V", ")*V"): NewCalcul = Replace(NewCalcul, "PIV", "PI*V"): Pi = 4 * Atn(1)
    For i = 0 To 9
      NewCalcul = Replace(NewCalcul, i & "(", i & "*("): NewCalcul = Replace(NewCalcul, i & "V", i & "*V"): NewCalcul = Replace(NewCalcul, i & "PI", i & "*PI")
    Next i
    NewCalcul = Replace(NewCalcul, "PI", Pi): NewCalcul = Replace(NewCalcul, ",", ".")    'Remplace les virgules par des points pour la validité de la fonction "Val"
    
    While InStrRev(1, NewCalcul, "(") <> Len(NewCalcul)    'Calcule les parenthèses
      ThePos = Len(NewCalcul) - InStrRev(1, NewCalcul, "(")    'Renvoie la position de départ de la parenthèse
      Parenthese = Mid(NewCalcul, ThePos, InStr(ThePos, NewCalcul, ")") - ThePos + 1)    'Renvoie l'ensemble de la parenthèse
      CParenthese = Calcule(Mid(Parenthese, 2, Len(Parenthese) - 2))    'Calcule l'intérieur de la parenthèse
      NewCalcul = Mid(NewCalcul, 1, ThePos - 1) & CParenthese & Mid(NewCalcul, ThePos + Len(Parenthese), Len(NewCalcul) - (ThePos + Len(Parenthese)) + 1)    'Rassemble les morceaux du calcul
      NewCalcul = Replace(NewCalcul, ",", ".")    'Remplace les virgules par des points pour la validité de la fonction "Val"
    Wend
    
    While InStr(1, NewCalcul, "²") <> 0    'Calcule les carrés
      ThePos = InStr(1, NewCalcul, "²")    'Renvoie la position du "carré"
      If Mid(NewCalcul, Len(NewCalcul) - GetSeparator(Len(NewCalcul) - ThePos + 1, NewCalcul) - 2, 3) = "0+-" Then AjoutSp = "-"
      NewCalcul = Mid(NewCalcul, 1, Len(NewCalcul) - GetSeparator(Len(NewCalcul) - ThePos + 1, NewCalcul)) & AjoutSp & ValSp(Val(Mid(NewCalcul, 1 + Len(NewCalcul) - GetSeparator(Len(NewCalcul) - ThePos + 1, NewCalcul), ThePos - (Len(NewCalcul) - GetSeparator(Len(NewCalcul) - ThePos + 1, NewCalcul)) - 1))) ^ 2 & Mid(NewCalcul, ThePos + (GetSeparator(ThePos + 1, NewCalcul, 2) - ThePos))  'Calcul le carré et rassemble les morceaux du calcule
      NewCalcul = Replace(NewCalcul, ",", ".")    'Remplace les virgules par des points pour la validité de la fonction "Val"
    Wend

    While InStr(1, NewCalcul, "°") <> 0    'Calcule les exposants
      ThePos = InStr(1, NewCalcul, "°")    'Renvoie la position de l'exposant
      NewCalcul = Mid(NewCalcul, 1, Len(NewCalcul) - GetSeparator(Len(NewCalcul) - ThePos + 1, NewCalcul)) & (ValSp(Val(Mid(NewCalcul, 1 + Len(NewCalcul) - GetSeparator(Len(NewCalcul) - ThePos + 1, NewCalcul), ThePos - (Len(NewCalcul) - GetSeparator(Len(NewCalcul) - ThePos + 1, NewCalcul)) - 1))) ^ ValSp(Val(Mid(NewCalcul, ThePos + 1, GetSeparator(ThePos + 1, NewCalcul, 3) - ThePos - 1)))) & Mid(NewCalcul, ThePos + (GetSeparator(ThePos + 1, NewCalcul, 3) - ThePos))  'Calcul l'exposant et rassemble les morceaux du calcule
      NewCalcul = Replace(NewCalcul, ",", ".")    'Remplace les virgules par des points pour la validité de la fonction "Val"
    Wend

    While InStr(1, NewCalcul, "V") <> 0    'Calcule les racines carrés
      ThePos = InStr(1, NewCalcul, "V")    'Renvoie la position de la racine carré
      NewCalcul = Mid(NewCalcul, 1, Len(NewCalcul) - GetSeparator(Len(NewCalcul) - ThePos + 1, NewCalcul)) & Sqr(ValSp(Val(Mid(NewCalcul, ThePos + 1, GetSeparator(ThePos + 1, NewCalcul, 2) - ThePos - 1)))) & Mid(NewCalcul, ThePos + (GetSeparator(ThePos + 1, NewCalcul, 2) - ThePos))  'Calcul la racine carré et rassemble les morceaux du calcule
      NewCalcul = Replace(NewCalcul, ",", ".")    'Remplace les virgules par des points pour la validité de la fonction "Val"
    Wend

    While InStr(1, NewCalcul, "/") <> 0    'Calcule les divisions
      ThePos = InStr(1, NewCalcul, "/")    'Renvoie la position de la division
      NewCalcul = Mid(NewCalcul, 1, Len(NewCalcul) - GetSeparator(Len(NewCalcul) - ThePos + 1, NewCalcul)) & (ValSp(Val(Mid(NewCalcul, 1 + Len(NewCalcul) - GetSeparator(Len(NewCalcul) - ThePos + 1, NewCalcul), ThePos - (Len(NewCalcul) - GetSeparator(Len(NewCalcul) - ThePos + 1, NewCalcul)) - 1))) / ValSp(Val(Mid(NewCalcul, ThePos + 1, GetSeparator(ThePos + 1, NewCalcul, 3) - ThePos - 1)))) & Mid(NewCalcul, ThePos + (GetSeparator(ThePos + 1, NewCalcul, 3) - ThePos))  'Calcul la division et rassemble les morceaux du calcule
      NewCalcul = Replace(NewCalcul, ",", ".")    'Remplace les virgules par des points pour la validité de la fonction "Val"
    Wend
      
    While InStr(1, NewCalcul, "*") <> 0    'Calcule les multiplications
      ThePos = InStr(1, NewCalcul, "*")    'Renvoie la position de la multiplication
      NewCalcul = Mid(NewCalcul, 1, Len(NewCalcul) - GetSeparator(Len(NewCalcul) - ThePos + 1, NewCalcul)) & (ValSp(Val(Mid(NewCalcul, 1 + Len(NewCalcul) - GetSeparator(Len(NewCalcul) - ThePos + 1, NewCalcul), ThePos - (Len(NewCalcul) - GetSeparator(Len(NewCalcul) - ThePos + 1, NewCalcul)) - 1))) * ValSp(Val(Mid(NewCalcul, ThePos + 1, GetSeparator(ThePos + 1, NewCalcul, 3) - ThePos - 1)))) & Mid(NewCalcul, ThePos + (GetSeparator(ThePos + 1, NewCalcul, 3) - ThePos))  'Calcul la multiplication et rassemble les morceaux du calcule
      NewCalcul = Replace(NewCalcul, ",", ".")    'Remplace les virgules par des points pour la validité de la fonction "Val"
    Wend

    NextC = ValSp(Val(Mid(NewCalcul, 1, GetSeparator(1, NewCalcul, 2)))): NewCalcul = Replace(NewCalcul, "+-", "-"): NewCalcul = Replace(NewCalcul, "--", "+"): NewCalcul = Replace(NewCalcul, "++", "+")    'Additionne le tout
    For i = 1 To Len(NewCalcul)
      If Mid(NewCalcul, i, 1) = "+" Then    'Pour les additions
        NextC = NextC + ValSp(Val(Mid(NewCalcul, i + 1, Len(NewCalcul) - GetSeparator(i, NewCalcul, 2))))
      ElseIf Mid(NewCalcul, i, 1) = "-" Then    'Pour les soustractions
        NextC = NextC - ValSp(Val(Mid(NewCalcul, i + 1, Len(NewCalcul) - GetSeparator(i, NewCalcul, 2))))
      End If
    Next i
    NewCalcul = NextC
    Calcule = ValSp(Val(Replace(NewCalcul, ",", ".")))
End Function

Public Function GetSeparator(Start As Long, TheString As String, Optional Mode = 1) As Long   'Trouve les séparateurs de droite ou de gauche
    Dim VAdd As Long, VDiv As Long, VMul As Long, VRac As Long, VSou As Long
    On Error Resume Next
    If Mode = 1 Then
      VAdd = InStrRev(Start, TheString, "+")
      VDiv = InStrRev(Start, TheString, "/")
      VMul = InStrRev(Start, TheString, "*")
      VRac = InStrRev(Start, TheString, "V")
      VSou = InStrRev(Start, TheString, "-")
    ElseIf Mode > 1 Then
      VAdd = InStr(Start, TheString, "+")
      VDiv = InStr(Start, TheString, "/")
      VMul = InStr(Start, TheString, "*")
      VRac = InStr(Start, TheString, "V")
      VSou = InStr(Start, TheString, "-")
    End If
    
    If VAdd = 0 Then VAdd = Len(TheString) + 1
    If VDiv = 0 Then VDiv = Len(TheString) + 1
    If VMul = 0 Then VMul = Len(TheString) + 1
    If VRac = 0 Then VRac = Len(TheString) + 1
    
    If Mode = 3 Then
      If VSou - Start = 0 Or VSou = 0 Then VSou = Len(TheString) + 1
    Else
      If VSou = 0 Then VSou = Len(TheString) + 1
    End If

    If VAdd < VDiv And VAdd < VMul And VAdd < VRac And VAdd < VSou Then
      GetSeparator = VAdd
    ElseIf VDiv < VAdd And VDiv < VMul And VDiv < VRac And VDiv < VSou Then
      GetSeparator = VDiv
    ElseIf VRac < VAdd And VRac < VMul And VRac < VDiv And VRac < VSou Then
      GetSeparator = VRac
    ElseIf VSou < VAdd And VSou < VMul And VSou < VDiv And VSou < VRac Then
      GetSeparator = VSou
    Else
      GetSeparator = VMul
    End If
End Function

Private Function InStrRev(Start As Long, String1 As String, String2 As String) As Long   'La fonction InStr, mais de droite à gauche
    InStrRev = Len(String1)
    For i = 1 To Len(String1) - Start
      If Mid(String1, Len(String1) - Start - i + 1, Len(String2)) = String2 Then InStrRev = Start + i - 1: Exit Function
    Next i
End Function

Function ValSp(Nombre As String)
  ValSp = Format(Nombre, "0.0000000000000000000000000000000")
End Function

Private Function Replace(ByVal TheString As String, ByVal StringSearch As String, ByVal NewString As String) As String    'Remplace les caractères d'une chaine par une autre
    Dim RstString As String
    Replace = TheString
    If Len(StringSearch) <> 0 Or Len(TheString) <> 0 Then
      While InStr(TheString, StringSearch)
        If Len(RstString) > 0 Then
          If Len(StringSearch) > 1 Then
            If InStr(TheString, StringSearch) = 1 Then RstString = RstString & NewString Else RstString = RstString & Left(TheString, (InStr(TheString, StringSearch)) - 1) & NewString
          Else
            RstString = RstString & Left(TheString, (InStr(TheString, StringSearch)) - 1) & NewString
          End If
        Else
          RstString = Left(TheString, (InStr(TheString, StringSearch)) - 1) & NewString
        End If
        If Len(StringSearch) > 1 Then TheString = Right(TheString, Len(TheString) - (InStr(TheString, StringSearch)) - (Len(StringSearch) - 1)) Else TheString = Right(TheString, Len(TheString) - (InStr(TheString, StringSearch)))
      Wend
      If Len(TheString) > 0 Then RstString = RstString & TheString
      Replace = RstString
    End If
End Function

Conclusion :


N'hésitez pas pour les commentaires ...

A voir également

S'inscrire maintenant

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.

Du même auteur (cs_Warning)