ناقل

وعليكم السلام ورحمة الله وبركاته عن نفسي ... حاولت افهم آلية عمل برنامجك وعجزت فعل ذلك ... لانه من الصعب وضع اكواد وانت لم تفهم الآلية ... هل عند الاقتطاع يتم ادراج سجل جديد ام يتم تحديث نفس السجلات وايضا دفع الانخراط ... ماذا تريد انت من الكود أن يفعل ،???? لذلك توقفت عن الإجابة ...

جميل جدا ..... بارك الله فيك ... ماشاء الله تبارك الله دائما مبدع .... انا الحقيقة انشغل في برنامج خاص بي .. لكنك سبقت واجدت المطلوب

ارنا محاولاتك ... وبعدها نحاول معك

جرب .............. Private Sub cmd_Pay_installments_Click() On Error GoTo err_cmd_Pay_installments_Click ' .......................... الشطر الاول اقتطاع القروض Dim rst As DAO.Recordset 'Cridi and Elec Payments Set rst = CurrentDb.OpenRecordset("Select * From tbl_Loans Where [Payment_Month]=CDATE('" & Me.txtMonth & "')") rst.MoveLast: rst.MoveFirst Rc = rst.RecordCount a1 = 0 'just a flag a2 = 0 'just a flag If Rc = 0 Then MsgBox " لا توجد إقتطاعات لشهر " & Format(Me.txtMonth, "mmmm") & " " & Year(Me.txtMonth), vbInformation Exit Sub End If If Len(rst!Payment_Made & "") = 0 And Not IsNull(rst!Loan_Made) Then Select Case MsgBox("هل تريد أن يتم توزيع الإقتطاعات لشهر " & Me.txtMonth, vbYesNo + vbQuestion + vbDefaultButton1) Case vbYes For i = 1 To Rc rst.Edit If rst!Nr >= 6 Then rst!Payment_Made = 0# Else If rst!Loan_Type = "Cridi" Then rst!Payment_Made = rst!Loan_Made rst!sadad = rst!Loan_Made rst!Loan_Remise = 0 End If If rst!Loan_Type = "Elec" Then rst!Payment_Made = rst!Loan_Made rst!sadad = rst!Loan_Made rst!Loan_Remise = 0 End If End If If rst!sadad.Value = True Then rst!wada3 = "تم التسديد" Else rst!wada3 = "لم يتم التسديد" End If TheSum = TheSum + Nz(rst!Payment_Made, 0) rst.Update rst.MoveNext Next i ' .......................... الشطر الثاني اقتطاع الانخراط 'Other loans for March (3) and July (7) If Month(Now()) = 3 Or Month(Now()) = 7 Then Dim rstE As DAO.Recordset Set rst = CurrentDb.OpenRecordset("Select * From tbl_Loans") myCriteria = "([detach]='موظف'" myCriteria = myCriteria & " Or [detach]='عامل متعاقد توقيت كامل'" myCriteria = myCriteria & " Or [detach]='عامل متعاقد توقيت جزئي'" myCriteria = myCriteria & " Or [detach]='حارس متعاقد توقيت جزئي'" myCriteria = myCriteria & " Or [detach]='عون نظافه وتطهير')" Set rstE = CurrentDb.OpenRecordset("Select * From Employee Where " & myCriteria) rstE.MoveLast: rstE.MoveFirst Rc = rstE.RecordCount For i = 1 To Rc ' استثناء الموظف الذي دفع 3000 If Nz(DLookup("Payment_Made", "tbl_Loans", "EmployeeID=" & rstE!EmployeeID & " And [Payment_Made]=3000 And [Payment_Month]=#" & Me.txtMonth & "#"), 0) <> 3000 Then rst.FindFirst "[Loan_Type]='Inkhirat' And [EmployeeID]=" & rstE!EmployeeID & " And [Payment_Month]=#" & Me.txtMonth & "#" If rst.NoMatch Then rst.AddNew a2 = 1 rst!EmployeeID = rstE!EmployeeID rst!Loan_ID = 0 rst!Payment_Month = DateSerial(Year(Me.txtMonth), Month(Me.txtMonth), 1) rst!Payment_Made = DLookup("Other_Value", "TblOther", "ID=1") rst!Loan_Type = "Inkhirat" rst!Nr = GetNumDetach(rst!EmployeeID) rst!Remarks = "إقتطاع من الراتب لإنخراط شهر " & Year(Me.txtMonth) & "/" & Month(Me.txtMonth) rst!annee = Year(Date) If rst!Loan_Type = "Inkhirat" Then rst!sadad = rst!Payment_Made If rst!sadad.Value = True Then rst!wada3 = "تم الإنخراط" Else rst!wada3 = "لم يتم الإنخراط" End If End If TheSum = TheSum + Nz(rst!Payment_Made, 0) rst.Update End If rstE.MoveNext Next i rstE.Close: Set rstE = Nothing End If TheSum = Format(TheSum, "#,##0.00") MsgBox " " & "تم توزيع الإقتطاعات" & vbLf & vbLf & "مجموع الإقتطاعات = " & TheSum, , "إقتطاعات شهر" & FrenchMonth(Month(Date)) & Year(Date) I_am_Done: Case vbNo MsgBox "لم يتم توزيع الإقتطاعات" End Select rst.Close: Set rst = Nothing End If Exit Sub err_cmd_Pay_installments_Click: If Err.Number = 3021 Then Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description End If End Sub

