(15/11/2025, 12:30)atoykan yazdı: Kodu aşağıdaki gibi revize ederek deneyim. Kayıt eklenmeden yeni kod üretimi, multiuser erişiminde race hatası gibi gerekçelerle aynı kod üretimini engellemeye yönelik denetim eklenmiş halidir. Tablolarınızda ilgili kod alanını da unique/benzersiz olarak ayarlarsanız ErrHandlerdaki duplicate key kontrolü daha sağlıklı çalışır.
Private Sub Onay13_Click()
Dim koduret As Long
Dim yenikod As String
Dim mevcutkod As Variant
Dim atamayacalis As Long
Dim kodkontrol As Boolean
Dim rs As DAO.Recordset
On Error GoTo ErrHandler
If Me.Onay13 = True Then
Randomize
Kontrol:
atamayacalis = atamayacalis + 1
If atamayacalis > 2000 Then
MsgBox "Benzersiz kod üretilemedi. Lütfen tekrar deneyin.", vbExclamation, "....KOD HATASI...."
Exit Sub
End If
koduret = Int((999999 - 100000 + 1) * Rnd + 100000)
yenikod = "TDX-" & koduret
'_#____Tablo ve Formlarda kayıt kontrolü
'_1__ Tablo2 kontrol
mevcutkod = Dlookup ("kodu", "Tablo2", "kodu = """ & yenikod & """")
'_2__Altform içindeki kayıtlarla kontrol
kodkontrol = False
Set rs = Me.RecordsetClone
If rs.RecordCount > 0 Then
rs.MoveFirst
Do While Not rs.EOF
If Nz(rs!kodu, "") = yenikod Then
kodkontrol = True
Exit Do
End If
rs.MoveNext
Loop
End If
rs.Close
Set rs = Nothing
'_3__Eğer tabloya veya formdaki kayıtlara denk geliyorsa tekrar üret
If Not IsNull(mevcutkod) Or kodkontrol Then
GoTo Kontrol
End If
'_4__Kayıt yoksa atamayı yap ve hemen kaydet
Me.kodu = yenikod
If Me.Dirty Then Me.Dirty = False
Exit Sub
Else
'_5___tik kaldırıldıysa kodu sil
Me.kodu = Null
End If
Exit Sub
ErrHandler:
If Err.Number = 3022 Then 'tabloda ilgili alanı unique/benzersiz ayarlarsanız aynı kodda duplicate key hatası verir
Err.Clear
Resume Kontrol
Else
MsgBox "Hata (" & Err.Number & "): " & Err.Description, vbCritical
End If
End Sub
tşkler hocam elinize sağlık yaptım şu an bi sorun görünmüyor.
