Foksh

وعليكم السلام ورحمة الله وبركاته ..
الأمر بسيط أخي الكريم إن شاء الله . اولاً سننشئ الدالة التالية في مديول :-
Public Function GenerateID(TableName As String, fieldName As String) As Long Dim currentYear As Integer Dim yearPrefix As String Dim maxID As Long Dim serialPart As Long currentYear = Year(Date) yearPrefix = currentYear & "" maxID = Nz(DMax(fieldName, TableName, fieldName & " LIKE '" & yearPrefix & "*'"), yearPrefix & "00") serialPart = CLng(Mid(maxID, Len(yearPrefix) + 1)) GenerateID = CLng(yearPrefix & (serialPart + 1)) End Function  
ثم في مربع النص داخل النموذج سنقوم بجعل القيمة الإفتراضية لهذا المربع النصي = الإستدعاء التالي ( على اعتبار ان الجدةل اسمه Tbl_Cust والحقل الرقمي الخاص بالترقيم = ID ) ..
=GenerateID("Tbl_Cust","ID") المرونة في الإستدعاء ستكون انه يمكنك استخدام الترقمي لأكثر من جدول . فقط بتغيير اسم الجدول وحقل الترقيم .
وهذا مثال في ملف مرفق :-
GenerateID.accdb

ليس من طبعي عدم استكمال بداية قد بدأتها ،ولكنك اخي الكريم في كل مرة تقوم بتوجيه طلب مختلف ، أو انك من البداية لم تقم بتوضيح المطلوب بشكل جيد . وها ما جعلني استنكف عن المتابعة .
لكن على العموم ، اتمنى ان لايكون الهدف في رأسك غير الذي أشرت اليه مؤخراً . ولذا فهذه تجربتي علها تكون ما تريده .
المديول سيصبح بهذا الشكل ( التعديل فقط على الدالة الأخيرة ) ..
Function DurationToWords(StartDate As Variant, EndDate As Variant) As String Dim diff As Integer If IsNull(StartDate) Or IsNull(EndDate) Then DurationToWords = "لم يتم إدخال تاريخين للمقارنة" Exit Function End If diff = DateDiff("yyyy", StartDate, EndDate) If Month(EndDate) < Month(StartDate) Or _ (Month(EndDate) = Month(StartDate) And Day(EndDate) < Day(StartDate)) Then diff = diff - 1 End If Select Case diff Case Is < 0 DurationToWords = "تاريخ غير صالح" Case 0 DurationToWords = "أقل من سنة" Case 1 DurationToWords = "سنة واحدة" Case 2 DurationToWords = "سنتان" Case 3 To 10 DurationToWords = NumberToArabicWords(diff, True) & " سنوات" Case Else DurationToWords = NumberToArabicWords(diff, True) & " سنة" End Select End Function Function NumberToArabicWords(ByVal Number As Long, Optional IsFeminine As Boolean = False) As String Dim UnitsMasc, UnitsFem, Tens, TeensMasc, TeensFem, Hundreds UnitsMasc = Array("", "واحد", "اثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة") UnitsFem = Array("", "واحدة", "اثنتان", "ثلاث", "أربع", "خمس", "ست", "سبع", "ثمان", "تسع") TeensMasc = Array("عشرة", "أحد عشر", "اثنا عشر", "ثلاثة عشر", "أربعة عشر", "خمسة عشر", "ستة عشر", "سبعة عشر", "ثمانية عشر", "تسعة عشر") TeensFem = Array("عشرة", "إحدى عشرة", "اثنتا عشرة", "ثلاث عشرة", "أربع عشرة", "خمس عشرة", "ست عشرة", "سبع عشرة", "ثماني عشرة", "تسع عشرة") Tens = Array("", "عشرة", "عشرون", "ثلاثون", "أربعون", "خمسون", "ستون", "سبعون", "ثمانون", "تسعون") Hundreds = Array("", "مئة", "مئتان", "ثلاثمئة", "أربعمئة", "خمسمئة", "ستمئة", "سبعمئة", "ثمانمئة", "تسعمئة") Dim Words As String Dim n As Long Dim h, t, u As Integer If Number = 0 Then NumberToArabicWords = "صفر" Exit Function End If If Number = 10 Then NumberToArabicWords = IIf(IsFeminine, "عشر", "عشرة") Exit Function End If If Number > 999 Then Dim Thousands As Long Thousands = Number \ 1000 Words = NumberToArabicWords(Thousands, False) & " ألف" n = Number Mod 1000 If n > 0 Then Words = Words & " و" & NumberToArabicWords(n, IsFeminine) NumberToArabicWords = Words Exit Function End If h = Number \ 100 t = (Number Mod 100) \ 10 u = Number Mod 10 If h > 0 Then Words = Hundreds(h) If (Number Mod 100) >= 11 And (Number Mod 100) <= 19 Then If Words <> "" Then Words = Words & " و" If IsFeminine Then Words = Words & TeensFem((Number Mod 100) - 10) Else Words = Words & TeensMasc((Number Mod 100) - 10) End If Else Dim UnitsArray UnitsArray = IIf(IsFeminine, UnitsFem, UnitsMasc) If t > 1 Then If u > 0 Then If Words <> "" Then Words = Words & " و" Words = Words & UnitsArray(u) & " و" & Tens(t) Else If Words <> "" Then Words = Words & " و" Words = Words & Tens(t) End If ElseIf u > 0 Then If Words <> "" Then Words = Words & " و" Words = Words & UnitsArray(u) End If End If NumberToArabicWords = Words End Function Function GetDurationStatus(StartDate As Variant, EndDate As Variant) As String If IsNull(StartDate) Or IsNull(EndDate) Then GetDurationStatus = "" Exit Function End If If EndDate < Date Then GetDurationStatus = "Expired" Else GetDurationStatus = "Current" End If End Function  
وفي التنسيق الشرطي استدعينا الدالة بها الشكل كما في الصورة :-