انا فتحت النموذج طيب بعدين .... كيف يعمل برنامجك .... لكي نرى النتيجة ؟؟؟؟؟؟؟؟؟؟؟؟ في حال محاولة التشغيل يتوقف على Abou_Taha مما هذه ؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟

انت بحاجة الى نظام صلاحيات مجموعات ........ انظر المثال

اخي @كريمو2 المسألة ليس كلام صعوبة ولكن معليش حبه حبه ...... ارفق الملف الاخير الذي توصلت اليه ... ثم اعرض مطلوبك ... لاني تهت بين الردود الاكواد ....

جرب المرفق .... Test (30).accdb

تفضل جرب المرفق Test (30).accdb

هذا التصور العام لها بارك الله في .... يتبقى الترجمة لاكواد ....

جرب المرفق .... Test (29).accdb

يعني انت تريد بعد العمليات السابقة حذف السعر المدخل سابقا وتريد نقل السعر الموجود في التوزيع ليحل محل السعر السابق ... انظر الصورة

اولا الشكر لك على هذه التحفة الفنية ..... ثانيا ان سمحت لي باقتباس هذه الساعة ... اريد تحويرها لارقام طلب الدور للعملاء والمطاعم وغيرها ان سمحت لي ...

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

ليس صحيح ..... بل هو استعلام واحد .... وتقوم بعمل نموذج من خلاله تحدد الصف و الفصل المطلوب عن طريق كمبوبكس فقط ...

تفضل انظر الاستعلام الجديد البحث وتعديل درجات10.rar

قمت لاحظ الاستعلام قام بتصفية الصف الاول واضفت طالب وسام ذكر وقام الاستعلام بترتيبة .... هل هذا الترتيب هو المطلوب لديك ؟؟؟

بعد اذنك سيد @Foksh ممكن عمل ذلك عن طريق النموذج أو التقرير دون الحاجة لطريقتك هذه

مشاركة Sub ClearClipboardAndFreeMemory() ' تحرير محتوى الحافظة On Error Resume Next Dim DataObject As Object Set DataObject = CreateObject("MSForms.DataObject") DataObject.SetText "" DataObject.PutInClipboard Set DataObject = Nothing On Error GoTo 0 ' تحرير الذاكرة DoEvents Application.Echo True, "Memory cleared" End Sub

