Private Sub NOTE_AfterUpdate()
Dim DB As Database, DB1 As Database
Dim T As Recordset, abfrage As QueryDef
Dim d As Recordset, D1 As Recordset
Dim Anzahl As Integer
Dim sqlalt As String, sqlneu As String, laenge As Integer
Dim ref_nr As Long, pos
On Error GoTo Fehler
Set DB1 = DBEngine(0)(0)
Set DB = DBEngine.Workspaces(0).OpenDatabase(g_Dname())
Set abfrage = DB1.QueryDefs("AB_Beurteilung")
sqlalt = abfrage.sql
laenge = Len(sqlalt)
pos = InStr(1, sqlalt, "P")
sqlneu = Left$(sqlalt, pos - 1) + REF + Right$(sqlalt, laenge - pos)
abfrage.sql = sqlneu
Set d = abfrage.OpenRecordset(dbOpenDynaset)
abfrage.sql = sqlalt
abfrage.Close
Set abfrage = DB1.CreateQueryDef("Zählen")
abfrage.sql = "SELECT COUNT(NR) AS ZAHL FROM beurteilung WHERE beurteilung.ref =" & REF
Set D1 = abfrage.OpenRecordset(dbOpenDynaset)
Anzahl = D1.zahl
abfrage.Close
DB1.QueryDefs.Delete "Zählen"
D1.Close
d.MoveLast
If Anzahl <= 3 And d![NOTE] = NOTE Then
MsgBox "Sie haben die gleiche Note noch einmal eingegeben!" & Chr(13) & Chr(10) & "Bitte einen Augenblick warten." & Chr(13) & Chr(10) & "Der Datensatz wird gelöscht."
DoCmd.Requery
d.Close
ref_nr = Abfrage_Beurteilung()
Set T = DB.OpenRecordset("beurteilung", dbOpenTable)
T.Index = "PrimaryKey"
T.Seek "=", ref_nr
T.Delete
T.Close
DoCmd.Requery
DoCmd.GoToRecord , , A_NEWREC
ElseIf Anzahl = 3 And d![NOTE] <> NOTE Then
MsgBox "Mit dieser Neueingabe wird der älteste" & Chr(13) & Chr(10) & "Datensatz gelöscht." & Chr(13) & Chr(10) & "Bitte einen Augenblick warten."
d.MoveFirst
d.Delete
DoCmd.Requery
DoCmd.GoToRecord , , A_NEWREC
End If
DB.Close
Fehler:
Exit Sub
End Sub
Ah ich hatte den Code Button im IE nicht im Firefox ging es :)
|