كل الانشطه

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

بعد التجربة هذا السطر لا ولن يعمل Forms(frm.Name).Detail.BackColor أكسس لا يدعمه ما رأيك ابو البشر لو تم عمل دالة للألوان تشمل جميع مقاطع النموذج وعناصره .. وتكون العناصر حسب المقطع فمثلا لو اردت ان لون خلفية الرأس والذيل تختلف عن التفاصيل .. فمؤكد ان خلفية العناصر او اللون الأمامي سيختلف من مقطع لآخر احب دوما البرنامج عندما اتصفحه ان تكون النماذج صورة طبق الأصل من بعض .. من اجل راحة النفس والعين على فكرة : حاجتي انقضت بفضل الله ثم فضلك فجزاك الله خيرا

بارك الله بكم استاذي الفاضل 😇.. شكراً لك 💐

جربت كلها تعمل ويبدو ان الثاني افضل كونه يعمل بالخفاء ................................. ولكن الاخير شامل كامل .. فقط من رؤيته وقبل ان اجرب بارك الله فيك وزادك علما .. الف شكر

طيب جرب هذا .... Public Function ModifyFormsBackground() Dim frm As Object Dim ctl As Control For Each frm In CurrentProject.AllForms ' افتح النموذج في وضع التصميم DoCmd.OpenForm frm.Name, acDesign ' تغيير لون خلفية مقطع التفاصيل Forms(frm.Name).Detail.BackColor = RGB(240, 240, 240) ' لون فاتح رمادي ' تغيير خلفية العناصر داخل مقطع التفاصيل For Each ctl In Forms(frm.Name).Detail.Controls ' تغيير خلفية العناصر حسب نوعها Select Case ctl.ControlType Case acTextBox, acComboBox, acListBox, acCheckBox ctl.BackColor = RGB(255, 255, 255) ' أبيض Case acLabel ctl.BackColor = RGB(240, 240, 240) ' نفس لون خلفية المقطع ctl.BackStyle = 1 ' خلفية معتمة End Select Next ctl ' احفظ وأغلق النموذج DoCmd.Close acForm, frm.Name, acSaveYes Next End Function

وهذا ايضا Public Function ChangeFormsDetailBackColor() On Error Resume Next Dim objForm As AccessObject Dim frm As Form Dim newColor As Long newColor = RGB(230, 255, 230) ' لون أخضر فاتح - يمكنك تغييره For Each objForm In CurrentProject.AllForms DoCmd.OpenForm objForm.Name, acDesign, , , , acHidden Set frm = Forms(objForm.Name) If Not frm Is Nothing Then ' تحقق من وجود مقطع التفاصيل If frm.Section(acDetail).Visible Then frm.Section(acDetail).BackColor = newColor End If DoCmd.Close acForm, objForm.Name, acSaveYes End If Next objForm Set frm = Nothing End Function عفوا لم انته للتعدي ... يبدو ردي وقت التعديل

اهلا ابو البشر سوف اجرب مشكورا ولكني اجريت تعديلا بسيطا على السؤال .. كرما وفضلا ارجع اليه

لم اجرب الكود ... جرب استاذنا الغالي التعديل التالي Public Function funforms() Dim frm As Object Dim frmDesign As Form For Each frm In CurrentProject.AllForms DoCmd.OpenForm frm.Name, acDesign Set frmDesign = Forms(frm.Name) ' تغيير خصائص النموذج frmDesign.PopUp = True ' تغيير لون خلفية مقطع التفاصيل (مثلاً إلى لون رمادي فاتح) frmDesign.Section(acDetail).BackColor = RGB(240, 240, 240) DoCmd.Close acForm, frm.Name, acSaveYes Next frm End Function تأكد من أن جميع النماذج ليست مفتوحة في وضع "عرض" أو "تصميم" قبل تنفيذ الوظيفة

السلام عليكم استخدم دالة لتغيير خصائص النماذج دفعة واحدة مثل هذه : Public Function funforms() Dim frm As Object For Each frm In CurrentProject.AllForms DoCmd.OpenForm frm.name, acDesign Forms(frm.name).PopUp = True DoCmd.Close acForm, frm.name, acSaveYes Next End Function واريد تغيير لون خلفية مقطع التفاصيل وخلفية العناصر التي داخل التفصيل في النماذج ما التعديل الذي يحقق ذلك ؟

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

الف مبروك

الف مبروك للاستاذ فادي الترقية المستحقة