حيث تم استدعاء الدالة مع تحديد اذا كانت النتيجة = Expired أو Current لتحديد اللون .
 
المرفق الأخير :-
تفقيط التاريخ 1 (2).accdb

وعليكم السلام ورحمة الله وبركاته ,,
هل هذه النتيجة صحيحة من المطلوب ؟

جرب هذا الاستعلام :-
SELECT tbaa.* FROM tbaa INNER JOIN (SELECT MIN(id) AS MinID FROM tbaa GROUP BY ll) AS UniqueRecords ON tbaa.id = UniqueRecords.MinID;  
طبعاً يوجد أكثر من فكرة للقيام بالوطلوب ، والسابق هي فكرة حيث أن الاستعلام سيجلب أول سجل (حسب أصغر ID) من كل مجموعة قيم ll ، سواء كانت مكررة أو لا .
أما اذا كنت تريد حسب أكبر ID فقط نستبدل بدلاً من Mini = Max كالتالي :-
SELECT tbaa.* FROM tbaa INNER JOIN (SELECT MAX(id) AS MaxID FROM tbaa GROUP BY ll) AS UniqueRecords ON tbaa.id = UniqueRecords.MaxID;  
وكفكرة أخرى على سبيل المثال :-
 
بواسطة استعلام باستخدام DISTINCT ON :-
SELECT tbaa.ll, FIRST(tbaa.id) AS first_id, FIRST(tbaa.rr) AS first_rr, FIRST(tbaa.fax) AS first_fax, FIRST(tbaa.mo) AS first_mo FROM tbaa GROUP BY tbaa.ll;  
وهناك فكرة تعتمد على استعلامين اثنين أحدهما مبني على الآخر ، ولكني لا اعتقد انك قد ترغب باستعلامين ما دام الأمر يمكن تنفيذه باستعلام واحد بأكثر من شكل  .

وعليكم السلام ورحمة الله وبركاته اخي الفاضل 
 
لأن Date هي دالة مضمنة لا تتطلب أقواس إذا لم تكن تُستدعى كجزء من تعبير داخل دالة أخرى .
وهذا طبيعي وسليم وصحيح 100% 
وعادة لا يتم حذف القوسين عند استدعاء دالة عامة باسمها الصريح باستخدام call
 
هذا رأيي والله أعلم

تفضل المرفق التالي ..
 
2025.accdb

