ناقل

شاهدت في المنتدى برنامج حماية شبيه لما طلبت اعتقد للاستاذ @Barna بهذه الصورة ..... ابحث عنه في المنتدى .... ,انا ابحث عنه اذا وجدته ادرجه هنا لك ...

ممكن كده Public Function GetPeriod(dt As Date) As String If Hour(dt) < 12 Then GetPeriod = "الصباح" Else GetPeriod = "المساء" End If End Function

جرب هذه الدالة IIf(Hour([chekin]) < 12, "الصباح", "المساء") لم اجربها ...

استخدم التنسيق الشرطي .... افضل .... انظر

طيب جرب هذا الكود بدل الموجود تحت الزر عندك .... On Error GoTo ErrorHandler Dim db As DAO.Database Dim rsEmp As DAO.Recordset Dim rsHol As DAO.Recordset Dim strSQL As String Dim intCount As Integer Dim blnExists As Boolean ' التحقق من وجود تاريخ في مربع النص If IsNull(Me.Controls("نص11").Value) Or Me.Controls("نص11").Value = "" Then MsgBox "الرجاء إدخال تاريخ في مربع النص نص11", vbExclamation, "تاريخ مفقود" Exit Sub End If ' التحقق من أن القيمة تاريخ صحيح If Not IsDate(Me.Controls("نص11").Value) Then MsgBox "القيمة في مربع النص ليست تاريخاً صحيحاً", vbExclamation, "تاريخ غير صالح" Exit Sub End If Me.Recalc ' فتح اتصال بقاعدة البيانات Set db = CurrentDb() ' إنشاء سجل مجموعة لجدول الموظفين (emp) حيث att = "غياب" strSQL = " SELECT emp.[no], emp.Att " & _ " FROM emp " & _ " WHERE (((emp.Att)="" غياب""));" Set rsEmp = db.OpenRecordset(strSQL) ' التحقق من وجود سجلات If rsEmp.EOF And rsEmp.BOF Then MsgBox "لا توجد سجلات غياب في جدول الموظفين", vbInformation, "لا توجد بيانات" GoTo CleanUp End If ' فتح جدول hol للكتابة Set rsHol = db.OpenRecordset("hol") ' بدء عملية الإدراج intCount = 0 Do Until rsEmp.EOF ' التحقق من عدم وجود سجل مكرر blnExists = DCount("[no]", "[hol]", "[absdate] =#" & [Forms]![تسجيل الحضور والغياب]![نص11] & "# And [no] =" & rsEmp!no & " ") If Not blnExists Then On Error Resume Next ' لتجنب أخطاء الإدراج rsHol.AddNew rsHol!no.Value = rsEmp!no.Value rsHol!absDate.Value = [Forms]![تسجيل الحضور والغياب]![نص11] rsHol.Update If Err.Number = 0 Then intCount = intCount + 1 Else MsgBox "خطأ في إدراج سجل للموظف رقم " & rsEmp!no & ": " & Err.Description, vbExclamation Err.Clear End If On Error GoTo ErrorHandler Else MsgBox "تم تجاهل الموظف رقم " & rsEmp!no & " لأنه مسجل غياب بالفعل في هذا التاريخ", vbExclamation, "سجل مكرر" End If rsEmp.MoveNext Loop MsgBox "تم إدراج " & intCount & " سجل غياب بنجاح", vbInformation, "تمت العملية" CleanUp: On Error Resume Next If Not rsEmp Is Nothing Then rsEmp.Close Set rsEmp = Nothing End If If Not rsHol Is Nothing Then rsHol.Close Set rsHol = Nothing End If Set db = Nothing Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description & " (السطر: " & Erl & ")", vbCritical, "خطأ" Resume CleanUp

تفضل ملفك ..... NA_1.accdb الرسالة تظهر عند الضغط على اضافة

