Barna

استخدم هذا الكود بدل الموجود لديك ..................
Dim result As String Dim userResponse As VbMsgBoxResult Dim emp As Integer emp = EmployeeID ' استدعاء الدالة للتحقق من الانخراط result = CheckInkhirat(emp) ' عرض النتيجة في رسالة userResponse = MsgBox(result, vbOKOnly + vbInformation, "نتيجة التحقق") ' التحقق من استحقاق الامتياز قبل المتابعة If (result Like "*كاملا*" And Not result Like "*النظارات*") Then ' طلب تأكيد تثبيت المنحة If MsgBox("هل تريد تثبيت تاريخ التعويض الطبي؟", vbYesNo + vbQuestion, "تأكيد") = vbYes Then ' إذا وافق المستخدم، يتم تثبيت التاريخ وإكمال العملية Me.Sanitaire_Date = Date ''Me.Obsérvation = Nom_Moss ''Me.Sanitaire_Value = Me.Montent Else ' إذا رفض المستخدم، يتم التراجع عن أي تغييرات Me.Undo End If Else ' إذا لم يتم استيفاء شروط الانخراط، لا يمكن تثبيت المنحة MsgBox "لا يمكنك تثبيت التعويض الطبي لأن شروط الانخراط غير مستوفاة.", vbExclamation, "تنبيه" Me.Undo End If  

تفضل ......................
Public Function CheckInkhirat(ByRef ID As Integer) As String On Error GoTo err_CheckInkhirat Dim yearNow As Integer Dim totalPaid As Currency Dim paymentMarch As Boolean Dim paymentJuly As Boolean ' تحديد السنة الحالية yearNow = Year(Date) ' إجمالي المبلغ المدفوع ' totalPaid = Nz(DSum("Payment_Made", "tbl_Loans", "EmployeeID = " & ID & " AND Year(Auto_Date) = " & yearNow), 0) totalPaid = Nz(DSum("Payment_Made", "tbl_Loans", "EmployeeID = " & ID & " AND Year(Auto_Date) = " & yearNow & " AND Loan_ID = 0"), 0) ' التحقق من دفع المبلغ في مارس ويوليو paymentMarch = Nz(DLookup("Payment_Made", "tbl_Loans", "EmployeeID = " & ID & " AND Year(Auto_Date) = " & yearNow & " AND Month(Auto_Date) = 3"), 0) = 1500 paymentJuly = Nz(DLookup("Payment_Made", "tbl_Loans", "EmployeeID = " & ID & " AND Year(Auto_Date) = " & yearNow & " AND Month(Auto_Date) = 7"), 0) = 1500 ' التحقق من الشروط If totalPaid = 3000 And paymentMarch = False And paymentJuly = False Then CheckInkhirat = "عزيزي العامل، يمكنك الاستفادة من جميع الامتيازات لأنك دفعت مبلغ الانخراط كاملاً." ElseIf totalPaid = 3000 And paymentMarch = True And paymentJuly = True Then CheckInkhirat = "عزيزي العامل، يمكنك الاستفادة من جميع الامتيازات لأنك دفعت مبلغ الانخراط كاملاً على دفعتين." Else CheckInkhirat = "عزيزي العامل، لا يمكنك الاستفادة من الامتيازات لأنك لم تدفع مبلغ الانخراط." End If Exit Function err_CheckInkhirat: MsgBox "خطأ رقم " & Err.Number & ": " & Err.Description, vbCritical, "خطأ" CheckInkhirat = "حدث خطأ أثناء التحقق من بيانات الانخراط." End Function  

جرب هذا .....
Dim rst As DAO.Recordset Dim biggest_Number As Long Dim i As Long Dim RC As Long biggest_Number = Len(DMax("[num]", "fnumber")) Set rst = CurrentDb.OpenRecordset("Select * From fnumber") rst.MoveLast: rst.MoveFirst RC = rst.RecordCount For i = 0 To RC - 1 rst.Edit rst!num = 1 + i rst.Update rst.MoveNext Next i rst.Close: Set rst = Nothing MsgBox "Done"  

تفضل ملفك بعد التعديل ......................
 
base_r_BAR.accdb

طيب جرب واعلمنا بالنتيجة ..... استخدم هذا الامر تحت زر تفريغ على الجدول .....
 
