Private Sub btn_balyala_Click()
If Me.btn_balyala.Caption = "Balyala" Then
GSorguKontrol = Nz(DCount("*", "MSysObjects", "[Name] = 'srg_balyalanacakkayitlar'"), 0)
If GSorguKontrol <> 0 Then
DoCmd.DeleteObject acQuery, "srg_balyalanacakkayitlar"
End If
Set SrgYp = CurrentDb.CreateQueryDef("srg_balyalanacakkayitlar", "SELECT TOP " & Me.mtn_balyasayisi & " Evrak_No, [Reçete Sayısı], tarandı, [Kutu Adedi], [Balya No], Grubu FROM Eczacılık WHERE (((tarandı) Is Null) And ((Grubu) = '" & Me.acl_grubu & "')) ORDER BY Rnd(Int(Now()*[Evrak_No])-Now()*[Evrak_No])")
GBalyaSon = Mid(mtn_balyasayisi, Len(mtn_balyasayisi), Len(mtn_balyasayisi))
If GBalyaSon = "2" Or GBalyaSon = "7" Then
GGek = "şerli"
ElseIf GBalyaSon = "6" Then
GGek = "şarlı"
ElseIf GBalyaSon = "9" Or GBalyaSon = "0" Then
GGek = "arlı"
Else
GGek = "erli"
End If
Dim db As Database
Dim rst As Recordset
Set db = CurrentDb()
Set rst = db.OpenRecordset("srg_balyalanacakkayitlar")
rst.MoveLast
Me.mtn_kontrol = rst.RecordCount
If MsgBox(Me.acl_grubu & " Grubuna Ait Reçetelerin " & Me.mtn_balyasayisi & "'" & GGek & " balyalanmasını istiyor musunuz", vbYesNo) = vbYes Then
If Nz(DMax("[Balya No]", "Yapılan_Balyalar"), 0) = 0 Then
BalyaNo = InputBox("A Gurubu başlangıçtaki balya numarasını giriniz...")
Else
BalyaNo = DMax("[Balya No]", "Yapılan_Balyalar") + 1
End If
Me.mtn_balyano = "Balya No: " & BalyaNo
Me.TimerInterval = 100
End If
Me.btn_balyala.Caption = "Durdur"
ElseIf Me.btn_balyala.Caption = "Durdur" Then
Me.TimerInterval = 0
Me.btn_balyala.Caption = "Balyala"
Exit Sub
End If
End SubFormun zaman dolduğunda olayındaki kodlar;
Private Sub Form_Timer()
100
Dim db As Database
Dim rst As Recordset
Set db = CurrentDb()
Set rst = db.OpenRecordset("srg_balyalanacakkayitlar")
rst.MoveLast
Me.mtn_kontrol = rst.RecordCount
mtn_balyasayisi.Requery
If Val(Me.mtn_kontrol) < Val(Me.mtn_balyasayisi) Then
MsgBox (mtn_kontrol & "-" & mtn_balyasayisi)
MsgBox " Balyalama işlemi sona erdi. Tabloda balya yapılmamış gurup varsa eczane sayısını artırarak yeniden deneyebilirsiniz."
Me.TimerInterval = 0
Exit Sub
ElseIf Val(Me.mtn_kontrol) > Val(Me.mtn_balyasayisi) Then
GoTo 100
End If
rst.MoveFirst
Do While Not rst.EOF
GToplam = GToplam + rst![Reçete Sayısı]
GEvrakNo = GEvrakNo & "," & rst![Evrak_No]
rst.MoveNext
Loop
Me.mtn_kayittoplam = GToplam
Me.mtn_evraknumaralari = Mid(GEvrakNo, 2, Len(GEvrakNo))
Me.Metin40 = Dsum ("[Kutu Adedi]", "srg_balyalanacakkayitlar")
For xx = 1 To 10
A = 148 * xx
B = 153 * xx
If GToplam > A And GToplam < B Then
If Dsum ("[Kutu Adedi]", "srg_balyalanacakkayitlar") < 10 Then
MsgBox (DSum("[Kutu Adedi]", "srg_balyalanacakkayitlar"))
For z = 1 To 10
Controls("Metin" & z).BackColor = vbWhite
Next z
Controls("Metin" & xx).BackColor = vbYellow
DoCmd.SetWarnings False
DoCmd.RunSQL "UPDATE Eczacılık SET tarandı = '1', [Balya No] = " & BalyaNo & " WHERE (((Evrak_No) In (" & Me.mtn_evraknumaralari & ")))"
DoCmd.SetWarnings True
Me.mtn_balyalanmayan = "Balyalanmayan Evrak Sayısı : " & DCount("*", "Eczacılık", "[Grubu]= '" & Me.acl_grubu & "' And [Balya No] Is Null")
BalyaNo = BalyaNo + 1
mtn_sayim = 1
Me.mtn_balyano = "Balya No: " & BalyaNo
Exit For
Exit Sub
End If
End If
Next xx
Me.mtn_sayim = Nz(Me.mtn_sayim, 0) + 1
If Me.mtn_sayim > 5000 Then
MsgBox ("Balyanacak uygun reçete bulunamadı")
Me.TimerInterval = 0
Exit Sub
End If
rst.Close
End Sub