ماذا لو حصل خلل أو انقطاع الكهرباء أو تلف ... الخ !!!! رغم أنك وأعتقد ذلك من خلال المكتبات أنك أسست للربط بجهاز البصمة ، فهل الخلل الحاصل سيتحمله الموظف ويدخل في متاهة أثبت أو إحلف 😅 ..... الخ. ما لم تكن هناك حلول لهذه الإحتمالات قد تم أخذها في الحسبان ، فرأيي أن الأنظمة التي يقود مركبها جهاز قابل للخطأ = غير عادلة. أشعر انني انفعلت قليلاً 🤣😂 هي وجهة نظر ما لم يكن معلمي قد خبأ لنا إجابة تنتظر هذا التعليق . الأكواد جميلة جدا ، وفكرتها جميلة وقد ألمت بجميع النواحي البرمجية التي تحدثتم عنها سابقاً.

الحمد لله على نعمه.. لا تنسى إغلاق الموضوع أخي الكريم 🤗

حبيبي يا هندسة 🤗 اللهم تقبل دعائكم بظهر الغيب 🤲🏻 شكراً لمرورك اختنا الكريمة ،، ولكم من الدعاء النصيب الأكبر 😇

تمام ... شكرا استاذ حجازى جزاك الله كل خير علي جميل عملك وسرعة الرد

بعد إذن الاستاذ/ هشام جرب كود الأستاذ/هشام بعد تعديل بسيط Option Explicit Sub Transfer() Dim code As Variant, c As Boolean Dim tmp(0 To 4) As Boolean, xDate As String Dim f As Long, i As Long, j As Long Dim linge As Long, xCode As Boolean, Irow As Range Dim ColArr As Long, xName As String, n As Variant, val As Variant Dim lastRow As Long Dim CrWS As Worksheet: Set CrWS = Sheets("Sheet2") Dim Data As Worksheet: Set Data = Sheets("Sheet3") ' التحقق من وجود التاريخ xDate = Format(CrWS.Range("D2").Value, "dd/mm/yyyy") If xDate = "" Then MsgBox "المرجوا تحديد التاريخ", vbInformation Exit Sub End If ' البحث عن العمود المطابق للتاريخ في الصف 3 With Data For ColArr = .Columns("E").Column To .Cells(3, .Columns.Count).End(xlToLeft).Column If Format(.Cells(3, ColArr).Value, "dd/mm/yyyy") = xDate Then f = ColArr Exit For End If Next ColArr If f = 0 Then MsgBox "لم يتم العثور على التاريخ", vbExclamation Exit Sub End If End With ' تحديد آخر صف يحتوي أكواد في العمود C من Sheet2 lastRow = CrWS.Cells(CrWS.Rows.Count, "C").End(xlUp).Row xCode = False: c = False ' البدء من الصف 11 حتى يشمل أول طالب For i = 11 To lastRow code = CrWS.Cells(i, "C").Value If code <> "" Then linge = Data.Cells(Data.Rows.Count, "D").End(xlUp).Row n = Application.Match(code, Data.Range("D6:D" & linge), 0) If Not IsError(n) Then xCode = True ' مسح الصف الخاص بالكود الحالي فقط For ColArr = 0 To 4 Data.Cells(n + 5, f + ColArr).ClearContents Next ColArr ' نقل القيم For j = 0 To 4 xName = CrWS.Cells(10, 4 + j).Value For ColArr = 0 To 4 If Data.Cells(4, f + ColArr).Value = xName Then val = CrWS.Cells(i, 4 + j).Value If Not IsEmpty(val) Then Data.Cells(n + 5, f + ColArr).Value = val c = True If Not tmp(j) Then Data.Cells(5, f + ColArr).Value = CrWS.Cells(11, 4 + j).Value tmp(j) = True End If End If Exit For End If Next ColArr Next j End If End If Next i ' رسائل النهاية If Not xCode Then MsgBox "لم يتم العثور على أي أكواد مطابقة", vbExclamation ElseIf c Then MsgBox "تم ترحيل البيانات بنجاح", vbInformation Else MsgBox "لا توجد بيانات لترحيلها", vbInformation End If End Sub غياب3.xlsm

السلام عليكم اخي محمد بعد تجربة الكود علي اكثر من فصل تحدث مشكله بعد ترحيل السشن الاول لفصل 1Aيتم الترحيل تمام عند اختيار فصل تاني مثل 1B يقوم الكود بمسح غياب الفصل السابق ... وهكذا .. شاهد المرفق ... اختر الفصل من D3 ثم اختر التايخ من D2 يتم استدعاء الفصل غياب2.xlsm

شكرا على المشاركة ورحم الله والديك