Dim strField As String Dim regex As Object Dim matches As Object Dim match As Variant Dim cleanedValue As String Dim FullText As String Dim FirstPhrase, SecondPhrase As String Dim RemainingText As String Set regex = CreateObject("VBScript.RegExp") regex.Global = True regex.IgnoreCase = True strField = Me.a regex.Pattern = "الوزن:\d+|\d+\s*\$\s*اجار شاحنة|\d+\s*\$\s*عمال|\d+\s*\$\s*رسوم|\d+\s*\$\s*وصل|\d+\s*\$\s*خدمات|العدد:\d+" Set matches = regex.Execute(strField) FirstPhrase = Split(strField, "المادة")(0) SecondPhrase = Split(strField, "العدد")(0) RemainingText = Replace(SecondPhrase, FirstPhrase & "المادة", "") FirstPhrase = Replace(FirstPhrase, "السيد", "") DoCmd.OpenForm "Test1", , , , acFormAdd Forms!Test1.Form.Recordset.AddNew For Each match In matches cleanedValue = Replace(match.Value, "$", "") cleanedValue = Replace(cleanedValue, "الوزن:", "") cleanedValue = Replace(cleanedValue, "رسوم", "") cleanedValue = Replace(cleanedValue, "وصل", "") cleanedValue = Replace(cleanedValue, "خدمات", "") cleanedValue = Replace(cleanedValue, "عمال", "") cleanedValue = Replace(cleanedValue, "اجار شاحنة", "") cleanedValue = Replace(cleanedValue, "العدد:", "") cleanedValue = Trim(cleanedValue) If InStr(match.Value, "الوزن:") > 0 Then Forms![Test1]![d].Value = cleanedValue ElseIf InStr(match.Value, "عمال") > 0 Then Forms![Test1]![g].Value = cleanedValue ElseIf InStr(match.Value, "وصل") > 0 Then Forms![Test1]![e].Value = cleanedValue ElseIf InStr(match.Value, "خدمات") > 0 Then Forms![Test1]![f].Value = cleanedValue ElseIf InStr(match.Value, "اجار شاحنة") > 0 Then Forms![Test1]![h].Value = cleanedValue ElseIf InStr(match.Value, "العدد:") > 0 Then Forms![Test1]![c].Value = cleanedValue End If Next match Forms![Test1]![a].Value = FirstPhrase Forms![Test1]![b].Value = RemainingText  

اولا ::: هناك اخطاء لديك لانك استخدمت بعض الكلمات المحجوزة للاكسس
ثانيا :::: اقتنصت بعض الاكواد من الخبير @jjafferr فله الشكر والعرفان
جرب المرفق ربما هو المطلوب .
 
Change by One Button.accdb

طبق ما في الصورة مع استخدام هذا .........
Me.نص1595 = DCount("[الرقم]", "[مذكرة]", "[الرمز] ='" & [Forms]![memoire]![الرمز] & "'") Me.نص1597 = DMax("[الرقم]", "[مذكرة]", "[الرمز] ='" & [Forms]![memoire]![الرمز] & "'")  

افتح التقرير في وضع التصمبم ونفذ ......
 

Database3.accdb

Dim db As DAO.Database Dim rs As DAO.Recordset Dim fld As DAO.Field Dim searchNumber As Long Dim found As Boolean searchNumber = Me.C Set db = CurrentDb() Set rs = db.OpenRecordset("SELECT Salary.GradeNO, Salary.[1], Salary.[2], Salary.[3], Salary.[4], Salary.[5] FROM Salary ORDER BY Salary.GradeNO DESC;", dbOpenDynaset) i = 0 found = False Do Until rs.EOF For Each fld In rs.Fields If Not IsNull(fld.Value) And fld.Value = searchNumber Then found = True ElseIf found And Not IsNull(fld.Value) And i < Me.D And fld.Name <> "GradeNO" Then i = i + 1 Me.G = fld.Value Me.E = rs!GradeNO Me.F = fld.Name End If Next fld rs.MoveNext Loop rs.Close Set rs = Nothing Set db = Nothing  

طيب جرب على حالات اخرى ....
Dim db As DAO.Database Dim rs As DAO.Recordset Dim i, TT As Integer Dim numCopies As Integer Set db = CurrentDb Set rs = db.OpenRecordset("SELECT tp2.GradeNO, tp2.سنوات_المكوث FROM tp2 WHERE (((tp2.GradeNO)<=" & Me.الدرجة_الوظيفية & ")) ORDER BY tp2.GradeNO DESC;", dbOpenDynaset) TT = iYear Do Until rs.EOF TT = TT - rs!سنوات_المكوث numCopies = rs!سنوات_المكوث If TT < rs!سنوات_المكوث Then Me.مربع_تحرير_وسرد47 = rs!GradeNO - 1 Me.مربع_تحرير_وسرد49 = Me.المرحلة_الوظيفية + TT rs.MoveNext GoTo RR 'Exit Sub End If For i = 1 To numCopies Next i rs.MoveNext Loop RR: If Me.مربع_تحرير_وسرد49 > rs!سنوات_المكوث Then Me.مربع_تحرير_وسرد47 = rs!GradeNO - 1 Me.مربع_تحرير_وسرد49 = 1 Exit Sub End If rs.Close Set rs = Nothing Set db = Nothing  

تفضل استاذ @Ahmed_J >>> ربما يلبي طلبك .....
 

301.Dates_Calculations2.mdb

تفضل جرب ................
 
التقرير الشهري للغياب.accdb

بارك الله فيك .....
انظر الصورة لهذا الموظف قبل التحديث وبعد التحديث ( هل هذا هو المطلوب ) ؟؟؟؟؟؟
جرب المرفق واعلمنا بالنتيجة .....


الغياب والتاخير.accdb

