Moosak

هذه مشاركتي 🙂 Private Sub Months_AfterUpdate() If Me.Months = "6 شهور" Then Me.End = DateAdd("M", 6, Me.Start) End If If Me.Months = "سنة" Then Me.End = DateAdd("M", 12, Me.Start) End If End Sub DateAdd.accdb

هذا الحل الذي أعددته في حال أن الأخ @elghoultk قال أن حقل النص بهذه الطريقة ( 15 - 20) .. ولكن قد سبقني بها عكاشة @kanory 😅 الحل أن تضع هذه الدالة في محرر الأكواد : Public Sub Check(FiledName As Control) Dim X As Integer Dim Count As Integer Dim TL As Integer Dim L As String TL = Len(FiledName) For X = 1 To TL L = Mid(FiledName, X, 1) If IsNumeric(L) = True Then If L > 5 Then Count = Count + 1 End If End If Next X If Count > 0 Then FiledName.FontBold = True FiledName.ForeColor = vbRed Else FiledName.FontBold = False FiledName.ForeColor = vbBlack End If End Sub ثم تناديها عند حدث بعد التغيير لمربع النص + وكذلك عند حدث في الحالي للنموذج .. هكذا : ( ولا تنسى تغيير اسم مربع النص ) 🙂 Private Sub Form_Current() If IsNull(Me.NumberxTxt) Then Exit Sub Check NumberxTxt End Sub Private Sub NumberxTxt_AfterUpdate() Check NumberxTxt End Sub والنتيجة عند عدم وجود رقم أكبر من الخمسة : وعند تحقق المطلوب : مرفق المثال : الرقم 5.accdb

اعمل تنسيق شرطي للخلية أخي العزيز .. بحيث لوكان قيمة مربع النص >5 يكون الخط سميك .. هذا حسب ما فهمته على فرض أن محتوى الخلية كله أرقام ، إلا إن كان قصدك أن محتوى الخلية يكون عبارة عن نص هكذا = ( 15 - 20) ؟ فالحل سيكون مختلف . للتكرم بالتوضيح .

تفضل أخي أحمد أحمد أحمد 🙂 ضع هذا الكود في موديول : Public Sub TakeBackup() On Error GoTo MyErr Dim OldFile, NewFile, CopyMyDB, wheretoBackup, BackupFolder, DBName As String OldFile = CurrentProject.FullName BackupFolder = SelectFolder DBName = Left(CurrentProject.Name, InStrRev(CurrentProject.Name, ".") - 1) NewFile = BackupFolder & "\" & DBName & "-Backup-" & Format(Date, "dd-mm-yyyy") & "-" & Format(Now(), "Hh-Nn-ss-AMPM.") & Right(OldFile, 5) CopyMyDB = "cmd.exe /C copy " & """" & OldFile & """" & " " & """" & NewFile & """" Shell CopyMyDB, 0 MsgBox "Backup........Done" & vbNewLine & vbNewLine & "Saved in :" & vbNewLine & NewFile, , " " MyErr: If Err.Number <> 0 Then MsgBox Err.Number & " - " & Err.Description End If End Sub Public Function SelectFolder() On Error GoTo ErrorHandler Dim FileDialog As Object Dim sPath As String Dim sFile As String Set FileDialog = Access.Application.FileDialog(4) With FileDialog .AllowMultiSelect = False .Filters.Clear .Show .Title = "Please select folder" SelectFolder = .SelectedItems(1) End With ExitHandler: Exit Function ErrorHandler: Select Case Err.Number Case Is = 5 MsgBox ChrW("1604") & ChrW("1602") & ChrW("1583") & ChrW("32") & ChrW("1578") & ChrW("1605") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1594") & ChrW("1575") & ChrW("1569") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1575") & ChrW("1605") & ChrW("1585") & ChrW("32") & ChrW("46") & ChrW("46") & ChrW("46") & ChrW("32") & ChrW("40") & ChrW("32") & ChrW("1604") & ChrW("1605") & ChrW("32") & ChrW("1578") & ChrW("1602") & ChrW("1605") & ChrW("32") & ChrW("1576") & ChrW("1578") & ChrW("1582") & ChrW("1583") & ChrW("1610") & ChrW("1583") & ChrW("32") & ChrW("1571") & ChrW("1609") & ChrW("32") & ChrW("1605") & ChrW("1587") & ChrW("1575") & ChrW("1585") & ChrW("41") _ , vbMsgBoxRight + vbMsgBoxRtlReading, _ ChrW("1578") & ChrW("1606") & ChrW("1576") & ChrW("1610") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("40") & ChrW("32") & ChrW("65") & ChrW("116") & ChrW("116") & ChrW("101") & ChrW("110") & ChrW("116") & ChrW("105") & ChrW("111") & ChrW("110") & ChrW("32") & ChrW("41") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1607") Case Else MsgBox "Error Number : " & Err.Number & vbNewLine & "Error Description : " & Err.Description Resume ExitHandler End Select End Function ثم قم باستدعائه هكذا : Call TakeBackup()