غير الشيفرة الموجودة تحث حدث الزر الى .... Me.Recalc If DLookup("[absdate]", "[hol]", "[absdate] =#" & [Forms]![تسجيل الحضور والغياب]![نص11] & "#") Then MsgBox "تم تسجيل غياب هذا اليوم" Else DoCmd.SetWarnings False DoCmd.RunSQL "INSERT INTO hol ( [no], absdate ) " & _ " SELECT emp.[no], [forms]![تسجيل الحضور والغياب]![نص11] AS Expr1 " & _ " FROM emp " & _ " WHERE (((emp.Att)="" غياب""));" DoCmd.RunSQL "UPDATE emp SET emp.Att = """";" DoCmd.SetWarnings True End If

اضفت حقل صغير في جدول الموظفين...... جرب الملف NA_1.accdb

الف مبروك اخي الكريم .... مزيدا من التألق

الف مبروك اخي الكريم .... مزيدا من التألق

يعني انت تريد تسجيل غياب الموظفين جميعا .... ثم الضغط علة اضافة يتم ادراج تاريخ الغياب كل الموظفين الغائبين فقط تريد هذا "" ؟؟؟؟

هذه النتيجة وصلت لها ولكن يبقى السؤال لما تم تجاوز هذه الفواتير ؟؟

ايش الخلل .... وبدون مبالغة على مدى يومين وابا ابحث عن ثغرة ... لم اجد ... ممكن شرح الخلل اين؟؟؟

معليش هذه مافهمتها ... ممكن شرح لها

ممكن تستخدم الحذف من خلال كود مباشر لاي ID كتاب محذوف يتم حذف الصفحات المقابلة له في الجدول الابن وبدون استخدام التكامل المرجعي

نعم من لوازم التكامل المرجعي ان يكون للسجل المضاف في جدول الابن سجل مرتبط في جدول الاب

هناك طريقة تحايل ولكني لست متأكد من جدواها .... 1- اعمل نسخة احتياطية من القاعدة لديك 2- امسح بيانات الجداول ( bookX - bookX2 - TAB_takhrij_X ) 3- انشأ العلاقات التي تريدها 4- انسخ بيانات الجداول من النسخة الاحتياطية الى الجداول الثلاث 5- جرب واعلمنا بالنتيجة شاهد البتيجة

ليس لدي جهاز ولكن لماذا لا يتم الربط بالحقل ID_BOOK

اخي الفاضل انا لم اتسرع ولم احكم عليك .... ولكني حكمت على نفسي باني لست خبير ... وفعلا انا تلميذ لكم اخي الفاضل ... المقامات محفوظة

وعليكم السلام ورحمة الله وبركاته اشارك برأي من باب المشاركة ولست خبيرا ,,,,, لأنك انت من طلب من غير الخبراء المشاركة 😃 عن تعديل الكود اعتقد يجب النظر في كل المتغيرات والدوال مثلا هناك دوال تحتاج الى تعديل للعمل في بيئة 64 bit مثل ::::::::::::::: 1. FindWindow 2. GetWindowLong / SetWindowLong 3. GetTickCount 4. ShellExecute 5. Sleep 6. GetSystemMetrics 7. GetCursorPos 8. OpenProcess 9. CreateFile والله اعلم

هذا برنامج اخر يقوم بنفس الوظيفة تقريبا ......................

بالنسبة للقواعد التي لم تعمل معك ...... من خصائص الملف فعل كما في الصورة

جرب هذا ....

اعمل بحث في المنتدى تجد ما يسرك

تم تعديل الملف ::::::::::::: عدلنا الحقل CorrectionCommittee في الجدول Teachers الى تاريخ/وقت عدلنا الكود تحت الزر بهذا الشكل ........ Dim db As DAO.Database Dim rsA As DAO.Recordset, rsB As DAO.Recordset Dim rsRooms As DAO.Recordset, rsDays As DAO.Recordset, rsTarget As DAO.Recordset Dim supervisionDate As Date, roomName As String Dim teacherAssignedA As Boolean, teacherAssignedB As Boolean Dim dayKey As String Dim safeName As String Dim teacherName As String On Error GoTo ErrorHandler Set db = CurrentDb() ' 1. التهيئة: مسح الجدول وتصفير العدادات db.Execute "UPDATE Teachers SET SupervisionCount = 0" db.Execute "DELETE FROM TeacherAssignment" ' 2. التحقق من توفر عدد كافٍ من المعلمين Dim totalSupervisionsNeeded As Long Dim availableA As Long, availableB As Long Dim daysCount As Long, roomsCount As Long daysCount = DCount("*", "SupervisionDays") roomsCount = DCount("*", "ExamRooms") totalSupervisionsNeeded = daysCount * roomsCount ' معلم A ومعلم B لكل قاعة ' حساب المعلمين المتاحين مع مراعاة جميع شروط الاستثناء ' (هنا نستخدم شرط التحقق من تاريخ المراقبة فقط) availableA = DCount("*", "Teachers", "TeacherCategory = 'A' " & _ "AND (ExamDate Is Null OR ExamDate Not In (SELECT SupervisionDate FROM SupervisionDays))") availableB = DCount("*", "Teachers", "TeacherCategory = 'B' " & _ "AND (ExamDate Is Null OR ExamDate Not In (SELECT SupervisionDate FROM SupervisionDays))") If availableA < totalSupervisionsNeeded Or availableB < totalSupervisionsNeeded Then Dim response As VbMsgBoxResult response = MsgBox("تحذير: عدد المعلمين غير كافي!" & vbCrLf & _ "المطلوب: " & totalSupervisionsNeeded & " معلم A و " & totalSupervisionsNeeded & " معلم B" & vbCrLf & _ "المتاح: " & availableA & " معلم A و " & availableB & " معلم B" & vbCrLf & _ "هل تريد المتابعة مع وضع 'غير مغطاة' للقاعات غير المكتملة؟", _ vbYesNo + vbExclamation, "تنبيه") If response = vbNo Then MsgBox "تم إلغاء التوزيع بناءً على طلبك.", vbInformation Exit Sub End If End If ' 3. بدء عملية التوزيع Set rsDays = db.OpenRecordset("SELECT * FROM SupervisionDays ORDER BY SupervisionDate", dbOpenDynaset) Set rsRooms = db.OpenRecordset("SELECT * FROM ExamRooms ORDER BY RoomName", dbOpenDynaset) Set rsTarget = db.OpenRecordset("TeacherAssignment") ' إنشاء قاموس لتتبع المعلمين في كل يوم على حدة Dim dailyTeachers As Object Set dailyTeachers = CreateObject("Scripting.Dictionary") ' حلقة على كل الأيام Do While Not rsDays.EOF supervisionDate = rsDays!supervisionDate ' تهيئة القاموس لهذا اليوم فقط (ليسمح بالتكرار في الأيام الأخرى) dailyTeachers.RemoveAll ' حلقة على كل القاعات rsRooms.MoveFirst Do While Not rsRooms.EOF roomName = rsRooms!roomName teacherAssignedA = False teacherAssignedB = False ' تعيين معلم فئة A Set rsA = db.OpenRecordset("SELECT * FROM Teachers WHERE TeacherCategory='A' " & _ "AND (ExamDate Is Null OR ExamDate <> #" & Format(supervisionDate, "mm/dd/yyyy") & "#) " & _ "AND (CorrectionCommittee Is Null OR CorrectionCommittee <> #" & Format(supervisionDate, "mm/dd/yyyy") & "#) " & _ "ORDER BY SupervisionCount ASC", dbOpenDynaset) If Not rsA.EOF Then rsA.MoveFirst Do Until rsA.EOF Or teacherAssignedA teacherName = rsA![teacherName] If Not dailyTeachers.Exists(teacherName) Then ' تعيين المعلم A rsTarget.AddNew rsTarget!teacherName = teacherName rsTarget!TeacherCategory = "A" rsTarget!ExamRoom = roomName rsTarget!supervisionDate = supervisionDate rsTarget.Update ' تحديث العداد safeName = Replace(teacherName, "'", "''") db.Execute "UPDATE Teachers SET SupervisionCount = SupervisionCount + 1 WHERE [TeacherName] = '" & safeName & "'" ' إضافة المعلم للقاموس اليومي فقط dailyTeachers.Add teacherName, 1 teacherAssignedA = True End If rsA.MoveNext Loop End If rsA.Close ' إذا لم يتم تعيين معلم A، تسجيل "غير مغطاة" If Not teacherAssignedA Then rsTarget.AddNew rsTarget!teacherName = "غير مغطاة" rsTarget!TeacherCategory = "A" rsTarget!ExamRoom = roomName rsTarget!supervisionDate = supervisionDate rsTarget.Update End If ' تعيين معلم فئة B Set rsB = db.OpenRecordset("SELECT * FROM Teachers WHERE TeacherCategory='B' " & _ "AND (ExamDate Is Null OR ExamDate <> #" & Format(supervisionDate, "mm/dd/yyyy") & "#) " & _ "AND (CorrectionCommittee Is Null OR CorrectionCommittee <> #" & Format(supervisionDate, "mm/dd/yyyy") & "#) " & _ "ORDER BY SupervisionCount ASC", dbOpenDynaset) If Not rsB.EOF Then rsB.MoveFirst Do Until rsB.EOF Or teacherAssignedB teacherName = rsB![teacherName] If Not dailyTeachers.Exists(teacherName) Then ' تعيين المعلم B rsTarget.AddNew rsTarget!teacherName = teacherName rsTarget!TeacherCategory = "B" rsTarget!ExamRoom = roomName rsTarget!supervisionDate = supervisionDate rsTarget.Update ' تحديث العداد safeName = Replace(teacherName, "'", "''") db.Execute "UPDATE Teachers SET SupervisionCount = SupervisionCount + 1 WHERE [TeacherName] = '" & safeName & "'" ' إضافة المعلم للقاموس اليومي فقط dailyTeachers.Add teacherName, 1 teacherAssignedB = True End If rsB.MoveNext Loop End If rsB.Close ' إذا لم يتم تعيين معلم B، تسجيل "غير مغطاة" If Not teacherAssignedB Then rsTarget.AddNew rsTarget!teacherName = "غير مغطاة" rsTarget!TeacherCategory = "B" rsTarget!ExamRoom = roomName rsTarget!supervisionDate = supervisionDate rsTarget.Update End If rsRooms.MoveNext Loop rsDays.MoveNext Loop ' 4. التنظيف وإغلاق الموارد rsTarget.Close rsRooms.Close rsDays.Close Set rsTarget = Nothing Set rsRooms = Nothing Set rsDays = Nothing Set rsA = Nothing Set rsB = Nothing Set db = Nothing Set dailyTeachers = Nothing MsgBox "تم الانتهاء من التوزيع بنجاح!" & vbCrLf & _ "تم تعيين معلم A ومعلم B لكل قاعة" & vbCrLf & _ "مع مراعاة الشروط التالية:" & vbCrLf & _ "- عدم تكرار المعلم في نفس اليوم" & vbCrLf & _ "- السماح بتكرار المعلم في أيام مختلفة" & vbCrLf & _ "- استثناء المعلمين الذين لديهم اختبار في نفس اليوم" & vbCrLf & _ "- استثناء المعلمين الموجودين في لجنة تصحيح لنفس تاريخ المراقبة فقط" & vbCrLf & _ "- العدالة في التوزيع حسب عدد المراقبات السابقة", _ vbInformation, "إنجاز" Exit Sub ErrorHandler: MsgBox "حدث خطأ أثناء التنفيذ: " & vbCrLf & _ "رقم الخطأ: " & Err.Number & vbCrLf & _ "الوصف: " & Err.Description & vbCrLf & _ "في الإجراء: " & Erl, vbCritical, "خطأ" Resume Next تقضل المرفق ....................... ‏‏NA_3.accdb