وعليكم السلام ورحمة الله وبركاته ,,
جرب التعديل التالي :-
DoCmd.OpenForm "JO_IN_OUT", , , "[Ddate] = #" & Format(Me.ddate, "yyyy\/mm\/dd") & "#"  

باعتقادي ودون الحاجة الى التوسعات في الإحتمالات ، المشكلة تكمن في السطر التالي :-
Dim DB As Database, rs As Recordset بأن يتم التعديل كالتالي :-
Dim DB As DAO.Database, rs As DAO.Recordset  
هذا من وجهة نظري المتواضعة فقط لا غير 😁 .
وكل عام وأنتم بخير جميعاً

أهلا مهندسنا الغالي .. جزاك الله خيراً على ما أسلفت ، هل الصورة أدناه تكفي  !!!

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

السلام عليكم ورحمة الله وبركاته 
في ملاحظة جانبية سأتطرق إليها للتوضيح في نقطة قد يتساءل البعض عنها في هذا الجزء
For i = 0 To UBound(arLabels) UpdateLabel frm, "Label" & CStr(i + 1), arLabels(i), enLabels(i) UpdateLabel frm, "Command" & CStr(i + 1), arLabels(i), enLabels(i) Next i End Sub تمت إضافة هذا الجزء من الكود ليشمل الـ Lable كما في الجزء الأول ، والـ Command في الجزء الثاني. حيث أن المسميات ستكون متبوعة برقم وهو الذي سيحدد رقم السطر في ملفات اللغة ( Arabic , English ) ، فهنا نستطيع التوحيد في مسميات البرنامج ( كتوحيد المقامات في الرياضيات 😅 ) طبعاً هنا سنحتاج جزء واحد من السطر ، ولنفترض أن الكود سيصبح بهذا الشكل:-
For i = 0 To UBound(arLabels) UpdateLabel frm, "Officna" & CStr(i + 1), arLabels(i), enLabels(i) Next i End Sub هنا قمت بتوحيد جميع العناصر والكائنات في المشروع ( مربعات نص ، ليبلات ، ازرار ..... إلخ ) تحت اسم Officna
وهنا يسهل علينا - وكما ذكر معلمنا الفاضل @ابوخليل - حفظ المسميات وسهولة الوصول إليها وتحديدها ..
 
ودمتم بخير 🤗

وهذه مشاركة بطريقة أخرى ، مشاركةً مع معلمي الجليل و والدنا العزيز الأستاذ @ابوخليل ..
فكرتين ، الأولى هي بجعل الزر يفتح التقرير بشرطين =
DoCmd.OpenReport "qrbook", acViewPreview, , , , Me.fsldrase.Column(1) & ";" & Me.drase.Column(1) وأن نجعل الحدث عند التحميل للتقرير = 
Dim args As Variant If Not IsNull(Me.OpenArgs) Then args = Split(Me.OpenArgs, ";") Me.Tx_Fasl = args(0) Me.Tx_Yer = args(1) End If  
والفكرة الثانية كما أشار أستاذي في مشاركته تماماً .. ومرفق زرين كل واحد منهما بطريقة
 
نموذج بحث شامل 1.accdb

وعليكم السلام ورحمة الله تعالى وبركاته..
تقدر تستخدام حدث "On Key Down" في النموذج للتحقق مما إذا كان المستخدم قد ضغط على Ctrl + T أو Ctrl + D ثم تغيير خصائص التعديل والحذف بناءً على ذلك . بس طبعاً لازم تتأكد أن خاصية Key Preview في النموذج = Yes 😅 
وإلا فلن نستفيد من الكود التالي :-
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) If KeyCode = vbKeyT And (Shift And acCtrlMask) <> 0 Then Me.AllowEdits = True MsgBox "تم تفعيل التعديل", vbInformation End If If KeyCode = vbKeyD And (Shift And acCtrlMask) <> 0 Then Me.AllowDeletions = True MsgBox "تم تفعيل الحذف", vbInformation End If End Sub جرب النتيجة النهائية وأخبرنا بها 😇 

لا تشغل بالك يا صديقي ، جل من لا يسهو ..
تفضل بعد التعديل على الاستعلامات ، تم تحقيق المطلوب في الملف المرفق ،

 
 
jo2025.accdb

