Foksh

بناءً على رقم الخطأ 2505 ، قد يكون هناك خطأ في كود يفتح نموذج أو تقرير ضمن شروط معينة . ما لم تقم برفع ملف يحتوي المشكلة لمتابعتها بعيداً عن الإحتمالات التي قد تطول دون جدوى .

الشكر موصول للمهندس @Moosak ، هو صاحب الفكرة أخي الكريم ، ( قد اختلطت عليك الردود )

مداخلة .. بما انه عندك 3 ورديات ( صحيح ؟ ) الآن بعد ما تختار الوردية الثالثة - وبناءً على كلامك - ستواجه مشكلة وهو انه لا يوجد وردية رابعة !!!! وعليه فإنك ستعود للوردية الأولى صحيح ؟؟ اذاً يجب ان يكون هناك شروط عند فتح السجل الجديد للوردية الجديدة بأن تكون ضمن نفس تاريخ اليوم !!! ( هل هذا صحيح ؟؟ )

قمت بتثبيت نسخة أوفيس 2003 لمتابعة النتائج ، وهذه صورة للتوضيح للنتيجة :- المرفق :- Delete Records 1By1.mdb

حسناً ، جرب هذا التعديل ، كنت قد جهزته مسبقاً للإحتياط لهكذا رد . مع العلم أنني لا أملك أوفيس 2003 للأسف ، وعل أحد الأخوة ممن يملك هذا الإصدار إفادتنا بالنتيجة أيضاً .. Private Sub Command0_Click() On Error GoTo ErrorHandler Dim db As Database Dim rst As Recordset Dim fld As Field Dim sqlUpdate As String Dim tableName As String tableName = "Employee" 'اسم الجدول Set db = CurrentDb() Set rst = db.OpenRecordset(tableName) sqlUpdate = "UPDATE " & tableName & " SET " For Each fld In rst.Fields If fld.Name <> "EmployeeID" Then 'حقل المفتاح الأساسي If Not (fld.Attributes And dbAutoIncrField) Then sqlUpdate = sqlUpdate & "[" & fld.Name & "] = Null, " End If End If Next fld If Right(sqlUpdate, 2) = ", " Then sqlUpdate = Left(sqlUpdate, Len(sqlUpdate) - 2) db.Execute sqlUpdate MsgBox "تمت تصفية جميع البيانات باستثناء حقل المفتاح الأساسي", vbInformation Else MsgBox "لا توجد حقول يمكن مسح محتوياتها", vbExclamation End If ExitSub: If Not rst Is Nothing Then rst.Close Set rst = Nothing Set db = Nothing Exit Sub ErrorHandler: MsgBox "حدث خطأ", vbCritical Resume ExitSub End Sub 1. حيث ما تم تعديله هو حذف مرجعيات DAO من تعريفات الكائنات لأنها غير ضرورية في أكسس 2003 حسب علمي . 2. قمت بإضافة معالجة الأخطاء باستخدام On Error GoTo ErrorHandler . 3. قمت بحذف dbFailOnError لأنه غير ضروري مع وجود معالج الأخطاء . جرب وأخبرني بالنتيجة ,, جرب بدايةً على الحذف الكامل ، ثم ننتقل لحذف سجل محدد مع العلم ، هذا ردك على حذف سجل واحد مؤخراً

جرب هذا المرفق Delete Records.mdb

ليس لدي آكسيس 2003 ، ولكن على حد علمي ، تأكد من وجود مكتبة "Microsoft DAO 3.6 Object Library" اذا لم يعمل معك الكود ، رغم أن آكسيس 2003 يدعم DAO ( على حد علمي ، والله أعلم ) . على كل حال ، جرب الكود التالي ، ومتابع معك حتى تصل للنهاية .. Private Sub Command0_Click() Dim db As DAO.Database Dim rst As DAO.Recordset Dim fld As DAO.Field Dim sqlUpdate As String Dim tableName As String tableName = "Employee" 'اسم الجدول Set db = CurrentDb Set rst = db.OpenRecordset(tableName, dbOpenDynaset) sqlUpdate = "UPDATE " & tableName & " SET " For Each fld In rst.Fields If fld.Name <> "EmployeeID" Then 'حقل المفتاح الأساسي If (fld.Attributes And dbAutoIncrField) = 0 Then sqlUpdate = sqlUpdate & "[" & fld.Name & "] = Null, " End If End If Next fld If Right(sqlUpdate, 2) = ", " Then sqlUpdate = Left(sqlUpdate, Len(sqlUpdate) - 2) db.Execute sqlUpdate, dbFailOnError MsgBox "تمت تصفية جميع البيانات باستثناء حقل المفتاح الأساسي", vbInformation, "" Else MsgBox "لا توجد حقول يمكن مسح محتوياتها", vbExclamation, "" End If rst.Close Set rst = Nothing Set db = Nothing End Sub ملف للتطبيق :- Delete Records.accdb