ببساطة يا عزيزنا @elghoultk .. تنسخ الدالة ( لكل ليبل الدالة الخاصة به ) .. وتغير اسم الدالة والبيانات اللي فيها حسب المطلوب .. وتحط نداء كل دالة في حدث عند التغيير للعناصر الثلاثة وفي الحالي للنموذج .. أو للخطوة الأخيرة تعمل دالة ثانية أو روتين عام تحط فيها النداءات كلها وبعدين تنادي الروتين مرة وحدة في حدث عند التغيير . إن شاء الله يكون واضح 😁 وبالمثال يتضح المقال 🙂

تفضل أخي تم التعديل .. الحل يكمن في أنه عليك ضبط عنوان القائمة المنسدلة في الاستعلام بالعنوان الجديد بعدما أصبح النموذج FORM_G كنموذج فرعي لنموذج التنقل .. وهذا هو العنوان الجديد الذي تم تعديله : [FORMS]![نموذج_التنقل]![z].[Form]![حقل 70] الملف بعد التعديل : Service.accdb

تفضل أخي .. تضع هذه المعادلة في محرر الأكواد : Private Function LableValue() As String If Me.age >= 13 And Me.age <= 150 And Me.Age2 = "YEARS" And Me.gender = "male" Then LableValue = "( 17- 13)" End If If Me.age >= 13 And Me.age <= 150 And Me.Age2 = "YEARS" And Me.gender = "female" Then LableValue = "( 16- 12)" End If If Me.age >= 2 And Me.age <= 12 And Me.Age2 = "YEARS" Then LableValue = "( 15- 11.5)" End If End Function ثم تضع جملة النداء لها بعد تحديث الحقول الثلاثة وكذلك في حدث الحالي لنموذج بهذه الطريقة : Private Sub age_AfterUpdate() Me.Label3.Caption = LableValue End Sub Private Sub Form_Current() Me.Label3.Caption = LableValue End Sub Private Sub gender_AfterUpdate() Me.Label3.Caption = LableValue End Sub Private Sub Text6_AfterUpdate() Me.Label3.Caption = LableValue End Sub وهذا هو المرفق بعد التطبيق : تحديث الليبل.accdb

بعد التعديل اشتغل تمام 👍🏼🙂 بارك الله فيك دكتور

أولا أشكرك أخي العزيز .. جهود طيبة إن شاء الله .. لكن عندي ثلاث ملاحظات .. الأولى : برنامج الواتسأب يقف عند كتابة الرسالة ولا يقوم بعملية الإرسال : ثانيا : مربع البحث لايعمل ثالثا : أنا أعمل على نواة 64 بت فاضررت لإضافة PtrSafe على هذه الجمل : Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" (ByVal _ hHandle As Long, ByVal dwMilliseconds As Long) As Long Private Declare PtrSafe Function CreateProcessA Lib "kernel32" (ByVal _ lpApplicationName As Long, ByVal lpCommandLine As String, ByVal _ lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _ ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _ ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, _ lpStartupInfo As STARTUPINFO, lpProcessInformation As _ PROCESS_INFORMATION) As Long Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal _ hObject As Long) As Long

وجدت هذا الموضوع في مكتبة الموقع :

