Foksh

حسناً ، جرب هذا التعديل ، كنت قد جهزته مسبقاً للإحتياط لهكذا رد . مع العلم أنني لا أملك أوفيس 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

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

جرب التعديل التالي عله يكون الحل الذي تريده :- 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 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(arrName(0), 1) = "ه" Or Right(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 otherEmpName = Split(rs!NameEmployee, " ") If UBound(otherEmpName) >= 1 Then If arrName(1) = otherEmpName(0) Then Dim matchFound As Boolean matchFound = True If UBound(arrName) >= 2 And UBound(otherEmpName) >= 2 Then If arrName(2) <> otherEmpName(1) Then matchFound = False End If End If If matchFound 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 rs.MoveNext Loop If Not found Then Me.EntityEmployee = "لا يوجد" Me.NameVerificationEmployee = "فردي" End If rs.Close Set rs = Nothing Set db = Nothing End Sub

بعد تحميل المرفق من الرابط والإطلاع عليه ،اضطررت الى تعديل أصل الكود بحيث يعمل على النواتين 32 و 64 (النسخة لدي 64 ) ، لتصبح الدالة في المديول كالآتي بعد إزالة التعليقات التوضيحية منها :- Option Compare Database Option Explicit #If VBA7 Then Private Declare PtrSafe Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As LongPtr, ByVal bInheritHandle As LongPtr, ByVal dwProcessId As LongPtr) As LongPtr Private Declare PtrSafe Function CloseHandle Lib "kernel32.dll" (ByVal hObject As LongPtr) As Long Private Declare PtrSafe Function ExpandEnvironmentStringsW Lib "kernel32.dll" (ByVal lpSrc As LongPtr, Optional ByVal lpDst As LongPtr, Optional ByVal nSize As LongPtr) As Long Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As LongPtr, ByRef lpExitCode As Long) As Long Private Declare PtrSafe Function MsgWaitForMultipleObjects Lib "user32.dll" (ByVal nCount As Long, ByRef pHandles As LongPtr, ByVal bWaitAll As Long, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long Private Declare PtrSafe Function SysReAllocStringLen Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr, Optional ByVal Length As Long) As Long Private Declare PtrSafe Function CreateWaitableTimerW Lib "kernel32.dll" (Optional ByVal lpTimerAttributes As LongPtr, Optional ByVal bManualReset As Long, Optional ByVal lpTimerName As LongPtr) As LongPtr Private Declare PtrSafe Function GetProcessId Lib "kernel32.dll" (ByVal hProcess As LongPtr) As Long Private Declare PtrSafe Function PathCanonicalizeW Lib "shlwapi.dll" (ByVal lpszDst As LongPtr, ByVal lpszSrc As LongPtr) As Long Private Declare PtrSafe Function PathGetArgsW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) As LongPtr Private Declare PtrSafe Function SetWaitableTimer Lib "kernel32.dll" (ByVal hTimer As LongPtr, ByRef pDueTime As Currency, Optional ByVal lPeriod As Long, Optional ByVal pfnCompletionRoutine As LongPtr, Optional ByVal lpArgToCompletionRoutine As LongPtr, Optional ByVal fResume As Long) As Long Private Declare PtrSafe Function ShellExecuteExW Lib "shell32.dll" (ByVal pExecInfo As LongPtr) As Long Private Declare PtrSafe Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr) As Long Private Declare PtrSafe Sub PathRemoveArgsW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) #Else Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long Private Declare Function ExpandEnvironmentStringsW Lib "kernel32.dll" (ByVal lpSrc As Long, Optional ByVal lpDst As Long, Optional ByVal nSize As Long) As Long Private Declare Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByRef lpExitCode As Long) As Long Private Declare Function MsgWaitForMultipleObjects Lib "user32.dll" (ByVal nCount As Long, ByRef pHandles As Long, ByVal bWaitAll As Long, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long Private Declare Function SysReAllocStringLen Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long, Optional ByVal Length As Long) As Long Private Declare Function CreateWaitableTimerW Lib "kernel32.dll" (Optional ByVal lpTimerAttributes As Long, Optional ByVal bManualReset As Long, Optional ByVal lpTimerName As Long) As Long Private Declare Function GetProcessId Lib "kernel32.dll" (ByVal hProcess As Long) As Long Private Declare Function PathCanonicalizeW Lib "shlwapi.dll" (ByVal lpszDst As Long, ByVal lpszSrc As Long) As Long Private Declare Function PathGetArgsW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long Private Declare Function SetWaitableTimer Lib "kernel32.dll" (ByVal hTimer As Long, ByRef pDueTime As Currency, Optional ByVal lPeriod As Long, Optional ByVal pfnCompletionRoutine As Long, Optional ByVal lpArgToCompletionRoutine As Long, Optional ByVal fResume As Long) As Long Private Declare Function ShellExecuteExW Lib "shell32.dll" (ByVal pExecInfo As Long) As Long Private Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long Private Declare Sub PathRemoveArgsW Lib "shlwapi.dll" (ByVal pszPath As Long) #End If Private Const SEE_MASK_NOCLOSEPROCESS As Long = &H40 Private Const SEE_MASK_DOENVSUBST As Long = &H200 Private Const SEE_MASK_FLAG_NO_UI As Long = &H400 #If VBA7 Then Private Type SHELLEXECUTEINFO cbSize As Long fMask As Long hWnd As LongPtr lpVerb As String lpFile As String lpParameters As String lpDirectory As String nShow As Long hInstApp As LongPtr lpIDList As LongPtr lpClass As String hkeyClass As LongPtr dwHotKey As Long hIcon As LongPtr hProcess As LongPtr End Type #Else Private Type SHELLEXECUTEINFO cbSize As Long fMask As Long hWnd As Long lpVerb As String lpFile As String lpParameters As String lpDirectory As String nShow As Long hInstApp As Long lpIDList As Long lpClass As String hkeyClass As Long dwHotKey As Long hIcon As Long hProcess As Long End Type #End If Public Const INFINITE As Long = &HFFFFFFFF Public Const STILL_ACTIVE As Long = &H103 Public Const PROCESS_HAS_TERMINATED As Long = vbObjectError Or &HDEAD Public Enum AppWinStyle vbHide = 0 vbShowNormal = 1 vbShowMinimized = 2 vbShowMaximized = 3 vbMaximize = 3 vbShowNoActivate = 4 vbShow = 5 vbMinimize = 6 vbShowMinNoActive = 7 vbShowNA = 8 vbRestore = 9 vbShowDefault = 10 End Enum Public Function Shell_n_Wait(ByRef PathName As String, Optional ByVal WindowStyle As VbAppWinStyle = vbNormalFocus) As Long Const PROCESS_QUERY_INFORMATION = &H400, QS_ALLINPUT = &H4FF, SYNCHRONIZE = &H100000 Dim hProcess As LongPtr, sPath As String If InStr(PathName, "%") = 0 Then sPath = PathName Else SysReAllocStringLen VarPtr(sPath), , ExpandEnvironmentStringsW(StrPtr(PathName)) - 1 ExpandEnvironmentStringsW StrPtr(PathName), StrPtr(sPath), Len(sPath) + 1 End If On Error GoTo ErrorHandler hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or SYNCHRONIZE, False, Shell(sPath, WindowStyle)) On Error GoTo 0 If hProcess Then sPath = vbNullString Do While MsgWaitForMultipleObjects(1, hProcess, False, INFINITE, QS_ALLINPUT) DoEvents Loop GetExitCodeProcess hProcess, Shell_n_Wait CloseHandle hProcess End If Exit Function ErrorHandler: Err.Raise Err.Number, , Err.Description End Function Public Function ShellW(ByRef PathName As String, Optional ByVal WindowStyle As AppWinStyle = vbShowNormal, Optional ByVal Wait As Long) As Long Const MAX_PATH = 260, QS_ALLINPUT = &H4FF, WAIT_OBJECT_0 = &H0 Dim TimedOut As Boolean, nCount As Long, pHandles As LongPtr, RV As Long, SEI As SHELLEXECUTEINFO Err.Clear If LenB(PathName) = 0 Then Exit Function With SEI .cbSize = LenB(SEI) .fMask = SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_DOENVSUBST Or SEE_MASK_FLAG_NO_UI .nShow = WindowStyle If InStr(PathName, "%") Then SysReAllocStringLen VarPtr(.lpFile), , ExpandEnvironmentStringsW(StrPtr(PathName)) - 1 ExpandEnvironmentStringsW StrPtr(PathName), StrPtr(.lpFile), Len(.lpFile) + 1 Else .lpFile = PathName End If If InStr(.lpFile, "\.") <> 0 Or InStr(.lpFile, ".\") <> 0 Then If Len(.lpFile) < MAX_PATH Then SysReAllocStringLen VarPtr(.lpVerb), , MAX_PATH - 1 If PathCanonicalizeW(StrPtr(.lpVerb), StrPtr(.lpFile)) Then SysReAllocString VarPtr(.lpFile), StrPtr(.lpVerb) End If .lpVerb = vbNullString End If End If SysReAllocString VarPtr(.lpParameters), PathGetArgsW(StrPtr(.lpFile)) If LenB(.lpParameters) Then PathRemoveArgsW StrPtr(.lpFile) If InStr(.lpParameters, """") Then .lpParameters = Replace(.lpParameters, """", """""") End If If ShellExecuteExW(VarPtr(SEI)) Then ShellW = GetProcessId(.hProcess) If Wait Then .lpFile = vbNullString .lpParameters = vbNullString If .hProcess Then nCount = 1 pHandles = VarPtr(.hProcess) End If If Wait > INFINITE Then .hIcon = CreateWaitableTimerW If .hIcon Then nCount = nCount + 1 pHandles = VarPtr(.hIcon) Wait = SetWaitableTimer(.hIcon, CCur(-Wait)) End If End If Do RV = MsgWaitForMultipleObjects(nCount, ByVal pHandles, False, INFINITE, QS_ALLINPUT) If RV < nCount Then If .hIcon Then TimedOut = RV = 0 RV = CloseHandle(.hIcon) End If Err.Clear Exit Do End If DoEvents Loop If Not (TimedOut) Then RV = GetExitCodeProcess(.hProcess, ShellW) Err = PROCESS_HAS_TERMINATED Err.Description = "Exit Code" End If End If If .hProcess Then RV = CloseHandle(.hProcess) End If End With End Function Public Function ShellWS(ByRef Command As String, Optional ByVal WindowStyle As VbAppWinStyle = vbNormalFocus, Optional ByVal WaitOnReturn As Boolean) As Long Dim ws As Object Set ws = CreateObject("Wscript.Shell") ShellWS = ws.Run(Command, WindowStyle, WaitOnReturn) End Function الآن في النموذج الأول th44 ، وبعد نسخ مربع النص str_Text وعنصر الصورة للباركود اليه ، أصبح كود النموذج كالآتي :- Option Compare Database Option Explicit Private Function ConstQRPath() ConstQRPath = CurrentProject.Path & "\Data\QR_images\" & Me.Key & " - " & "QR_code.png" End Function Private Function ConstBarcodePath() ConstBarcodePath = CurrentProject.Path & "\Data\QR_images\" & Me.Key & " - " & "ID_PDF_417.png" End Function Private Sub CreateQRCode() On Error GoTo ErrorHandler If IsNull(Me.th_Text) Or IsEmpty(Me.th_Text) Or Len(Trim(Nz(Me.th_Text, ""))) = 0 Then Exit Sub End If Dim AppName As String Dim OutputFile As String Dim OutputText As String Dim CommandLine As String AppName = Chr(34) & Application.CurrentProject.Path & "\Data\zint.exe" & Chr(34) OutputText = Chr(34) & Me.th_Text & Chr(34) OutputFile = Chr(34) & ConstQRPath & Chr(34) CommandLine = AppName & " -o " & OutputFile & " --rotate=0 --eci=24 --scale=2 -w 0 --height=100 --barcode=58 -d " & OutputText Shell_n_Wait CommandLine, vbHide Exit Sub ErrorHandler: MsgBox "An error occurred: " & Err.Description, vbCritical, "Error" End Sub Private Sub CreateBarcode() On Error GoTo ErrorHandler If IsNull(Me.str_Text) Or IsEmpty(Me.str_Text) Or Len(Trim(Nz(Me.str_Text, ""))) = 0 Then Exit Sub End If Dim AppName As String Dim OutputFile As String Dim OutputText As String Dim CommandLine As String AppName = Chr(34) & Application.CurrentProject.Path & "\Data\zint.exe" & Chr(34) OutputText = Chr(34) & Me.str_Text & Chr(34) OutputFile = Chr(34) & ConstBarcodePath & Chr(34) CommandLine = AppName & " -o " & OutputFile & " --rotate=0 --eci=24 --binary --barcode=55 --mode=3 -d " & OutputText Shell_n_Wait CommandLine, vbHide Exit Sub ErrorHandler: MsgBox "An error occurred: " & Err.Description, vbCritical, "Error" End Sub Private Sub Form_Current() Call CreateAndDisplayCodes End Sub Sub CreateAndDisplayCodes() On Error GoTo ErrorHandler If IsNull(Me.th_Text) Or IsEmpty(Me.th_Text) Or Len(Trim(Nz(Me.th_Text, ""))) = 0 Then Me.QR_Code.Picture = "" Else Call CreateQRCode Me.QR_Code.Picture = ConstQRPath End If If IsNull(Me.str_Text) Or IsEmpty(Me.str_Text) Or Len(Trim(Nz(Me.str_Text, ""))) = 0 Then Me.ID_PDF_417.Picture = "" Else Call CreateBarcode Me.ID_PDF_417.Picture = ConstBarcodePath End If Exit Sub ErrorHandler: If Err.Number = 2220 Then Me.QR_Code.Picture = "" Me.ID_PDF_417.Picture = "" Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical, "Code generation error" End If Resume Next End Sub Private Sub sdfff_Click() On Error Resume Next DoCmd.OpenForm "thaaer55" Dim RName, FldCriteria As String RName = "rpt_Details" FldCriteria = "[Key]=" & Me![Key] DoCmd.OpenReport RName, acViewNormal, , FldCriteria End Sub وهذا الملف بعد التعديل :- New.zip اخبرنا بالنتيجة 😊 .

وعليكم السلام ورحمة الله وبركاته .. من خلال تصميمك للجدول ، نستطيع انشاء دالة عامة في مديول كالتالي - بناءً على أسماء الأشهر لديك :- Function CalculateFridaysSaturdays(monthName As String, year As Integer, Optional dayType As String = "Both") As Variant Dim monthNumber As Integer Dim startDate As Date Dim endDate As Date Dim currentDate As Date Dim fridays As Integer Dim saturdays As Integer 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 startDate = DateSerial(year, monthNumber, 1) endDate = DateSerial(year, monthNumber + 1, 0) fridays = 0 saturdays = 0 currentDate = startDate Do While currentDate <= endDate If Weekday(currentDate) = vbFriday Then fridays = fridays + 1 ElseIf Weekday(currentDate) = vbSaturday Then saturdays = saturdays + 1 End If currentDate = currentDate + 1 Loop If dayType = "Friday" Then CalculateFridaysSaturdays = fridays ElseIf dayType = "Saturday" Then CalculateFridaysSaturdays = saturdays Else CalculateFridaysSaturdays = Array(fridays, saturdays) End If End Function ومن خلال استعلام تحديث ، تستطيع استدعاء الدالة لتحديث القيم في الحقلين حسب السنة الحالية كالآتي :- UPDATE data_shr SET gm = CalculateFridaysSaturdays([shr], Year(Date()), "Friday"), sbt = CalculateFridaysSaturdays([shr], Year(Date()), "Saturday"); النتيجة ، افتح استعلام التحديث Query2 وشوف النتيجة في المرفق التالي :- ايام الغياب.accdb

وعليكم السلام ورحمة الله وبركاته .. قم بإضافة زر إلى نموذج (مثلاً : btnRestore) اجعل الكود التالي كتجربة ( بما انك لم تقم بارفاق قاعدتا البيانات للتجربة ) فيحدث عند النقر للزر السابق :- Private Sub btnRestore_Click() Dim dbPath As String Dim backupPath As String Dim fso As Object Dim fd As FileDialog dbPath = CurrentProject.FullName Set fd = Application.FileDialog(3) With fd .Title = "اختر ملف النسخة الاحتياطية" .Filters.Clear .Filters.Add "ملفات Access", "*.accdb;*.mdb" .AllowMultiSelect = False If .Show = -1 Then backupPath = .SelectedItems(1) Else MsgBox "لم يتم تحديد أي ملف!", vbExclamation + vbMsgBoxRight, "إلغاء العملية" Exit Sub End If End With If Dir(backupPath) = "" Then MsgBox "الملف المحدد غير موجود", vbExclamation + vbMsgBoxRight, "خطأ" Exit Sub End If DoCmd.Close acForm, "اسم_النموذج", acSaveYes DoCmd.Close acReport, "اسم_التقرير", acSaveYes DoCmd.Close acTable, "اسم_الجدول", acSaveYes DoCmd.Close acQuery, "اسم_الاستعلام", acSaveYes Set fso = CreateObject("Scripting.FileSystemObject") fso.DeleteFile dbPath, True fso.CopyFile backupPath, dbPath MsgBox "تم استعادة النسخة الاحتياطية بنجاح ! قد تحتاج إعادة تشغيل البرنامج", vbInformation + vbMsgBoxRight, "نجاح" End Sub يجب توافر المكتبة Microsoft Office XX.0 Object Library