[ تمت الإجابة ] هل يوجد حل نهائي للترقيم التلقائي على الشبكات

ها هو كود الأستاذ الفاضل accssesna

ولكن وجدت به بعض العيوب فمثلا هذا الكود يقبل فواتير ليس بها بيانات وهذا ليس منطقي

يمكن لفاتورتين أن تكونا برقم واحد عند فتح البرنامج لأول مرة

Private Sub Form_Open(Cancel As Integer)

DoCmd.RunCommand acCmdAppMinimize

DoCmd.GoToRecord , , acLast

End Sub

Private Sub Command1_Click()

On Error Resume Next

Err.Clear

Me.Refresh

If Err.Number <> 0 Then

MsgBox Err.Description, , Err.Number

End If

End Sub

Private Sub Command2_Click()

Const Duplicate = 3022

Dim MaxRec As Long

Dim Msg As String

On Error Resume Next

If Me.Dirty Then

Msg = "ÝÊÍ ÝÇÊæÑÉ ÌÏíÏÉ Ïæä ÍÝÙ ÇáÊÚÏíáÇÊ !!¿"

If vbCancel = MsgBox(Msg, vbOKCancel + vbDefaultButton2, "ÚÝæÇð") Then

Exit Sub

End If

End If

If Nz(DCount("[invoiceNo]", Me.AccontSub.Form.RecordSource, _

"InvoiceNo = " & Nz(Me.InvoiceNo, 0)), 0) = 0 Then

Msg = "ÝÊÍ ÝÇÊæÑÉ ÌÏíÏÉ ãÚ ÊÑß åÐå ÇáÝÇÊæÑÉ ÈÏæä ÓÌáÇÊ !!¿"

If vbCancel = MsgBox(Msg, vbOKCancel + vbDefaultButton2, "ÚÝæÇð") Then

Exit Sub

End If

End If

MaxRec = Nz(DMax("[invoiceNo]", "Account"), 0) + 1

Me.AllowAdditions = True

DoCmd.GoToRecord , , acNewRec

Me.InvoiceNo = MaxRec

Me.Refresh

Do While Err.Number = Duplicate

Err.Clear

MaxRec = MaxRec + 1

Me.InvoiceNo = MaxRec

Me.Refresh

Loop

Me.AllowAdditions = False

Me.DoctorNo.SetFocus

End Sub

Private Sub CmdDelete_Click()

On Error GoTo Err_CmdDelete_Click

If vbOK = MsgBox("ãÊÃßÏ ãä ÍÐÝ åÐå ÇáÝÇÊæÑÉ ¿", vbOKCancel + vbDefaultButton2, "ÚÝæÇð") Then

DoCmd.DoMenuItem acFormBar, acEditMenu, 8, , acMenuVer70

DoCmd.DoMenuItem acFormBar, acEditMenu, 6, , acMenuVer70

End If

Exit_CmdDelete_Click:

Exit Sub

Err_CmdDelete_Click:

MsgBox Err.Description

Resume Exit_CmdDelete_Click

End Sub

إطلع على هذا الرابط أولاً ثم أفدنا إن وجدت ما تريد عليه أم بحاجة الى حلول أخرى !!

/index.php?showtopic=186920

الف شكر لك أخي الفاضل Karramli

مبدئيا الحل ممتاز

وسأختبر ذلك وأفيدك إن شاء الله

الله يجزاك خير

إطلع على هذا الرابط أولاً ثم أفدنا إن وجدت ما تريد عليه أم بحاجة الى حلول أخرى !!

/index.php?showtopic=118581

أستاتذتي Karramli و NawalyZuma

شكرا على تعاونكم معي

نعم وجدت ما أريد في كلا الرابطين

شكرا لكم وفقكم الله