حسناً ، جرب هذا التعديل البسيط ,,
Private Sub Comannd187_Click() Dim fdialog As Office.FileDialog Dim filepath As String Dim sdialog As New WIA.CommonDialog Dim imagefile As WIA.imagefile On Error GoTo errorhandle Dim fso As Object Dim fldrname, fldrpath, FoldrPath As String FoldrPath = "Pictures" Set fso = CreateObject("scripting.filesystemobject") fldrpath = CurrentProject.Path & "\" & FoldrPath If Not fso.FolderExists(fldrpath) Then fso.createfolder (fldrpath) End If '================================== Set fdialog = Application.FileDialog(msoFileDialogSaveAs) filepath = CurrentProject.Path & "\" & FoldrPath & "\" & Me.Key & ".jpg" Set imagefile = sdialog.ShowAcquireImage() imagefile.SaveFile filepath Me.PicPath2 = filepath Image.Requery errorhandleexit: Exit Sub errorhandle: If Err.Number = "-2147024816" Then If MsgBox("توجد صورة تحمل نفس الرقم" & vbNewLine & "هل تريد حذف الصورة القديمة" & vbNewLine & "في حال الرفض سيتم اضافة رقم عشوائي الى اسم الصورة لتمييزها", vbCritical + vbYesNo + vbMsgBoxRight, "تنبيه") = vbYes Then Kill filepath 'Set imagefile = sdialog.ShowAcquireImage() imagefile.SaveFile filepath Me.PicPath2 = filepath Image.Requery Else Dim g As String g = CurrentProject.Path & "\" & FoldrPath & "\" & Me.Key & "-" & Format(Now, "hhnnss") & ".jpg" imagefile.SaveFile g Me.PicPath2 = g Me.Image1.Picture = Me.Pic1 End If ElseIf Err.Number = "-2145320939" Then MsgBox "الاسكانر غير متصل", vbCritical + vbMsgBoxRight, "تنبيه" Else Me.PicPath2 = Err.Number MsgBox Err.Description End If Resume errorhandleexit End Sub  

بناءً على طلب وملاحظة الأستاذ موسى ( مشكوراً )، تمت التعديلات الجديدة في النسخة التالية بحيث :-
♻ تظهر أسماء الأعمدة البرمجية والعناوين التي تخصها في الصف الأول كما في الصورة أدناه ( مثال ) ..

♻ الفكرة تم تطبيقها على الإستيراد المتعدد والغير متعدد أيضاً ..
 
 
💢 Excel Importor 2025.accdb 💢
 

وعليكم السلام ورحمة الله تعالى وبركاته اخي @أبو أحمد ، تفضل الكود التالي بعد تعديل المسميات في مثالك.
Private Sub أمر26_Click() On Error GoTo ErrorHandler Dim db As dao.Database Dim rst1 As Recordset, rst2 As Recordset Dim fld As Field Dim sqlUpdate1 As String, sqlUpdate2 As String Dim recordID As Long If Me.searinumber = 0 Or IsNull(Me.searinumber) Or Me.searinumber = "" Then MsgBox "الرجاء إدخال رقم السجل", vbExclamation Me.searinumber.SetFocus Exit Sub End If recordID = Val(Me.searinumber) Set db = CurrentDb() If DCount("*", "جدول تسجيل الكتب", "searinumber = " & recordID) = 0 Then MsgBox "رقم السجل غير موجود", vbExclamation Me.searinumber.SetFocus GoTo ExitSub End If Set rst1 = db.OpenRecordset("جدول تسجيل الكتب") 'الجدول الرئيسي sqlUpdate1 = "UPDATE [جدول تسجيل الكتب] SET " For Each fld In rst1.Fields If fld.Name <> "searinumber" Then 'المفتاح الأساسي If Not (fld.Attributes And dbAutoIncrField) Then sqlUpdate1 = sqlUpdate1 & "[" & fld.Name & "] = Null, " End If End If Next fld If Right(sqlUpdate1, 2) = ", " Then sqlUpdate1 = Left(sqlUpdate1, Len(sqlUpdate1) - 2) sqlUpdate1 = sqlUpdate1 & " WHERE searinumber = " & recordID End If Set rst2 = db.OpenRecordset("Marks") 'الجدول الفرعي sqlUpdate2 = "UPDATE Marks SET " For Each fld In rst2.Fields If fld.Name <> "NoMArks" Then 'الحقل المرتبط If Not (fld.Attributes And dbAutoIncrField) Then sqlUpdate2 = sqlUpdate2 & "[" & fld.Name & "] = Null, " End If End If Next fld If Right(sqlUpdate2, 2) = ", " Then sqlUpdate2 = Left(sqlUpdate2, Len(sqlUpdate2) - 2) sqlUpdate2 = sqlUpdate2 & " WHERE NoMArks = " & recordID End If db.Execute sqlUpdate1 db.Execute sqlUpdate2 MsgBox "تمت تصفية بيانات السجل رقم " & recordID & " في الجدولين", vbInformation Me.Requery ExitSub: If Not rst1 Is Nothing Then rst1.Close If Not rst2 Is Nothing Then rst2.Close Set rst1 = Nothing Set rst2 = Nothing Set db = Nothing Exit Sub ErrorHandler: MsgBox "حدث خطأ", vbCritical Resume ExitSub End Sub  