للاسف ليس لدي سكنر ... جرب واعلمنا ..........
Public Function SelectScanner() Dim ComDialog As New WIA.CommonDialog Dim wiaScanner As WIA.Device ' عرض نافذة لاختيار الجهاز Set wiaScanner = ComDialog.ShowSelectDevice(WiaDeviceType.ScannerDeviceType, False, True) ' إذا تم اختيار جهاز، فإن DeviceID سيحتوي على معرف الجهاز المحدد If Not wiaScanner Is Nothing Then MsgBox "تم اختيار الجهاز: " & wiaScanner.DeviceID Else MsgBox "لم يتم اختيار أي جهاز." End If End Function يتطلب إضافة مرجع إلى “Microsoft Windows Image Acquisition Library v2.0

Sub InsertYears() Dim rsSource As DAO.Recordset Dim rsTarget As DAO.Recordset Dim StartDate As Date Dim EndDate As Date Dim iYear As Integer DoCmd.SetWarnings False DoCmd.RunSQL "DELETE TEMP_DATE.* FROM TEMP_DATE;" DoCmd.SetWarnings True Set rsSource = CurrentDb.OpenRecordset("date1") Set rsTarget = CurrentDb.OpenRecordset("TEMP_DATE") Do Until rsSource.EOF StartDate = rsSource!t2 EndDate = rsSource!t3 For iYear = Year(StartDate) To Year(EndDate) rsTarget.AddNew rsTarget!t2 = CStr(iYear) rsTarget!t1 = rsSource!t1 rsTarget.Update Next iYear rsSource.MoveNext Loop rsSource.Close rsTarget.Close Set rsSource = Nothing Set rsTarget = Nothing End Sub  

هل هذا طلبك حسب فهمي للموضوع ....
 

2023.mdb

مشاركة مع استاذي الغالي @Eng.Qassim
تفضل ......
 
المهن التربوية.accdb

وعليكم السلام اخي الفاضل
لم افهم جيدا لسؤالك ولكن هل تقصد هذا الخيار ؟؟؟؟ ملف .... ثم تابع الصور ...
 
 

امين واياك ....... طيب تفضل شوف كده
استخدمنا هذه الاكواد ...
Public Function PctMeter(varAmt As Variant, varTotal As Variant) Dim sngPct As Single sngPct = varAmt / varTotal If sngPct <= 1 Then Me!baselbl.Caption = Int(sngPct * 100) Me!lblmeter.Width = CLng(Me!baselbl.Width * sngPct) Else Me!baselbl.Caption = " القيمة أكبر من 100%" Me!lblmeter.Width = CLng(Me!baselbl.Width * 1) End If Select Case sngPct Case Is < 0.15 Me!lblmeter.BackColor = 255 Me.red_p.Visible = True Me.gre_p.Visible = False Me.yel_p.Visible = False Case Is < 0.5 Me!lblmeter.BackColor = 65535 Me.red_p.Visible = False Me.gre_p.Visible = False Me.yel_p.Visible = True Case Else Me!lblmeter.BackColor = 65280 Me.red_p.Visible = False Me.gre_p.Visible = True Me.yel_p.Visible = False End Select End Function Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer) i = 1 For i = i To 5 If (Me("Text" & 19 + i) / Me.Text25) * 100 < 20 Then Me(i & "_red").Visible = True Me(i & "_ger").Visible = False Me(i & "_yel").Visible = False ElseIf (Me("Text" & 19 + i) / Me.Text25) * 100 > 20 Then Me(i & "_red").Visible = False Me(i & "_ger").Visible = True Me(i & "_yel").Visible = False End If Next i Call PctMeter(Me.bar, 100) End Sub  
 
New Database - .accdb

طيب جرب هذا <|<><><><><><|>
Dim rst As DAO.Recordset Set dbs = CurrentDb date_custom = Date If Len(Me.number_custom & "") <> 0 Then Exit Sub Me.number_custom = Nz(DMax("[number_custom]", "tbl_custom", "year([date_custom])=" & Year(date_custom)), 0) + 1 Set rst = dbs.OpenRecordset("FrmRretsQ") d = Me.number_custom DoCmd.RunCommand acCmdSaveRecord Do Until rst.EOF rst.Edit rst!number_custom = d rst!date_custom = Date rst!emp_company = DYear rst.Update d = d + 1 rst.MoveNext Loop Me.Requery  

اعتقد عندك مشكلة في العلاقات .... حاول ترتجعها .... على العموم هل هذا ما تريد .....
 
solaf2.accdb

مشاركة مع الاستاذ @دروب مبرمج
في حدث الحالي للنموذج الفرعي الاول ضع هذا الحدث ......
Dim rs As DAO.Recordset On Error Resume Next Set rs = Me.RecordsetClone rs.FindFirst "[ItemNumber] = " & Me![ItemNumber] Me.Parent.FrmSubInvoice.Form.Bookmark = rs.Bookmark  

اخي محمد جرب الكود التالي في حدث تحت الزر ....
Dim a As Integer a = Forms![test1]![NumberEnd] Me("LastNumberx" & a) = Forms![test1]![NumberEnd]