Bonsoir byacces2,
Je regarderai cette histoire de Dlookup, mais en attendant...
J’ai refait du VBA, ça faisait un moment ! Je me suis livré à l’exercice suivant (dans le style que j'utilisais il y a 20 ans) :
Création du formulaire F_Fabrications, dans lequel l’utilisateur fournit un nom de composant et une date de référence, à partir de laquelle on cherchera par requête SQL la date de fabrication inférieure ou égale, ainsi que le lot correspondant. Cette recherche est déclenchée quand on clique sur le bouton « GO ».
Après avoir fait GO, il y a affichage des valeurs correspondantes dans les champs IDFabrication, DateFabrication, Lot et il y a insertion d’une ligne dans la table T_Fabrications.
Les champs du formulaire sont ainsi nommés :
Composant
DateReference
IDFabrication
DateFabrication
Lot
Et le bouton : GO.
Structure des tables que j’utilise :
TLC_Composants {N° autonumber, Composant short text}
T_Lots {IDLot autonumber, Composant number, Lot short text, DateDebutUtilisation date}
T_Fabrications {IDFabrication autonumber, DateFabrication date, Composant number, Lot short text}
Code VBA (évidemment améliorable, je n’ai pas fait dans la dentelle !) :
Private Sub Composant_GotFocus()
Me.IDFabrication = ""
Me.DateFabrication = ""
Me.Lot = ""
End Sub
Private Sub GO_Click()
Dim r As String, theComposant As String
Dim theDateReference As String, theDateFabrication As String, MaxIdFabrication As Integer
Dim Sqlresult As DAO.Recordset
Dim insert As String
Dim theDataBase As DAO.Database
Dim Style As Integer
Dim Insulte As String
Dim Titre As String, Reponse As String
Dim theKount As Integer, theComposantNo As Integer
On Error Resume Next
Set theDataBase = CurrentDb
'-------------------------------------------------------------------------
' Contrôle du composant
'-------------------------------------------------------------------------
theComposant = Composant.Value
theKount = 0
If Len(theComposant) > 0 Then
r = "SELECT COUNT(*) AS Kount FROM TLC_Composants WHERE Composant = '" & theComposant & "' ;"
Set Sqlresult = theDataBase.OpenRecordset(r, dbOpenDynaset)
If Err.Number <> 0 Then
Style = vbCritical
Insulte = r & Chr(13) & Chr(13) & "Erreur " & Err.Number & ". " & Err.Description & Chr(13) & Chr(13) & " Prévenir qui de droit..."
Titre = "Formulaire " & Me.Name
Reponse = MsgBox(Insulte, Style, Titre)
theDataBase.Close: Set theDataBase = Nothing
Exit Sub
End If
theKount = Sqlresult.Fields("Kount").Value
End If
If theKount = 0 Then
Style = vbExclamation
Insulte = "Le champ Composant doit contenir un composant existant ! "
Titre = "Formulaire " & Me.Name
Reponse = MsgBox(Insulte, Style, Titre)
Composant.SetFocus
Exit Sub
End If
r = "SELECT N° AS ComposantNo FROM TLC_Composants WHERE Composant = '" & theComposant & "' ;"
Set Sqlresult = theDataBase.OpenRecordset(r, dbOpenDynaset)
If Err.Number <> 0 Then
Style = vbCritical
Insulte = r & Chr(13) & Chr(13) & "Erreur " & Err.Number & ". " & Err.Description & Chr(13) & Chr(13) & " Prévenir qui de droit..."
Titre = "Formulaire " & Me.Name
Reponse = MsgBox(Insulte, Style, Titre)
theDataBase.Close: Set theDataBase = Nothing
Exit Sub
End If
theComposantNo = Sqlresult.Fields("ComposantNo").Value
r = "SELECT COUNT(*) AS Kount FROM T_LOTS WHERE Composant = " & theComposantNo & " ; "
Set Sqlresult = theDataBase.OpenRecordset(r, dbOpenDynaset)
If Err.Number <> 0 Then
Style = vbCritical
Insulte = r & Chr(13) & Chr(13) & "Erreur " & Err.Number & ". " & Err.Description & Chr(13) & Chr(13) & " Prévenir qui de droit..."
Titre = "Formulaire " & Me.Name
Reponse = MsgBox(Insulte, Style, Titre)
theDataBase.Close: Set theDataBase = Nothing
Exit Sub
End If
theKount = Sqlresult.Fields("Kount").Value
If theKount = 0 Then
Style = vbExclamation
Insulte = "Le composant n'est référencé dans la table des lots ! "
Titre = "Formulaire " & Me.Name
Reponse = MsgBox(Insulte, Style, Titre)
Composant.SetFocus
Exit Sub
End If
'-------------------------------------------------------------------------
' Contrôle de la date de référence
'-------------------------------------------------------------------------
theDateReference = DateReference.Value
If Not IsDate(theDateReference) Then
Style = vbExclamation
Insulte = "Le champ date de référence doit contenir une date ! "
Titre = "Formulaire " & Me.Name
Reponse = MsgBox(Insulte, Style, Titre)
DateReference.SetFocus
Exit Sub
End If
'--------------------------------------------------------------------------------------------------------------------
' Insert d'une ligne dans la table T_Fabrications
'--------------------------------------------------------------------------------------------------------------------
insert = "insert into T_Fabrications (DateFabrication, Lot, Composant) " _
& "SELECT Max(x.DateDebutUtilisation), Max(x.lot), " & theComposantNo & " " _
& "FROM T_Lots AS x INNER JOIN TLC_Composants AS y ON x.Composant = y.N° " _
& "WHERE y.Composant = '" & theComposant & "'" _
& " AND x.DateDebutUtilisation <= CDate('" & theDateReference & "')" _
& " GROUP BY x.Composant ; "
theDataBase.Execute insert
If Err.Number <> 0 Then
Style = vbCritical
Insulte = r & Chr(13) & Chr(13) & "Erreur " & Err.Number & ". " & Err.Description & Chr(13) & Chr(13) & " Prévenir qui de droit.."
Titre = "Formulaire " & Me.Name
Reponse = MsgBox(Insulte, Style, Titre)
theDataBase.Close: Set theDataBase = Nothing
Exit Sub
End If
'--------------------------------------------------------------------------------------------------------------------
' Détermination de la dernière ligne insérée dans la table T_Fabrications
'--------------------------------------------------------------------------------------------------------------------
r = "SELECT MAX(IdFabrication) AS Maxfab FROM T_Fabrications ; "
Set Sqlresult = theDataBase.OpenRecordset(r, dbOpenDynaset)
If Err.Number <> 0 Then
Style = vbCritical
Insulte = r & Chr(13) & Chr(13) & "Erreur " & Err.Number & ". " & Err.Description & Chr(13) & Chr(13) & " Prévenir qui de droit..."
Titre = "Formulaire " & Me.Name
Reponse = MsgBox(Insulte, Style, Titre)
theDataBase.Close: Set theDataBase = Nothing
Exit Sub
End If
MaxIdFabrication = Sqlresult.Fields("Maxfab").Value
Me.IDFabrication = MaxIdFabrication
'--------------------------------------------------------------------------------------------------------------------
' Détermination de la date de fabrication pour la dernière ligne insérée dans la table T_Fabrications
'--------------------------------------------------------------------------------------------------------------------
r = "SELECT DateFabrication FROM T_Fabrications WHERE IDFabrication = " & Me.IDFabrication & " ; "
Set Sqlresult = theDataBase.OpenRecordset(r, dbOpenDynaset)
If Err.Number <> 0 Then
Style = vbCritical
Insulte = r & Chr(13) & Chr(13) & "Erreur " & Err.Number & ". " & Err.Description & Chr(13) & Chr(13) & " Prévenir qui de droit..."
Titre = "Formulaire " & Me.Name
Reponse = MsgBox(Insulte, Style, Titre)
theDataBase.Close: Set theDataBase = Nothing
Exit Sub
End If
Me.DateFabrication = Sqlresult.Fields("DateFabrication").Value
'--------------------------------------------------------------------------------------------------------------------
' Détermination du lot de la dernière ligne insérée dans la table T_Fabrications
'--------------------------------------------------------------------------------------------------------------------
r = "SELECT Lot FROM T_Fabrications WHERE IdFabrication = " & MaxIdFabrication & " ;"
Set Sqlresult = theDataBase.OpenRecordset(r, dbOpenDynaset)
If Err.Number <> 0 Then
Style = vbCritical
Insulte = r & Chr(13) & Chr(13) & "Erreur " & Err.Number & ". " & Err.Description & Chr(13) & Chr(13) & " Prévenir qui de droit..."
Titre = "Formulaire " & Me.Name
Reponse = MsgBox(Insulte, Style, Titre)
theDataBase.Close: Set theDataBase = Nothing
Exit Sub
End If
Me.Lot = Sqlresult.Fields("Lot").Value
End Sub
Répondre avec citation
Envoyé par byacces2
c'est toujours apprécié...
.png)
.png)
).
) peut avoir 6 attitudes:
Partager