وعليكم السلام ورحمة الله تعالى وبركاته
استخدم الدالة التالية في مديول :-
Function GetAcademicYear() As String Dim currentDate As Date Dim currentYear As Integer Dim nextYear As Integer currentDate = Date currentYear = Year(currentDate) nextYear = currentYear + 1 If currentDate >= DateSerial(currentYear, 9, 1) Then GetAcademicYear = currentYear & " - " & nextYear Else GetAcademicYear = (currentYear - 1) & " - " & currentYear End If End Function في مربع النص اجعل مصدر بياناته =
=GetAcademicYear()  
وتقدر تستخدمه في استعلام على سبيل المثال ، بالشكل التالي :-
SELECT IIf(Date() >= DateSerial(Year(Date()), 9, 1), Year(Date()) & " - " & (Year(Date()) + 1), (Year(Date()) - 1) & " - " & Year(Date())) AS AcademicYear;  
النتيجة :-
1️⃣ إذا كان التاريخ الحالي بعد أو يساوي 1 سبتمبر 2024 ، ستكون النتيجة 2024 - 2025
2️⃣ إذا كان التاريخ الحالي قبل 1 سبتمبر 2024 ، ستكون النتيجة 2023 - 2024
🔚 بهذه الطريقة ، يمكنك الحصول على السنة الدراسية الحالية والسنة اللاحقة بناءً على التاريخ المحدد
 
 
AcademicYear.accdb

جهود جميلة منكم أخي الكريم ، واسمحلي بسؤال يدور في ذهني !!
هل تمت التجربة على هذا الكود ؟؟؟؟؟؟؟؟؟؟؟؟؟

وعليكم السلام ورحمة الله وبركاته ..
جرب هذا التعديل  بالاستعلام التالي  :-
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 txt_AfterUpdate() Dim selectedYear As Integer selectedYear = Me.txt Me.Filter = "[TOTALSHY] = 0 OR ([yearshy] <> '" & selectedYear & "' AND [TOTALSHY] <> 0)" Me.FilterOn = True End Sub  

تم تعديل اسلوب الدالة من المديول على النحو التالي :-
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
* تم حذف الأجزاء السابقة الغير ضرورية لتلافي ظهور رسائل الأخطاء .

بعد تحميل المرفق من الرابط والإطلاع عليه ،اضطررت الى تعديل أصل الكود بحيث يعمل على النواتين 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
 
اخبرنا بالنتيجة 😊 .
 
 
 
 

وعليكم السلام ورحمة الله وبركاته ..
قم بإضافة زر إلى نموذج (مثلاً : 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 

جرب التعديل التالي عله يكون الحل الذي تريده :-
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  

عذراً لمن اتنتظرني بأن أرفق الملف مفتوح المصدر وتأخرت عليه ،،
لن أرفق الأكواد هنا لتعددها وطولها ..
 
GD Uploader.accdb

ما شاء الله عليك ، أبدعت أخي @طاهر اوفيسنا  .
المتبقي بسيط ان شاء الله ، هل هذا طلبك ؟

 
BAR_A(5.3.2025).mdb.zip