المشكلة لم تظهر عندي حتى في أول مرفق لك صديقي العزيز.. عل أحد الإخوة ممن ظهرت لديه المشكلة ان يفيدك بأحد الحلول أو الإقتراحات المناسبة ..

يوجد كود لدي ، ولكنه يقوم بحذف جميع سجلات الجدول باستثناء حقل المفتاح الأساسي .. أم تريد حذف سجل محدد !!!!

في الأكواد لديك ، حاول ضبط التنسيق في المواضع التي يتم فيها اضافة التاريخ الى الحقل باستعمال الجملة :- Format(Date, "mm/dd/yyyy") كمثال في الجملة التالية :- Me.AwardMonth = Format(Date, "mm/dd/yyyy")

وعليكم السلام ورحمة الله وبركاته .. زودنا بملف بسيط على الأقل للتعرف على اسماء الحقول والجداول يا صديقي

أعتذر منك ، قد يكون لدى أحد الإخوة والأساتذة حل آخر

وعليكم السلام ورحمة الله وبركاته ،، فيما يتعلق بالمطلب الأول ، أعتقد انه يجب ضبط التنسيق للتاريخ في الدالة إن كانت هي المسؤولة عن الخلل الذي تتحدث عنها ، علماً أنني لم ألحظ الخطأ بشكل واضح . على العموم في الدالة داخل المديول جرب ضبط التنسيق للسطر بالشكل التالي :- txtDate = Format(Date, "mm/dd/yyyy") المطلب الثاني غير مفهوم بالنسبة لي ..

جرب هذا التعديل البسيط ra1 (2).accdb