جرب هذا .... Private Sub Form_Open(Cancel As Integer) Me.OrderBy = "fega ASC" ' للفرز تصاعديًا Me.OrderByOn = True End Sub Private Sub Form_Current() Me.OrderBy = "fega ASC" ' للفرز تصاعديًا Me.OrderByOn = True End Sub

جرب واعلمنا ... لاني لم اجربه #If VBA7 Then Private Declare PtrSafe Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" (ByVal lpFileName As String) As Long Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Const HWND_BROADCAST As LongPtr = &HFFFF& #Else Private Declare Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" (ByVal lpFileName As String) As Long Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Const HWND_BROADCAST As Long = &HFFFF& #End If Private Const WM_FONTCHANGE As Long = &H1D Sub InstallFonts() Dim dbPath As String Dim fontsFolder As String Dim fontFile As String Dim fontName As String Dim fso As Object Dim folder As Object Dim file As Object Dim fontInstalled As Boolean ' الحصول على مسار قاعدة البيانات ومجلد الخطوط dbPath = CurrentProject.Path fontsFolder = dbPath & "\الخطوط" ' التحقق إذا كان مجلد الخطوط موجودًا Set fso = CreateObject("Scripting.FileSystemObject") If Not fso.FolderExists(fontsFolder) Then MsgBox "مجلد الخطوط غير موجود: " & fontsFolder, vbExclamation Exit Sub End If ' تصفح الخطوط في المجلد Set folder = fso.GetFolder(fontsFolder) For Each file In folder.Files If LCase(Right(file.Name, 4)) = ".ttf" Or LCase(Right(file.Name, 4)) = ".otf" Then fontFile = file.Path fontName = GetFontName(fontFile) ' التحقق إذا كان الخط مثبتًا fontInstalled = IsFontInstalled(fontName) If Not fontInstalled Then If AddFontResource(fontFile) > 0 Then ' تحديث النظام لإضافة الخط SendMessage HWND_BROADCAST, WM_FONTCHANGE, 0, 0 MsgBox "تم تثبيت الخط: " & fontName, vbInformation Else MsgBox "فشل في تثبيت الخط: " & fontName, vbExclamation End If End If End If Next file MsgBox "اكتمل التحقق من الخطوط.", vbInformation End Sub Function IsFontInstalled(fontName As String) As Boolean Dim regPath As String Dim objRegistry As Object On Error Resume Next regPath = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts" Set objRegistry = CreateObject("WScript.Shell") IsFontInstalled = Not IsEmpty(objRegistry.RegRead(regPath & "\" & fontName & " (TrueType)")) On Error GoTo 0 End Function Function GetFontName(fontFile As String) As String ' استرجاع اسم الملف بدون الامتداد GetFontName = CreateObject("Scripting.FileSystemObject").GetBaseName(fontFile) End Function

تفضل ... Me.Caption =DLookUp("[school]";"Tbl_basic") في حدث عند تحميل النموذج

تفضل .............. Dim UserInput As String Dim IsValid As Boolean ' احصل على النص المدخل UserInput = Me.y.Value ' تحقق من وجود حروف وأرقام فقط IsValid = Not UserInput Like "*[!A-Za-z0-9]*" And _ UserInput Like "*[A-Za-z]*" And _ UserInput Like "*[0-9]*" If IsValid Then ' أغلق النموذج إذا كان الإدخال صحيحًا DoCmd.Close Else ' إظهار رسالة خطأ MsgBox "الرقم المدخل غير صحيح. يجب أن يحتوي الإدخال على حروف وأرقام فقط.", vbCritical, "خطأ" ' تفريغ مربع النص Me.y.Value = "" End If

امين واياك ... منكم تعلمنا بارك الله فيك وفي علمك حياك اخي الكريم ... في الخدمه

جرب المرفق open.accdb Private Sub Form_Load() Call CopyText("Pa@ 12345678") End Sub Public Function CopyText(ByVal Text As Variant) As Boolean CopyText = CreateObject("htmlfile").ParentWindow.ClipboardData.SetData("Text", Text) End Function