Calculer une expression mathematique

Commenter

Contenu du snippet

Permet de calculer une équation du type :
2*(V4*4²+(2*2))/8

Source / Exemple : 


Function Calcule(TheCalcul As String)
    Dim NewCalcul As String, ThePos As Long, Parenthese As String, CParenthese As String, NegPos As Long, NextPar As Long
    NewCalcul = Replace(TheCalcul, " ", "")
    NewCalcul = Replace(NewCalcul, ",", ".")
    NewCalcul = "0+" & NewCalcul & "+0"
    NewCalcul = UCase(NewCalcul)
    
    While InStrRev(1, NewCalcul, "(") <> Len(NewCalcul)    'Calcule les parenthèses
      ThePos = Len(NewCalcul) - InStrRev(1, NewCalcul, "(")
      NextPar = InStr(ThePos, NewCalcul, ")")
      Parenthese = Mid(NewCalcul, ThePos, NextPar - ThePos + 1)
      CParenthese = Calcule(Mid(Parenthese, 2, Len(Parenthese) - 2))
      NewCalcul = Mid(NewCalcul, 1, ThePos - 1) & CParenthese & Mid(NewCalcul, ThePos + Len(Parenthese), Len(NewCalcul) - (ThePos + Len(Parenthese)) + 1)
    Wend
    
    NewCalcul = Replace(NewCalcul, ",", ".")
        
    While InStr(1, NewCalcul, "²") <> 0    'Calcule les carrés
      ThePos = InStr(1, NewCalcul, "²")
      NewCalcul = Mid(NewCalcul, 1, Len(NewCalcul) - GetSeparator(Len(NewCalcul) - ThePos + 1, NewCalcul)) & 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 + (GetSeparatorRev(ThePos + 1, NewCalcul) - ThePos))
    Wend
    
    NewCalcul = Replace(NewCalcul, ",", ".")
        
    While InStr(1, NewCalcul, "V") <> 0    'Calcule les racines carrés
      ThePos = InStr(1, NewCalcul, "V")
      NewCalcul = Mid(NewCalcul, 1, Len(NewCalcul) - GetSeparator(Len(NewCalcul) - ThePos + 1, NewCalcul)) & Sqr(Val(Mid(NewCalcul, ThePos + 1, GetSeparatorRev(ThePos + 1, NewCalcul) - ThePos - 1))) & Mid(NewCalcul, ThePos + (GetSeparatorRev(ThePos + 1, NewCalcul) - ThePos))
    Wend
    
    NewCalcul = Replace(NewCalcul, ",", ".")
    
    If InStr(1, NewCalcul, "*") < InStr(1, NewCalcul, "/") Then    'Calcule les multiplications et les divisions
      While InStr(1, NewCalcul, "*") <> 0
        ThePos = InStr(1, NewCalcul, "*")
        NewCalcul = Mid(NewCalcul, 1, Len(NewCalcul) - GetSeparator(Len(NewCalcul) - ThePos + 1, NewCalcul)) & (Val(Mid(NewCalcul, 1 + Len(NewCalcul) - GetSeparator(Len(NewCalcul) - ThePos + 1, NewCalcul), ThePos - (Len(NewCalcul) - GetSeparator(Len(NewCalcul) - ThePos + 1, NewCalcul)) - 1)) * Val(Mid(NewCalcul, ThePos + 1, GetSeparatorSP(ThePos + 1, NewCalcul) - ThePos - 1))) & Mid(NewCalcul, ThePos + (GetSeparatorSP(ThePos + 1, NewCalcul) - ThePos))
      Wend
      
      NewCalcul = Replace(NewCalcul, ",", ".")
          
      While InStr(1, NewCalcul, "/") <> 0
        ThePos = InStr(1, NewCalcul, "/")
        NewCalcul = Mid(NewCalcul, 1, Len(NewCalcul) - GetSeparator(Len(NewCalcul) - ThePos + 1, NewCalcul)) & (Val(Mid(NewCalcul, 1 + Len(NewCalcul) - GetSeparator(Len(NewCalcul) - ThePos + 1, NewCalcul), ThePos - (Len(NewCalcul) - GetSeparator(Len(NewCalcul) - ThePos + 1, NewCalcul)) - 1)) / Val(Mid(NewCalcul, ThePos + 1, GetSeparatorSP(ThePos + 1, NewCalcul) - ThePos - 1))) & Mid(NewCalcul, ThePos + (GetSeparatorSP(ThePos + 1, NewCalcul) - ThePos))
      Wend
    Else
      While InStr(1, NewCalcul, "/") <> 0
        ThePos = InStr(1, NewCalcul, "/")
        NewCalcul = Mid(NewCalcul, 1, Len(NewCalcul) - GetSeparator(Len(NewCalcul) - ThePos + 1, NewCalcul)) & (Val(Mid(NewCalcul, 1 + Len(NewCalcul) - GetSeparator(Len(NewCalcul) - ThePos + 1, NewCalcul), ThePos - (Len(NewCalcul) - GetSeparator(Len(NewCalcul) - ThePos + 1, NewCalcul)) - 1)) / Val(Mid(NewCalcul, ThePos + 1, GetSeparatorSP(ThePos + 1, NewCalcul) - ThePos - 1))) & Mid(NewCalcul, ThePos + (GetSeparatorSP(ThePos + 1, NewCalcul) - ThePos))
      Wend
      
     NewCalcul = Replace(NewCalcul, ",", ".")
      
      While InStr(1, NewCalcul, "*") <> 0
        ThePos = InStr(1, NewCalcul, "*")
        NewCalcul = Mid(NewCalcul, 1, Len(NewCalcul) - GetSeparator(Len(NewCalcul) - ThePos + 1, NewCalcul)) & (Val(Mid(NewCalcul, 1 + Len(NewCalcul) - GetSeparator(Len(NewCalcul) - ThePos + 1, NewCalcul), ThePos - (Len(NewCalcul) - GetSeparator(Len(NewCalcul) - ThePos + 1, NewCalcul)) - 1)) * Val(Mid(NewCalcul, ThePos + 1, GetSeparatorSP(ThePos + 1, NewCalcul) - ThePos - 1))) & Mid(NewCalcul, ThePos + (GetSeparatorSP(ThePos + 1, NewCalcul) - ThePos))
      Wend
    End If
    
    NewCalcul = Replace(NewCalcul, ",", ".")
        
    Calcule = Addition(NewCalcul)    'Additionne le tout