تم تعديل اسلوب الدالة من المديول على النحو التالي :- Function CalculateFridaysSaturdays(monthName As String, Optional baseYear As Integer = 0, Optional dayType As String = "Both") As Variant Dim monthNumber As Integer Dim startDate As Date, endDate As Date Dim fridays As Integer, saturdays As Integer Dim targetYear As Integer monthName = Trim(monthName) Select Case monthName Case "يناير": monthNumber = 1 Case "فبراير": monthNumber = 2 Case "مارس": monthNumber = 3 Case "ابريل": monthNumber = 4 Case "مايو": monthNumber = 5 Case "يونيو": monthNumber = 6 Case "يوليو": monthNumber = 7 Case "اغسطس": monthNumber = 8 Case "سبتمبر": monthNumber = 9 Case "اكتوبر": monthNumber = 10 Case "نوفمبر": monthNumber = 11 Case "ديسمبر": monthNumber = 12 Case Else CalculateFridaysSaturdays = "اسم الشهر غير صحيح" Exit Function End Select If monthNumber >= 10 Then targetYear = year(Date) - 1 ElseIf monthNumber <= 6 Then targetYear = year(Date) Else targetYear = baseYear End If If targetYear < 1900 Or targetYear > 2100 Then CalculateFridaysSaturdays = "السنة غير صحيحة" Exit Function End If fridays = CountWeekdayOccurrences(targetYear, monthNumber, vbFriday) saturdays = CountWeekdayOccurrences(targetYear, monthNumber, vbSaturday) Select Case LCase(dayType) Case "friday": CalculateFridaysSaturdays = fridays Case "saturday": CalculateFridaysSaturdays = saturdays Case Else: CalculateFridaysSaturdays = Array(fridays, saturdays) End Select End Function Function CountWeekdayOccurrences(targetYear As Integer, monthNumber As Integer, targetWeekday As Integer) As Integer Dim startDate As Date, endDate As Date Dim firstDay As Integer, totalDays As Integer Dim count As Integer startDate = DateSerial(targetYear, monthNumber, 1) endDate = DateSerial(targetYear, monthNumber + 1, 0) firstDay = Weekday(startDate) totalDays = endDate - startDate + 1 count = ((totalDays + firstDay - targetWeekday) \ 7) + IIf((firstDay <= targetWeekday), 1, 0) CountWeekdayOccurrences = count End Function ✅ تحسين قراءة أسماء الأشهر بحيث لا تتأثر بالمسافات الزائدة . ✅ إضافة فحص للسنة لمنع القيم غير المنطقية . ✅ تحسين الأداء باستخدام دالة تقوم بالحساب المباشر . ✅ تجنب الأخطاء عند تمرير قيم غير صحيحة أو عند التعامل مع أسماء الأشهر . ✅ تحديث الاستعلام SQL بحيث يستبعد القيم غير الصالحة (NULL أو الفراغ) . 👌 النتيجة : كود أسرع وأكثر كفاءة ويعمل دون أخطاء غير متوقعة بهذه الطريقة ، لن تحتاج إلى تغيير الكود يدوياً كل سنة ، وسيتم احتساب القيم المطلوبة تلقائياً !! أما الإستعلام ، فقد تم تعديله لمحاكاة الكود السابق على النحو التالي :- UPDATE data_shr SET gm = CalculateFridaysSaturdays([shr], 0, "Friday"), sbt = CalculateFridaysSaturdays([shr], 0, "Saturday") WHERE shr IN ("يناير", "فبراير", "مارس", "ابريل", "مايو", "يونيو", "اكتوبر", "نوفمبر", "ديسمبر") AND shr IS NOT NULL AND shr <> ""; ايام الغياب 2.accdb * تم حذف الأجزاء السابقة الغير ضرورية لتلافي ظهور رسائل الأخطاء .

اعتذر عن عدم حذف النموذج ، فهو كان للتجربة فقط لا غير ، ولم آت على ذكره في حلي معتقداً اني حذفته . وكان الحل مقتصراً في ردي على فتح الاستعلام Query2 فقط !! اعتقد ان الفكرة تدور حول بداية العام الدراسي مثلاً من شهر 10 من العام الحالي الى شهر 6 من العام التالي صحيح ؟؟ على العموم، قد اتضحت الصورة الآن ، دعني أرى ما يمكنني تعديله .

ما اقصده اخي انك اخترت إجابتك كأفضل إجابة ، وليس إجابة الأستاذ @ابو عارف التي وجدت بها الحل . كل الشكر والتقدير لشخصك الكريم 🤗 وتقبل الله منكم الصيام 🤲🏻

طلبك غير واضح من البداية ، فمن وظيفة الكود ان يعطيك الأعداد المطلوبة حسب السنة الحالية ، أما خلاف ذلك فلم يتم التوجه له في طلبك . أما موضوع الخطأ فقد قمت بعمل ضغط وإصلاح أكثر من 6 مرات متتالية لقاعدة البيانات ولم يظهر الخطأ لدي ، إلا إذا كان في قاعدتك الأصلية أخطاء سابقة 😁 .

نرجو من الأخ العزيز @أحمد العيسى ، ان ينسب اختيار أفضل إجابة لصاحب الحل ، وليس لإجابة الشكر 😇 . فمن قدم لك الحل يستحق أن تمنحه أفضل إجابة .

وعليكم السلام ورحمة الله وبركاته.. تبارك الرحمن ، ما شاء الله ، جزاكم الله كل الخير ، والله يعطيك العافية 🤗

قد يكون الحقل في الجدول نصي وليس رقمي,, جرب التعديل التالي :- Private Sub txt_AfterUpdate() Dim selectedYear As Integer selectedYear = Me.txt Me.Filter = "[TOTALSHY] = 0 OR ([yearshy] <> '" & selectedYear & "' AND [TOTALSHY] <> 0)" Me.FilterOn = True End Sub