...

إمضِ قُدما باش مهندس عمر .. 👍🏻🙂 أحييك على هذه الأفكار ✌🏻️

فكرة رائعة باش مهندس .. بارك الله فيك 🌹😊 فقط لاحظت أن زر الحذف يعمل في حال الحماية .. ربما من الأفضل منع الحذف أيضا 🙂

مثل ما قال الأستاذ ناقل + عمل تنسيق شرطي لتلوين الكومبوبوكس إذا كان فاضي 😁

هذا هو الرابط : https://drive.google.com/file/d/1wfb_sWZGIgooWAApnkGk4emJCSXT9Ho2/view ويمكنك تحميله من هنا لو تعذر الرابط : برنامج الحضور والانصراف.rar

مبارك عليك أخي عمر 🙂🌷🌹

اللهم آمين .. وإياكم

رائع ما شاء الله عليك أخي @Amr Ashraf فكرة جميلة من شأنها أن تبسط تصميم النماذج .. 🙂

تم الإصلاح أخي كناري .. وتأكد دائما أنك تعطي الموديول أسماً مختلف عن اسم الدالة .. وإلا فستحصل على رسالة خطأ .. Database1.rar

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

يمكنك فعل ذالك عن طريق هذه الدالة dlookupPlus وهي من عمل أحد الإخوة جزاه الله خيرا .. وقد أخذتها من قناته في اليوتيوب .. وظيفتها هي القيام بإحضار جميع القيم الفرعية الخاصة بسجل رئيسي معين .. وليس فقط القيمة الأولى مثل ما هو الحال عند دالة Dlookup المعتادة . أولا : ضع هذه الدالة في موديول : Function dlookupPlus(Fieldname As String, Domain As String, Optional Criteria = "") Dim db As dao.Database Dim rs As Recordset Dim strsql As String Dim i As Integer Dim st, stt As String On Error GoTo dlookup_err Fieldname = Trim(Fieldname): Domain = Trim(Domain) If IsNull(Criteria) Or Criteria = "" Then strsql = "select " & Fieldname & " from " & Domain Else Criteria = Trim(Criteria) strsql = "select " & Fieldname & " from " & Domain & " where " & Criteria End If Debug.Print "StrSql >> " & strsql Set db = CurrentDb Set rs = db.OpenRecordset(strsql, dbOpenDynaset) rs.MoveLast rs.MoveFirst Debug.Print rs.RecordCount For i = 0 To rs.RecordCount - 1 st = rs(Fieldname).Value & " , " stt = stt & st ' Debug.Print "stt" & stt rs.MoveNext Next dlookupPlus = Left(stt, Len(stt) - 2) dlookup_err: Exit Function End Function ثانيا : استخدمها بنفس طريقة استخدامك لدالة Dlookup العادية ولكن بالمسمى الجديد ( والشرط يكون رقم الفاتورة مثلا ) هكذا : dlookupPlus("Nots","TableName","[FatoorhID]=" & Me.FatoorhID ) طبعا تضع الكود أعلاه كمصدر بيانات مربع النص الذي تريد جمع الملاحظات فيه .

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

تفضل أخي .. قمت بنقل الكود لحدث عند النقر بدل عند التركيز .. ثم قمت بإضافة الشرط والرسالة ليصبح هكذا : Private Sub comm_ex_Click() On Error Resume Next Dim X As Object Dim objWord As Object Set X = CreateObject("Word.Application") Me.Refresh If Me.تدقيق7 = -1 Then 'Continue Else MsgBox "يجب التحديد للقيام بعملية التصدير", vbOKOnly, "تنبيه !" Exit Sub End If X.Documents.Open CurrentProject.Path & "\word_ex.docx" X.Visible = True X.ActiveDocument.Bookmarks("G").Select X.Selection.InsertAfter G End Sub الملف : مثال تصدير إلى ملف وورد 05-07-1443 --15-17.rar

أتوقع أن السر في الماكرو After Update و After Insert و After delet المصاحبة للجداول والله أعلم 😅✋🏻

لك جزيل الشكر معلمنا 🙂 ..