End Function

Function InStrRev(Start As Long, String1 As String, String2 As String)
    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 GetSeparatorRev(Start As Long, TheString As String)
    Dim VAdd As Long, VDiv As Long, VMul As Long, VRac As Long, VSou As Long
    
    VAdd = InStr(Start, TheString, "+")
    VDiv = InStr(Start, TheString, "/")
    VMul = InStr(Start, TheString, "*")
    VRac = InStr(Start, TheString, "V")
    VSou = InStr(Start, TheString, "-")
    
    If VAdd = 0 Then
      VAdd = Len(TheString) + 1
    End If
    If VDiv = 0 Then
      VDiv = Len(TheString) + 1
    End If
    If VMul = 0 Then
      VMul = Len(TheString) + 1
    End If
    If VRac = 0 Then
      VRac = Len(TheString) + 1
    End If
    If VSou = 0 Then
      VSou = Len(TheString) + 1
    End If
    
    If VAdd < VDiv And VAdd < VMul And VAdd < VRac And VAdd < VSou Then
      GetSeparatorRev = VAdd
    ElseIf VDiv < VAdd And VDiv < VMul And VDiv < VRac And VDiv < VSou Then
      GetSeparatorRev = VDiv
    ElseIf VRac < VAdd And VRac < VMul And VRac < VDiv And VRac < VSou Then
      GetSeparatorRev = VRac
    ElseIf VSou < VAdd And VSou < VMul And VSou < VDiv And VSou < VRac Then
      GetSeparatorRev = VSou
    Else
      GetSeparatorRev = VMul
    End If