يا اهلاً ومرحباً بصاحب الأفكار الجميلة ،، عمل جميل جداً ، ولكن انت تعرفني انني أتجنب التوسعات التي قد تُربك صاحب الطلب في إجاباتي 😉 .

تستطيع الاستغناء عن هذه الأسطر شريطة ان لا يكون هناك نموذج يستدعي أو يشغل أو يستخدم جدولاً من تلك الجداول التي تريد استيرادها 🤗 .

التعديل الصحيح بنظري هو الآتي بإضافة دالة للتعامل مع "أ" أو "إ" أو "ا" أو "ه" أو "ة" :- Private Function NormalizeArabicText(text As String) As String Dim result As String result = text result = Replace(result, "أ", "ا") result = Replace(result, "إ", "ا") result = Replace(result, "آ", "ا") result = Replace(result, "ة", "ه") NormalizeArabicText = result End Function Private Function GetLastName(nameArray() As String) As String If UBound(nameArray) >= 0 Then GetLastName = nameArray(UBound(nameArray)) Else GetLastName = "" End If End Function Private Sub NameEmployee_AfterUpdate() Dim db As DAO.Database Dim rs As DAO.Recordset Dim strEmpName As String Dim arrName() As String Dim lastName As String Dim relation As String Dim empID As Integer Dim found As Boolean Dim isFemaleName As Boolean Dim i As Integer Const MIN_MATCHING_NAMES = 2 Set db = CurrentDb() strEmpName = Me.NameEmployee arrName = Split(strEmpName, " ") If UBound(arrName) >= 2 Then lastName = "" For i = 1 To UBound(arrName) If i > 1 Then lastName = lastName & " " lastName = lastName & arrName(i) Next i Else MsgBox "يجب إدخال الاسم ثلاثيًا على الأقل", vbExclamation + vbMsgBoxRight, "تنبيه" Exit Sub End If isFemaleName = (Right(NormalizeArabicText(arrName(0)), 1) = "ه") Set rs = db.OpenRecordset("SELECT IDeMP, NameEmployee FROM DatEmp WHERE IDeMP <> " & Me.IDeMP) found = False Do While Not rs.EOF Dim otherEmpName() As String Dim matchingNames As Integer otherEmpName = Split(rs!NameEmployee, " ") For i = 0 To UBound(arrName) arrName(i) = NormalizeArabicText(arrName(i)) Next i For i = 0 To UBound(otherEmpName) otherEmpName(i) = NormalizeArabicText(otherEmpName(i)) Next i If GetLastName(arrName) = GetLastName(otherEmpName) Then If UBound(otherEmpName) >= MIN_MATCHING_NAMES And UBound(arrName) >= MIN_MATCHING_NAMES + 1 Then If arrName(1) = otherEmpName(0) Then matchingNames = 1 For i = 2 To UBound(arrName) If (i - 1) <= UBound(otherEmpName) Then If arrName(i) = otherEmpName(i - 1) Then matchingNames = matchingNames + 1 Else Exit For End If End If Next i If matchingNames > MIN_MATCHING_NAMES Then If isFemaleName Then relation = "ابنة" Else relation = "ابن" End If Me.EntityEmployee = relation Me.NameVerificationEmployee = rs!NameEmployee found = True Exit Do End If ElseIf UBound(arrName) >= MIN_MATCHING_NAMES And UBound(otherEmpName) >= MIN_MATCHING_NAMES Then matchingNames = 0 For i = 1 To UBound(arrName) If i <= UBound(otherEmpName) Then If arrName(i) = otherEmpName(i) Then matchingNames = matchingNames + 1 Else Exit For End If End If Next i If matchingNames > MIN_MATCHING_NAMES Then If isFemaleName Then relation = "أخت" Else relation = "أخ" End If Me.EntityEmployee = relation Me.NameVerificationEmployee = rs!NameEmployee found = True Exit Do End If End If End If End If rs.MoveNext Loop If Not found Then Me.EntityEmployee = "لا يوجد" Me.NameVerificationEmployee = "فردي" End If rs.Close Set rs = Nothing Set db = Nothing End Sub

انتظر لحظة ، قمت بتجربة الكود على اسماء متنوعة ، والنتيجة غير مرضية بالنسبة لي ,, سأعدل في التالي لاحقاً