Versions : 97 et supérieures
Cette application exemple met en oeuvre :
- Utilisation de graphiques type courbe
- Utilisation de graphiques type histogramme
- Evaluation d'expressions mathématiques à l'aide de Eval
Le principe est simple : l'utilisateur entre une fonction avec une variable u. Puis il saisit des bornes d'étude ainsi qu'un intervalle et le programme boucle sur chaque valeur comprise entre les deux bornes avec un pas égal à l'intervalle saisi. Les valeurs sont au fur et à mesure ajoutées à une table. Enfin, la table est affectée à un graphique via la propriété RowSource. De plus, il est possible de passer d'un graphique de type histogramme à une courbe en changeant la propriété Type de l'objet graphique.
Type=3 --> Histogramme
Type=4 --> Courbe
Voici le code qui lance le traitement :
On Error GoTo err
Dim i As Integer, j As Integer
Dim correct As Boolean
Dim Min As Single, Max As Single, inter As Single
Dim F(4) As String
correct = True
If typeGraph <> Continu And typeGraph <> discret Then _
typeGraph = Continu
For i = 1 To 4
If Nz(Me.Controls("Fonction" & i), "") <> "" And _
(Nz(Me.Controls("Fonction" & i), "") <> _
DFirst("Expression", "FonctionTous")) Then
correct = correct And _
Testfun(Me.Controls("Fonction" & i), 1.1)
F(i - 1) = Me.Controls("Fonction" & i)
Else
j = j + 1
End If
Next i
If j = 4 Then
MsgBox ("Saisir au moins une fonction !")
Else
If Not correct Then
MsgBox ("Fonctions mal définies !")
Else
If TestMinMax(Nz(Me.Min, ""), Nz(Me.Max, ""), _
Nz(Me.Intervalle, "")) Then
Min = Val(Replace(Me.Min, ",", "."))
Max = Val(Replace(Me.Max, ",", "."))
inter = Val(Replace(Me.Intervalle, ",", "."))
If typeGraph = discret Then
Min = Int(Min)
Max = Int(Max)
inter = Int(inter)
If inter = 0 Then inter = 1
End If
MajValeurs F(0), F(1), F(2), F(3), Min, Max, inter
RefreshGraph F(0), F(1), F(2), F(3), Me
Me!ListeValeurs.Requery
Me!Graph.Type = typeGraph
Else
MsgBox ("Définition des valeurs des x incorrecte !")
End If
End If
End If
Exit Sub
err:
MsgBox "Une erreur est survenue : " & _
vbCrLf & vbCrLf & err.Description, vbCritical, "Erreur"
End Sub
Private Function TestMinMax(Min As String, _
Max As String, inter As String) As Boolean
Dim T(3) As Single
If Min <> "" And Max <> "" And inter <> "" Then
T(0) = Val(Replace(Min, ",", "."))
T(1) = Val(Replace(Max, ",", "."))
T(2) = Val(Replace(inter, ",", "."))
If T(0) < T(1) And T(1) - T(2) >= T(0) And T(2) <> 0 _
Then TestMinMax = True
End If
End Function
Public Sub MajValeurs(f1 As String, f2 As String, f3 As String, _
f4 As String, Min As Single, Max As Single, Interval As Single)
On Error Resume Next
Dim RecL As dao.Recordset
Dim x As Double
DoCmd.Hourglass True
CurrentDb.Execute "Delete * from valeurs"
Set RecL = CurrentDb.OpenRecordset("Valeurs", dbOpenDynaset)
x = Min
Do While x <= Max
RecL.AddNew
RecL!x = x
If (f1 <> "") Then RecL!f1 = Evaluer(f1, x)
If (f2 <> "") Then RecL!f2 = Evaluer(f2, x)
If (f3 <> "") Then RecL!f3 = Evaluer(f3, x)
If (f4 <> "") Then RecL!f4 = Evaluer(f4, x)
RecL.Update
x = x + Interval
If (Abs(x - 0) < 0.0001) Then x = 0
Loop
DoCmd.Hourglass False
End Sub
Public Sub RefreshGraph(f1 As String, f2 As String, _
f3 As String, f4 As String, Formulaire As Form)
Dim SQL1 As String
SQL1 = "SELECT [x] "
If (f1 <> "") Then SQL1 = SQL1 & ",[f1] "
If (f2 <> "") Then SQL1 = SQL1 & ",[f2] "
If (f3 <> "") Then SQL1 = SQL1 & ",[f3] "
If (f4 <> "") Then SQL1 = SQL1 & ",[f4] "
SQL1 = SQL1 & " FROM [Valeurs] ;"
Formulaire!Graph.RowSource = SQL1
Formulaire!Graph.Requery
End Sub
Public Function Evaluer(f As String, Valeur As Double) As Double
Dim fnc As String
fnc = ReplaceT(f, "u", "(u)")
Evaluer = Eval(ReplaceT(fnc, "u", Str(Valeur)))
End Function
Pour tester qu'une fonction est bien saisie, il suffit de l'évaluer avec une valeur. C'est ce que fait cette fonction :
Public Function Testfun(f As String, Valeur As Double) As Boolean
On Error GoTo err
Dim y As Double
f = ReplaceT(f, "u", "(u)")
y = Eval(ReplaceT(f, "u", Str(Valeur)))
Testfun = True
err:
End Function
Notons que depuis la version Access 2000, il est possible de remplacer la fonction ReplaceT par la fonction VBA Replace
N'hésitez pas à télecharger le fichier zip pour visualiser le résultat.
|