وعليكم السلام ورحمة الله تعالى وبركاته جزاكم الله خيـــــــرا اسال الله تعالى ان يعفو ويغفر لوالدك و والدى ويرحمهم رحمة واسعة وكل المسلمين الاحياء منهم والاموات وان يسكنهم الفردوس الاعلى ان شاء الله تسلم ايدك يا فنان

جزاكم الله خير فكره جميلة جدا و يحتاجها كل مطوري الاكسيس

تم الضبط وحسب رأي صاحب العمل .. طلب عدم تسديد حقل الانصراف اذا لم يوقع خروج لأنه حسب انظمتهم من وقع حضور ولم يوقع انصراف يعتبر غائبا Private Sub cmd_ComeIN_GoOut() EmpUserid = ii Me.Requery Dim thisTime As Boolean Dim startTime As Date, endTime As Date Dim waitTimeIn As Date, waitTimeOut As Date Dim myFatrah As Integer Dim empName As String Dim waitTime As Integer waitTime = Nz(DLookup("waitBtween", "tbl_Ctrl"), 0) empName = DLookup("s_name", "Qnames", "UserId='" & Me.ii & "'") myFatrah = Nz(DLookup("fatrah", "Qnames", "UserId='" & ii & "'"), 0) startTime = DLookup("start_signin", "tbl_Ftrat", "id=" & myFatrah) endTime = DLookup("end_signOut", "tbl_Ftrat", "id=" & myFatrah) thisTime = Time() >= startTime And Time() <= endTime If thisTime = False Then Me.id.SetFocus Call CommNo Beep Me.alert.Caption = "خطأ !! توقيع خارج الوقت ..." Me.TimerInterval = 5000 id = "" id.SetFocus Exit Sub End If If thisTime = True Then Dim rs As Recordset Dim strSql As String strSql = "SELECT TOP 1 tblcomIn.id, tblcomIn.UserId, tblcomIn.chekIn, tblcomIn.chekOut, Format([chekin],""Short Date"") AS tdat " & vbCrLf & _ "FROM tblcomIn " & vbCrLf & _ "WHERE (((tblcomIn.UserId)=funEmpUserid()) AND ((Format([chekin],""Short Date""))=Date())) " & vbCrLf & _ "ORDER BY tblcomIn.id DESC;" Set rs = CurrentDb.OpenRecordset(strSql) On Error Resume Next waitTimeIn = DateAdd("n", waitTime, rs!chekIn) waitTimeOut = DateAdd("n", waitTime, rs!chekOut) If rs.RecordCount = 0 Then rs.AddNew rs!chekIn = Now() rs!UserId = ii rs.Update Call CommOk Me.TimerInterval = 5000 Me.txtnm = empName LabelH.Caption = "حضور" Me.Requery Me.id = "" Me.id.SetFocus Exit Sub End If If rs.RecordCount > 0 Then If Not IsNull(rs!chekIn) And Not IsNull(rs!chekOut) And Now() > waitTimeOut Then rs.AddNew rs!chekIn = Now() rs!UserId = ii rs.Update Call CommOk LabelH.Caption = "حضور" Me.TimerInterval = 5000 Me.txtnm = empName Me.Requery Me.id = "" Me.id.SetFocus ' ElseIf Not IsNull(rs!chekIn) And IsNull(rs!chekOut) And Now() > waitTimeIn Then rs.Edit rs!chekOut = Now() rs.Update Call CommOk Me.TimerInterval = 5000 Me.txtnm = empName LabelH.Caption = "انصراف" Me.Requery Me.id = "" Me.id.SetFocus Else Me.id.SetFocus Call CommNo Beep Me.alert.Caption = "توقيع مكرر !! انتظر قليلا ..." Me.TimerInterval = 5000 id = "" id.SetFocus Exit Sub End If End If End If End Sub www.rar

وإياكم أخي الكريم .. شكراً لمرورك العطر

جزاكم الله كل خير بشمهندس فادي هدية أكثر من رائعة

احسنت وبارك الله فيك شكرا لتجاوبك تمت التجربة مع بعض التعديلات البسيطه وكانت فعاله Dim ctrl As Control For Each ctrl In Me.Controls If (ctrl.ControlType = acTextBox Or ctrl.ControlType = acComboBox) Then If (Nz(ctrl.Value, "") = "") Then MsgBox "يرجى تعبئة جميع الحقول قبل الحفظ." & vbCrLf & _ "الحقل الفارغ: " & ctrl.Name, vbExclamation ctrl.SetFocus Exit Sub End If End If Next ctrl ' إذا جميع الحقول تم تعبئتها، يتم الحفظ DoCmd.RunCommand acCmdSaveRecord MsgBox "تم الحفظ بنجاح بنجاح", 0 + 64 + 1048576, "مؤكد" DoCmd.Close