الترقيم التلقائي - اعادة الضبط

[محمد قاسم 12]

السلام عليكم

فى المرفق حقل للترقيم التلقائي فى جميع الجداول

ارجوا اعادة الترقيم من رقم 1 

حاولت كثبرا ولم انجح

جربت امثلة من المنتدي ولم انجح

mr.rar

[د.كاف يار]

انشئ Module  جديد و الصق فيه الشفرة التالية

Public Function ReNumber()
On Error Resume Next
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim tdf As DAO.TableDef
    Dim x As Integer
    Dim sSQL As String

    Set db = CurrentDb

    For Each tdf In db.TableDefs
        If Not (tdf.Name Like "MSys*" Or tdf.Name Like "~*" Or tdf.Name Like "exl*") Then
                sSQL = "ALTER TABLE [" & tdf.Name & "] Add [ID_New] Number"
                db.Execute sSQL
                Set rs = CurrentDb.OpenRecordset(tdf.Name)
    
            If Not rs.BOF And Not rs.EOF Then
                rs.MoveFirst
                While (Not rs.EOF)
                x = x + 1
                rs.Edit
                 rs.Fields("ID_New") = x
                 rs.Update
                    rs.MoveNext
                Wend
            End If
            rs.Close
            Set rs = Nothing

        End If
        x = 0
    Next
MsgBox "تم اضافة ترقيم لجميع الجداول بنجاح", vbInformation + vbMsgBoxRight, "تأكيد"
End Function

 

و في النموذج ازرار اعادة ترقيم ضع الأمر التالي

Call ReNumber

 

[abouelhassan]

استاذى الحبيب الغالى لقلبى د.كاف يار

طبقت كل المكتوب بالضبط ولا يتم ارجاع الترقيم التلقائى

بارك الله فيك وبك ولك اللهم امين

احترامى

ترقيم تلقائى كود.accdb

[طلب اكسس]

40 دقائق مضت, د.كاف يار said:

انشئ Module  جديد و الصق فيه الشفرة التالية

Public Function ReNumber()
On Error Resume Next
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim tdf As DAO.TableDef
    Dim x As Integer
    Dim sSQL As String

    Set db = CurrentDb

    For Each tdf In db.TableDefs
        If Not (tdf.Name Like "MSys*" Or tdf.Name Like "~*" Or tdf.Name Like "exl*") Then
                sSQL = "ALTER TABLE [" & tdf.Name & "] Add [ID_New] Number"
                db.Execute sSQL
                Set rs = CurrentDb.OpenRecordset(tdf.Name)
    
            If Not rs.BOF And Not rs.EOF Then
                rs.MoveFirst
                While (Not rs.EOF)
                x = x + 1
                rs.Edit
                 rs.Fields("ID_New") = x
                 rs.Update
                    rs.MoveNext
                Wend
            End If
            rs.Close
            Set rs = Nothing

        End If
        x = 0
    Next
MsgBox "تم اضافة ترقيم لجميع الجداول بنجاح", vbInformation + vbMsgBoxRight, "تأكيد"
End Function

 

و في النموذج ازرار اعادة ترقيم ضع الأمر التالي

Call ReNumber

 

هذا اضافة عمود جديد مرقم لجميع الجداول

ممتازة جدا عيني

[طارق عبد الرازق]

 د.كاف يار 

مشكور وجزاك الله خير

رائع ودائماً بنتعلم منك 

[محمد قاسم 12]

بارك الله فيكم معلمنا الفاضل

بالفعل ينشئ id جديد

ولكن المطلوب هو تصحيح ترقيم الترقيم التلقائي فى الجداول و ليس انشاء جديد

 

[Eng.Qassim]

السلام عليكم

معلومة..

في حالة حذف السجل الاخير وحتى لايعبر الترقيم الرقم الاخير .. نقوم بعمل ضغط واصلاح للقاعدة

[محمد قاسم 12]

هل من حل

[د.كاف يار]

تفضل هذا التعديل 

***** لكن قبل البدء يجب ان يكون اسم المفتاح الاساسي هو "ID" قي كل جدول

Sub indexDelet()
Public Function ReNumber()
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim tdf As DAO.TableDef
    Dim idx As ADOX.Index
    Dim x As Integer
    Dim sSQL As String, S As String

    Set db = CurrentDb

    For Each tdf In db.TableDefs
        If Not (tdf.Name Like "MSys*" Or tdf.Name Like "~*" Or tdf.Name Like "exl*") Then
                sSQL = "ALTER TABLE [" & tdf.Name & "] ALTER COLUMN [id] LONG"
                db.Execute sSQL
                Set rs = CurrentDb.OpenRecordset(tdf.Name)
    
            If Not rs.BOF And Not rs.EOF Then
                rs.MoveFirst
                While (Not rs.EOF)
                x = x + 1
                rs.Edit
                 rs.Fields("id") = x
                 rs.Update
                    rs.MoveNext
                Wend
            End If
            rs.Close
            Set rs = Nothing

        End If
        x = 0
    Next
MsgBox "تم اعادة الترقيم بنجاح", vbInformation + vbMsgBoxRight, "تأكيد"

End Function

و في ازرار اعادة الترقيم ضع التالي

Call ReNumber

 

[محمد قاسم 12]

هل يمكن تطبيقها على الملف المرفق لو سمحت

[د.كاف يار]

تفضل التعديل

ملاحظة 

اعادة الترقيم سوف تسبب لك مشكلة كبيرة في الجداول الفرعة

لذا يجب عليك عمل نسخة احتياطية قبل البدء

و يجب ان تعلم انك ستفقد ارتباط الجداول الأخرى بالجدول الرئيسي لأن مفتاح السجل الرئيسي سيتم تغييره و لن يتعرف على البيانات الخاصة به في الجداول الأخرى

تفضل التعديل

 

 

 

 

mr.zip

تم تعديل سبتمبر 9, 2021 بواسطه د.كاف يار

[محمد قاسم 12]

بارك اتلله فيكم

والف شكر لكم

[abouelhassan]

شكروتقدير واحترام من اخيك استاذى د.كاف يار