End Function
Function GetSeparatorSP(Start As Long, TheString As String)
    Dim VAdd As Long, VDiv As Long, VMul As Long, VRac As Long, VSou As Long
    
    VAdd = InStr(Start, TheString, "+")
    VDiv = InStr(Start, TheString, "/")
    VMul = InStr(Start, TheString, "*")
    VRac = InStr(Start, TheString, "V")
    VSou = InStr(Start, TheString, "-")
    
    If VAdd = 0 Then
      VAdd = Len(TheString) + 1
    End If
    If VDiv = 0 Then
      VDiv = Len(TheString) + 1
    End If
    If VMul = 0 Then
      VMul = Len(TheString) + 1
    End If
    If VRac = 0 Then
      VRac = Len(TheString) + 1
    End If
    If VSou - Start = 0 Or VSou = 0 Then
      VSou = Len(TheString) + 1
    End If
    
    If VAdd < VDiv And VAdd < VMul And VAdd < VRac And VAdd < VSou Then
      GetSeparatorSP = VAdd
    ElseIf VDiv < VAdd And VDiv < VMul And VDiv < VRac And VDiv < VSou Then
      GetSeparatorSP = VDiv
    ElseIf VRac < VAdd And VRac < VMul And VRac < VDiv And VRac < VSou Then
      GetSeparatorSP = VRac
    ElseIf VSou < VAdd And VSou < VMul And VSou < VDiv And VSou < VRac Then
      GetSeparatorSP = VSou
    Else
      GetSeparatorSP = VMul
    End If
    

End Function
Function GetSeparator(Start As Long, TheString As String)
    Dim VAdd As Long, VDiv As Long, VMul As Long, VRac As Long, VSou As Long
    
    VAdd = InStrRev(Start, TheString, "+")
    VDiv = InStrRev(Start, TheString, "/")
    VMul = InStrRev(Start, TheString, "*")
    VRac = InStrRev(Start, TheString, "V")
    VSou = InStrRev(Start, TheString, "-")
    
    If VAdd = 0 Then
      VAdd = Len(TheString) + 1
    End If
    If VDiv = 0 Then
      VDiv = Len(TheString) + 1
    End If
    If VMul = 0 Then
      VMul = Len(TheString) + 1
    End If
    If VRac = 0 Then
      VRac = Len(TheString) + 1
    End If
    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

Public Function Replace(ByVal laChaine As String, ByVal old_car As String, ByVal new_car As String) As String
    Dim ncar As Integer, lng As Integer, result As String, txt As String
    lng = Len(old_car)
    txt = laChaine
    If lng <= 0 Then
        Replace = txt
        Exit Function
    End If
    On Error GoTo ErrChangeCaractre
    
    If lng <= 0 Or Len(Trim(txt)) <= 0 Then
        Replace = txt
        Exit Function
    End If
    result = vbNullString
    ncar = InStr(txt, old_car)
    Do While ncar
        If Len(result) > 0 Then
            If lng > 1 Then
                If ncar = 1 Then
                    result = result & new_car
                Else
                    result = result & Left(txt, ncar - 1) & new_car
                End If
            Else
                result = result & Left(txt, ncar - 1) & new_car
            End If
        Else
            result = Left(txt, ncar - 1) & new_car
        End If
        If lng > 1 Then
            txt = Right(txt, Len(txt) - ncar - (lng - 1))
        Else
            txt = Right(txt, Len(txt) - ncar)
        End If
        ncar = InStr(txt, old_car)
    Loop
    If Len(txt) > 0 Then result = result & txt
    Replace = result
    Exit Function
ErrChangeCaractre:
    Replace = result
End Function

Function Addition(TheCalcule As String)
    Dim NextC, i As Long
    NextC = Val(Mid(TheCalcule, 1, GetSeparatorRev(1, TheCalcule)))
    TheCalcule = Replace(TheCalcule, "+-", "-")
    TheCalcule = Replace(TheCalcule, "--", "+")
    TheCalcule = Replace(TheCalcule, "++", "+")
    For i = 1 To Len(TheCalcule)
      If Mid(TheCalcule, i, 1) = "+" Then
        NextC = NextC + Val(Mid(TheCalcule, i + 1, Len(TheCalcule) - GetSeparatorRev(i, TheCalcule)))
      ElseIf Mid(TheCalcule, i, 1) = "-" Then
        NextC = NextC - Val(Mid(TheCalcule, i + 1, Len(TheCalcule) - GetSeparatorRev(i, TheCalcule)))
      End If
    Next i
    Addition = NextC
End Function

Conclusion :


Exemple :
Calcule("2*(V16)") 'renvoie 8

V --> Racine Carré
² --> Carré
  • --> Multiplier

/ --> Diviser
+ --> Additioner
- --> Soustraire
( --> Parenthèse

Mettez vos commentaire (il contient surement quelque bug, merci de me prevenir)...

A voir également

Du même auteur (cs_Warning)