Foksh

وعليكم السلام ورحمة الله وبركاته ،، فيما يتعلق بالمطلب الأول ، أعتقد انه يجب ضبط التنسيق للتاريخ في الدالة إن كانت هي المسؤولة عن الخلل الذي تتحدث عنها ، علماً أنني لم ألحظ الخطأ بشكل واضح . على العموم في الدالة داخل المديول جرب ضبط التنسيق للسطر بالشكل التالي :- 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

وعليكم السلام ورحمة الله وبركاته .. جرب هذا التعديل بالاستعلام التالي :- SELECT D.Cood, IIf([D].[Percent]*100 <= 60 Or [S].[natio] = 'S', "خارج", [S].[Tans]) AS Expr1 FROM S INNER JOIN D ON S.Cood = D.Cood; جرب الاستعلام وأخبرني بالنتيجة !! 😊

وعليكم السلام ورحمة الله وبركاته .. جرب فكرتي البسيطة .. 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 Set db = CurrentDb() strEmpName = Me.NameEmployee arrName = Split(strEmpName, " ") If UBound(arrName) >= 2 Then lastName = arrName(UBound(arrName)) Else MsgBox "يجب إدخال الاسم ثلاثيًا على الأقل.", vbExclamation, "تنبيه" Exit Sub End If Set rs = db.OpenRecordset("SELECT IDeMP, NameEmployee FROM DatEmp WHERE NameEmployee Like '*" & lastName & "' AND IDeMP <> " & Me.IDeMP) found = False Do While Not rs.EOF If InStr(rs!NameEmployee, lastName) > 0 Then If InStr(rs!NameEmployee, arrName(0)) > 0 Then relation = "ابن" ElseIf InStr(rs!NameEmployee, arrName(1)) > 0 Then relation = "أخ" Else relation = "أخت" End If Me.EntityEmployee = relation Me.NameVerificationEmployee = rs!NameEmployee found = True Exit Do 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 emp.7z

لم اقم بتحميل المرفق ، ولكن جرب التالي بتصحيح بعض الأخطاء .. Private Sub txt_AfterUpdate() Dim selectedYear As Integer If IsNumeric(Me.txt.Value) Then selectedYear = CInt(Me.txt.Value) Else MsgBox "الرجاء إدخال سنة صحيحة", vbExclamation Exit Sub End If Me.Filter = "[totalshy] = 0 OR ([yearshy] <> " & selectedYear & " AND [totalshy] <> 0)" Me.FilterOn = True End Sub

نفس النتيجة للأسف ، يبدو أن جهازك مصاب بفايروس لذلك لا تظهر المشكلة في جهازك يا صديقي 🤗,

عمل جميل جداً ، وجزاك الله كل خير على مجهودك .. وتقبل الله طاعاتكم وصيامكم وقيامكم ،، وهنأكم بإفطاركم بهذا الشهر الفضيل .. لي مداخلة بسيطة وهي أن معظم ( 90% ) من مصممي البرامج يتوجهون الى ان تكون الرسائل باللغة العربية ؛ على الأقل ليسهل فهمها للمستخدم وللوصول الى حل المشكلة التي ظهرت له . هل يمكن تنفيذ الفكرة ???

وعليكم السلام ورحمة الله وبركاته ,, المرفق غير سليم ،،

وعليكم السلام ورحمة الله وبركاته .. بدايةً لن أنصحك بالإعتماد على كود تخطي الأخطاء هذا بشكل أساسي في مشاريعك ، لأنه قد يترتب عليه تخطي خطأ باكمال معلومة أو معادلة أو إجراء أو نتيجة ستكون قد بنيت عليها إجراءات أخرى ، وعليه تقع في مشاكل .. - على العموم استخدم الكود في حدث عند التحميل للنموذج ، وسيبقى مفعلاً لكل الأكواد الأخرى داخل النموذج طالما لم يتم تغييره في أي إجراء آخر . - أولاً لم أقم بتجربتها ، جرب استعماله في حدث On Error للنموذج كإجراء عام .

وعليكم السلام ورحمة الله تعالى وبركاته.. يبدو انني لم أقم بتوصيل المعلومة جيداً.. جدول العملاء والسيارات لا غنى عنهم ( ولا اختلاف في ذلك ). جدول العقول هو ذلك المقصود بأن يكون الجدول الموحد. فمثلاً جدول العقود سيضم حقل رقم العميل ( الفريد ) ورقم السيارة ( الفريد أيضاً ) . وباقي الحقول الخاصة بهما سيتم جلبه حسب الرقم الفريد ، أما بيانات العقد وهي الغير ثابتة ( التواريخ ، العدادات ، المبالغ ، ..... إلخ ) ستكون في جدول العقود الموحد . أي بمعنى أصح كأنه جدول الحركات ، وسأقوم بتطبيق فكرتي بشكل مصغر على مقصدي حال وصولي للكمبيوتر 🤗 إن شاء الله..