نجوم المشاركات

اعرض الملف إمنح تطبيقك المظهر الإحترافي بإستخدام مربع حوار المهام بديل لـ MsgBox {سلسلة الأدوات المساعدة المخصصة} أرفق لك إحدى الأدوات الرائعة التي يمكن أن تغنيك عن الكثير من النماذج وتجعل رسائل التنبيه تشبه رسائل ويندوز حاولت قد الإمكان تبسيط طريقة الإستخدام وتوضيحها في التعليقات أرجو أن تنال إعجابكم مع تحياتي صاحب الملف منتصر الانسي تمت الاضافه 07/05/25 الاقسام قسم الأكسيس  

أخواني وأساتذتي ومعلمينا ( دون استثناء ) أعتقد أنه ومن خلال العنوان سيتسائل البعض عن أن المحاولات كانت كثيرة لبناء هذه الفكرة ولكنها مع التحديثات الجديدة تفشل !! وهذا الإعتقاد منطقي 😁 . إلا انه وبهذه التحديثات - واتمنى - أنه قد تم التعامل مع هذه الأخطاء بهذه النسخة المطورة والمحسنة . الإضافات التي تم تأمينها في هذه النسخة :- التعامل مع المرفقات بسلاسة وسهولة من خلال فكرة نسخ المرفق ولصقه في تطبيق الواتس اب ( سطح المكتب ) ، وليس من خلال المسار 😁 . إمكانية الإرسال لأكثر من رقم دفعة واحدة . افصل بين الرقمين بإشارة / فقط . إمكانية إضافة التعبيرات Emoji وإرسالها ضمن الرسائل في الواتس أب . من خلال زر زر لمسح محتوى الرسالة تهيئةً لإرسال جديد . من خلال الزر تضمين محدد لحجم الملفات والمرفقات المرسلة . ( خاص بأصحاب التطويرات الذين يريدون تقييد وإلزام المستخدم بحجم محدد ) . استخدام تايمر متغير للتعامل مع الإرسالات المتعددة لأكثر من رقم . واجهة محاكية وجذابة للبرنامج . لا تحتاج جداول أو مكتبات خارجية .... إلخ . تم كتابة الدوال والأكواد بطريقة تسهل على المطورين إعادة الهيكلة والتصميم حسب حاجتهم في برامجهم . واجهة البرنامج :- :- ضرورة تثبيت برنامج واتس اب سطح المكتب من متجر ويندوز . التأكد من فتح تطبيق الواتس أب سطح المكتب لديك ، لتلافي المشاكل عند اختلاف سرعة إستجابة الكمبيوتر من مستخدم لآخر . WhatsApp Sender 2025.zip

رغم أن معظم الأكواد تحتاج الى إعادة هيكلة وتصحيح ، ولكن جرب هذا المقترح ، بعد ما تمت تجربته على ملفك السابق :- Private Function GetDateColumn(ByVal searchDate As Date) As Long Dim cell As Range Dim searchRange As Range Set searchRange = wsData.Range(wsData.Cells(HEADER_ROW, DATE_COL_START), _ wsData.Cells(HEADER_ROW, wsData.Columns.Count)) For Each cell In searchRange If IsDate(cell.Value) Then If CDate(cell.Value) = searchDate Then GetDateColumn = cell.Column Exit Function End If End If Next cell GetDateColumn = 0 End Function جرب الملف التالي وشوف النتيجة Book5.zip

بعد إذن الاستاذ/ هشام جرب كود الأستاذ/هشام بعد تعديل بسيط 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

بعد اذن اخي فادي تفضل من عمل اخونا صالح حمادي جربته وأستخدمه دوما في الشاشات التي تفتح على كامل الشاشة .. يعمل 100% ملائمة النموذج حسب حجم الشاشة صالح حمادي.rar

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

وعليكم السلام ورحمة الله وبركاته ,, فيما يخص الإيميل ، فهذه فكرة بسيطة من خلال النقر على مربع نص الإيميل على سبيل المثال :- Private Sub EMAIL_Click() Dim EmailAdd As String Dim GmailURL As String EmailAdd = Me.EMAIL.Value If Not IsValidEmails(EmailAdd) Then MsgBox "عنوان البريد الإلكتروني غير صالح", vbExclamation + vbMsgBoxRight, "" Exit Sub End If GmailURL = "https://mail.google.com/mail/?view=cm&fs=1&to=" & EmailAdd Application.FollowHyperlink GmailURL End Sub Function IsValidEmails(EMAIL As String) As Boolean Dim regex As Object Set regex = CreateObject("VBScript.RegExp") regex.Pattern = "^[\w-\.]+@([\w-]+\.)+[\w-]{2,4}$" regex.IgnoreCase = True IsValidEmails = regex.Test(EMAIL) End Function والطلب الثاني ، وهو فتح واتس أب ويب على دردشة محددة للرقم الذي تم النقر عليه ، حذح محاولتي البسيطة ( مشتقة من أحد ملفاتي سابقاً ) .. Private Sub MOB_Click() Dim WhatsURL As String Dim PhoneNum As String PhoneNum = Me.MOB.Value PhoneNum = CleanPhoneNum(PhoneNum) If PhoneNum = "" Then MsgBox "رقم الهاتف غير صالح", vbExclamation + vbMsgBoxRight, "" Exit Sub End If WhatsURL = "https://wa.me/" & PhoneNum Application.FollowHyperlink WhatsURL End Sub Function CleanPhoneNum(phone As String) As String Dim i As Integer Dim result As String result = "" For i = 1 To Len(phone) If IsNumeric(Mid(phone, i, 1)) Then result = result & Mid(phone, i, 1) End If Next i If Left(result, 2) = "00" Then result = Right(result, Len(result) - 2) ElseIf Left(phone, 1) = "+" Then result = Right(result, Len(result) - 1) End If CleanPhoneNum = result End Function

جزاك الله خيرا عمل وأفكار ولا أجمل هكذا يصبح الموضوع مرجع .. بل بستان .. يقطف منه الزائر ما شاء . بالنسبة لي احب الاختصارات انظر عملي في المرفق ادناه .. تقرير فقط لا يخفى عليك .. امكانية عرض حضور جميع الموظفين خلال يوم .. او عرض حضور موظف واحد خلال شهر مثلا الاختصار هو في اظهار وقتي الحضور والانصراف .. ومجموع التأخر فيهما .. وتم تلوين الوقت المخالف باللون الأحمر اذا كانت الطباعة بالاسود والابيض يمكننا تظليل خلفية الحقل بدلا من لون الخط الاحمر حسب اعتقادي .. المسؤول ليس بحاجة الى اكثر من ذلك في اسفل التقرير سوف تظهر المجاميع والفروقات d4.rar

السلام عليكم ورحمة الله وبركاته حياكم الله جميعا عذرا اخي المفتاح الرئيسي صحيح ولا يوجد مشكلة فيه كانت المشكلة في نوع البيانات، كانت هناك بيانات نوعها رقم كبير وكانت خصائص قاعدة البيانات لا تسمح برقم كبير ، وعندما فعلت هذا الخيار ظهرت الجداول بشكل صحيح

تمام أخي الكريم ،، نستطيع تلافي المشكلة بإخفاء النموذج بشكل مؤقت أثناء المعاينة !! استخدم الكود التالي في زر المعاينة ، وجرب Private Sub btnPrint_Click() If lstResults.ListCount = 0 Then MsgBox "لا توجد نتائج لطباعتها", vbExclamation: Exit Sub End If Dim sh As Worksheet, nextRow As Long, i As Long, j As Long Const REPORT_SHEET As String = "تقرير الغياب" Me.Hide On Error Resume Next: Application.DisplayAlerts = False Worksheets(REPORT_SHEET).Delete Application.DisplayAlerts = True: On Error GoTo 0 Set sh = Worksheets.Add(After:=Worksheets(Worksheets.Count)) sh.Name = REPORT_SHEET For j = 0 To lstResults.ColumnCount - 1 sh.Cells(1, j + 1).Value = "العمود " & j + 1 Next j sh.Range("A1:" & sh.Cells(1, lstResults.ColumnCount).Address).Font.Bold = True nextRow = 2 For i = 0 To lstResults.ListCount - 1 For j = 0 To lstResults.ColumnCount - 1 sh.Cells(nextRow, j + 1).Value = lstResults.List(i, j) Next j nextRow = nextRow + 1 Next i sh.Columns.AutoFit sh.PageSetup.Orientation = xlPortrait sh.PageSetup.Zoom = False sh.PageSetup.FitToPagesWide = 1 sh.PageSetup.FitToPagesTall = 1 sh.PrintPreview Me.Show End Sub

التحديث الجديد يستحق الإنتظار 🤗

اعرض الملف ⭐ هدية ~ مرسال الواتس أب الجديد 2025⭐ أخواني وأساتذتي ومعلمينا ( دون استثناء ) أعتقد أنه ومن خلال العنوان سيتسائل البعض عن أن المحاولات كانت كثيرة لبناء هذه الفكرة ولكنها مع التحديثات الجديدة تفشل !! وهذا الإعتقاد منطقي 😁 . إلا انه وبهذه التحديثات - واتمنى - أنه قد تم التعامل مع هذه الأخطاء بهذه النسخة المطورة والمحسنة . الإضافات التي تم تأمينها في هذه النسخة :- التعامل مع المرفقات بسلاسة وسهولة من خلال فكرة نسخ المرفق ولصقه في تطبيق الواتس اب ( سطح المكتب ) ، وليس من خلال المسار 😁 . إمكانية الإرسال لأكثر من رقم دفعة واحدة . افصل بين الرقمين بإشارة / فقط . إمكانية إضافة التعبيرات Emoji وإرسالها ضمن الرسائل في الواتس أب . من خلال زر زر لمسح محتوى الرسالة تهيئةً لإرسال جديد . من خلال الزر تضمين محدد لحجم الملفات والمرفقات المرسلة . ( خاص بأصحاب التطويرات الذين يريدون تقييد وإلزام المستخدم بحجم محدد ) . استخدام تايمر متغير للتعامل مع الإرسالات المتعددة لأكثر من رقم . واجهة محاكية وجذابة للبرنامج . لا تحتاج جداول أو مكتبات خارجية .... إلخ . تم كتابة الدوال والأكواد بطريقة تسهل على المطورين إعادة الهيكلة والتصميم حسب حاجتهم في برامجهم . واجهة البرنامج :- :- ضرورة تثبيت برنامج واتس اب سطح المكتب من متجر ويندوز . التأكد من فتح تطبيق الواتس أب سطح المكتب لديك ، لتلافي اختلاف سرعة إستجابة الكمبيوتر من مستخدم لآخر . صاحب الملف Foksh تمت الاضافه 07/03/25 الاقسام قسم الأكسيس  

طيب و بمناسبة الرفع والشوط والله مش هزعلك اتفضل 1- Show And Hdie لاخفاء واظهار الامر الخاص باخفاء واظهار الملفات والمجلدات بعد الاخفاء سوف تكون بهذا الشكل طبعا اى مجلدات او ملفات مخفيه لن يستطيع المستخدم الذى يريد العبث اعادة اظهارها والاطلاع عليها لان أمر اظهار الملفات او المجلدات المخفيه اساسا اختفى 2- usb Open And Lock تفعيل / عدم تفعيل قراءة اى شئ من منفذ USB عند استخدام : USB LOOK لو عندك الف منفذ Usb ادخل بهم اى فلاشة او هردات محمولة لن يتم قرائتها مطلقا usb Open And Lock.zip Show And Hdie.zip

ما شاء الله ، مبدع فيما طرحت . أثار الموضوع اهتمامي سابقاً في مناقشة سابقة ومداخلة قوية لك ، مما جعلني أتحرى عن موضوع الحقن بشكل عميق وأحاول تنفيذه في مشاريعي تالياً .. ومن سياق الحديث الذي طرحته ، اعتقد أن استخدام المعلمات بدلاً من سلاسل نصية سيكون من خطوات الأمان التي قد يجب تنفيذها . أيضاً على ما أعتقد استخدامنا لمطهرات النصوص قد يأتي بنتيجة جيدة ومساعدة ,, على سبيل المثال ، هذه فكرة بسيطة أيضاً وقد تكون قابلة للتطوير والتحديث بشمولية ,, If InStr(Me.txtUser, "'") > 0 Or InStr(Me.txtUser, ";") > 0 Then MsgBox "تم استخدام رموز غير مسموح بها في اسم المستخدم", vbExclamation Exit Sub End If ولهذا السبب كنت قد استخدمت محاولة لم أقم بتجربتها بعد ، على أحد المشاريع باستخدام هذه الدالة :- Public Function Sanitizer(ByVal userInput As String, Optional ByVal context As String = "sql") As String Dim sanitized As String sanitized = Trim(userInput) Select Case LCase(context) Case "sql" sanitized = Replace(sanitized, "'", "''") sanitized = Replace(sanitized, ";", "") sanitized = Replace(sanitized, "--", "") Case "name" sanitized = Replace(sanitized, "'", "") sanitized = Replace(sanitized, ";", "") sanitized = Replace(sanitized, "*", "") sanitized = Replace(sanitized, "=", "") Case "pure" Case Else sanitized = Replace(sanitized, "'", "''") End Select Sanitizer = sanitized End Function وعلى سبيل المثال كإستخدام في الاستعلامات :- Dim filter As String filter = "[U_UserName]='" & Sanitizer(Me.txtUser, "sql") & "' AND [U_Password]='" & Sanitizer(Me.txtPass, "sql") & "'" DoCmd.OpenForm "frmDashboard", , , filter وكمثال على ما طرحته سابقاً لفتح نموذج بفلترة .. DoCmd.ApplyFilter , "[U_UserName]='" & Sanitizer(Me.txtSearch, "sql") & "'" أو حتى في نموذج تسجيل الدخول لاسم المستخدم ، كانت المحاولة :- Dim newUser As String newUser = Sanitizer(Me.txtNewUser, "name") هذه كانت الفكرة التي خطرت لي ، ولكن لاحقاً قمت بتحديثها لإظهار رسالة تحذيرية تلقائية إذا تم رصد مدخل خطير أو محاولات حقن نصية 😁

تفضل Sub FormatUniqueCellsInRow() Dim ws As Worksheet Dim lastRow As Long, startRow As Long Dim r As Long, i As Long, j As Long Dim values(1 To 7) As Variant Dim count As Long Dim data As Variant On Error GoTo ErrorHandler Set ws = ThisWorkbook.Sheets("Sheet1") ' تأكد من تغيير "Sheet1" إلى اسم الورقة الفعلي startRow = 3 ' الصف الذي تبدأ منه البيانات lastRow = ws.Range("C3:I" & ws.Rows.Count).Find(What:="*", _ SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row ' تنظيف التنسيقات السابقة من الأعمدة C:I و O With ws.Range("C" & startRow & ":I" & lastRow & ",O" & startRow & ":O" & lastRow) .Interior.ColorIndex = xlNone .Font.ColorIndex = xlAutomatic .Font.Bold = False End With ' تحميل النطاق إلى مصفوفة data = ws.Range("C" & startRow & ":I" & lastRow).Value ' المرور على كل صف For r = 1 To lastRow - startRow + 1 ' تخزين قيم الصف الحالي For i = 1 To 7 values(i) = data(r, i) Next i ' فحص القيم الفريدة For i = 1 To 7 count = 0 If Not IsEmpty(values(i)) Then For j = 1 To 7 If CStr(values(j)) = CStr(values(i)) Then count = count + 1 End If Next j ' إذا كانت القيمة فريدة If count = 1 Then ' تطبيق التنسيق على الخلية في C:I With ws.Cells(r + startRow - 1, i + 2) .Interior.Color = RGB(255, 255, 0) ' تعبئة صفراء .Font.Color = RGB(255, 0, 0) ' خط أحمر .Font.Bold = True ' خط عريض End With ' تطبيق نفس التنسيق على الخلية في العمود O في نفس الصف With ws.Cells(r + startRow - 1, "O") .Interior.Color = RGB(255, 255, 0) ' تعبئة صفراء .Font.Color = RGB(255, 0, 0) ' خط أحمر .Font.Bold = True ' خط عريض End With End If End If Next i Next r MsgBox "تمت معالجة البيانات بنجاح!", vbInformation Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical End Sub

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

جميل ، وهذا ما كنت اعمل عليه في هذه الفكرة ,, ودون شرحها هنا ، في المرفق نموذجين كأفكار قابلة للتحوير والتعديل حسب حاجتنا . مع العلم أنني قمت بإضافات قد لا تحتاجها ، ولكنها من باب الفضول والزيادة 😅 data1-1.zip

كنت عامل موضوع بهذا الخصوص ولكن لتصفير و حذف بيانات أكثر من جدول ان اردت التوسع هذا رابط الموضوع https://www.officena.net/ib/topic/106503-حذف-بيانات-جداول-منضمة-ومرتبطه-دفعة-واحدة-على-حسب-اختيارك/#comment-642632

تفضل أخي عبدالعزيز @Abdelaziz Osman 🙂 هذا الاستعلام لو بتشغله في ال VBA : ' DELETE statement | جملة DELETE Dim sqlDelete As String sqlDelete = "DELETE FROM [TABINDX]" sqlDelete = sqlDelete & " WHERE [ID] = " & var_ID ' Execute The Query | تنفيذ الاستعلام CurrentDb.Execute sqlDelete وهذ لو بتشغله كاستعلام أكسس : DELETE FROM [TABINDX] WHERE [ID] = var_ID ولا تنسى أن تضع قيمة ال ID المطلوب حذفه مكان الـمتغير : var_ID ولو بتحذف كافة محتويات الجدول تكتب كذا : CurrentDb.Execute "DELETE FROM TABINDX"

احسنت وبارك الله فيك شكرا لتجاوبك تمت التجربة مع بعض التعديلات البسيطه وكانت فعاله 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

كثيرون استفسروا عن كيفية اختيار اسم مخزن في الجدول ، بدلاً من كتابة الرقم بشكل يدوي . ولذا قد صورت هذا الفيديو كفكرة سريعة على الخطوات - وصولاً إلى النتيجة ,, طبعاً كلمة كثيرون = في مجموعة الواتس أب الخاصة بقسم آكسيس وليس في المنتدى 🤣

في المعايير النصية لبعض الاستعلامات نستخدم WHERE U_UserName = '" & strUser & "' AND U_Password = '" & strPass & "'") وكذلك الحال في دوال تجميع المجال "[U_FullName]='" & [tx3] & "'") ايضا عندما نضع معيار نصي لفتح فورم من خلال فورم اخر DoCmd.OpenForm "frm2", , , "[U_UserName]='" & [tx2] & "'" وكذلك الحال عند الفلترة بمعيار نصي DoCmd.ApplyFilter , "[U_UserName]='" & [tx9] & "'" وحيث ان الحقول النصية تقبل كتابة أي احرف أو أرقام أو رموز خاصة وبالتي يمكن توظيفها بطريقة معينة لتنفيذ اجراء غير شرعي الحقيقة التي يعلمها اي شخص لديه خبرة في الحماية أن الرموز الخاصة ورسائل الخطأ غير المعالجة تمثل الطريق الأسهل للاختراق في الحالة الاولى معيار نصي في استعلام يمكن تسجيل دخول غير شرعي بكافة صلاحيات مستخدم رقم 1 ويمكن تنفيذ استعلام حذف او الحاق او او ... الخ في حالة رقم 2 مع دوال تجميع المجال يمكن تنفيذ الدالة دون معرفة المعيار وتعود باول او اخر او اكبر سجل وفقا لنوع الدالة في الحالة الثالثة نحتاج أحيانا لفتح فورم وإحضار بيانات محددة للعرض و يمكن من خلال توظيف الرمز فتح الفور مع اول سجل او كافة السجلات ويمكن استعراضها والتنقل بينها هنا لا داعي لمعرفة المعيار فقط رموز ونجوم يتم كتابتها بطريقة معينة وكذلك في الحالة الرابعة الفلترة يمكن فلترة كافة البيانات والتنقل بدون الحاجة لمعرفة المعيار والسؤال هل هذا هو الرمز الوحيد الذي يمكن استغلاله (') الاجابة لا ولكن ركزنا عليه لكونه الأكثر استخدام في قاعدة البيانات اخيرا هل يمكن انهاء المشكلة وخصوصا ان الرمز مطلوب للمعايير النصية نعم يمكن بتتبع المدخلات للحقول النصية المرتبطة باجراء ومن اسهل الطرق استخدام دالة Replace strPass = Replace(Me.U_Password, "'", "_") ايضا استخدام رسائل معالجة الاخطاء وتحديد الاجراء عند حدوث خطأ ونكتفي بهذا القدر عن الرمز (') وقد نتحدث غن رمز اخر لايقل خطورة والله الموفق الشايب

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

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

اتفضل الطريقة نعم بدون حبة الملح : Salt ولحالة آمن ولكن حبة الملح هذه تزيد من قوة التأمين فى فى التشفير جدا جدا جدا

لمنع موضوع الحق انا استخدم الداله Public Function SafeSql(strValue As String) As String If IsNull(strValue) Or strValue = "" Then SafeSql = "NULL" Else SafeSql = "'" & Replace(strValue, "'", "''") & "'" End If End Function وامرر لها اسم المستخدم وكلمة المرور strUserName = SafeSql(strUserName)

تفضل أخي الكريم ، محاولتي البسيطة . حيث في الورقة الثانية = موقف الغياب اليومي ، قمت بإضافة زر للتحديث ، وتم استدعاءه للدالة التي تم انشاؤها في مديول عام :- Sub ExtractAbsentEmployees() Dim wsMain As Worksheet Dim wsReport As Worksheet Dim targetDate As Date Dim dayNum As Integer Dim targetCol As Integer Dim lastRow As Long Dim i As Long Dim reportRow As Long Set wsMain = ThisWorkbook.Sheets("MainSheet") Set wsReport = ThisWorkbook.Sheets("موقف الغياب اليومي") wsReport.Range("A5:D" & wsReport.Rows.Count).ClearContents targetDate = wsReport.Range("C2").Value dayNum = Day(targetDate) targetCol = 3 + dayNum If targetCol < 4 Or targetCol > 34 Then MsgBox ".تاريخ غير صالح يجب أن يكون اليوم بين 1 و 31", vbExclamation Exit Sub End If lastRow = wsMain.Cells(wsMain.Rows.Count, "B").End(xlUp).Row reportRow = 5 For i = 4 To lastRow If wsMain.Cells(i, targetCol).Value = "غ" Then wsReport.Cells(reportRow, 1).Value = wsMain.Cells(i, 1).Value wsReport.Cells(reportRow, 2).Value = wsMain.Cells(i, 2).Value wsReport.Cells(reportRow, 3).Value = wsMain.Cells(i, 3).Value wsReport.Cells(reportRow, 4).Value = targetDate reportRow = reportRow + 1 End If Next i If reportRow = 5 Then MsgBox "لا يوجد موظفين متغيبين في هذا التاريخ", vbInformation End If End Sub وفي الورقة الثالثة "موقف الغياب الشهري" ، أيضاً تم انشاء زر لاستدعاءه الدالة التالية من نفس المديول :- Sub GenerateMonthlyAbsenceReport() Dim wsMain As Worksheet Dim wsReport As Worksheet Dim startDate As Date, endDate As Date Dim currentDate As Date Dim dayNum As Integer, targetCol As Integer Dim lastRow As Long, reportRow As Long, i As Long Dim empName As String, empJob As String Dim dateList As String, dayList As String Dim dateCount As Integer Dim dayName As String Set wsMain = ThisWorkbook.Sheets("MainSheet") Set wsReport = ThisWorkbook.Sheets("موقف الغياب الشهري") If Not IsDate(wsReport.Range("C2").Value) Or Not IsDate(wsReport.Range("C3").Value) Then MsgBox "الرجاء إدخال تاريخين صالحين في الخلايا C2 و C3", vbExclamation + vbMsgBoxRight, "" Exit Sub End If startDate = wsReport.Range("C2").Value endDate = wsReport.Range("C3").Value If startDate > endDate Then MsgBox "خطأ: تاريخ البداية يجب أن يكون قبل تاريخ النهاية", vbExclamation + vbMsgBoxRight, "" Exit Sub End If Application.ScreenUpdating = False Application.Calculation = xlCalculationManual With wsReport .Range("A6:F" & .Rows.Count).ClearContents .Range("6:" & .Rows.Count).RowHeight = 15 End With lastRow = wsMain.Cells(wsMain.Rows.Count, "B").End(xlUp).Row reportRow = 6 For i = 4 To lastRow empName = wsMain.Cells(i, 2).Value empJob = wsMain.Cells(i, 3).Value If empName = "" Then GoTo NextEmployee dateList = "" dayList = "" dateCount = 0 currentDate = startDate Do While currentDate <= endDate dayNum = Day(currentDate) targetCol = 3 + dayNum If targetCol >= 4 And targetCol <= 34 Then If wsMain.Cells(i, targetCol).Value = "غ" Then dayName = wsMain.Cells(2, targetCol).Value If dateList <> "" Then dateList = dateList & vbLf & Format(currentDate, "yyyy-mm-dd") dayList = dayList & vbLf & dayName Else dateList = Format(currentDate, "yyyy-mm-dd") dayList = dayName End If dateCount = dateCount + 1 End If End If currentDate = DateAdd("d", 1, currentDate) Loop If dateCount > 0 Then With wsReport .Cells(reportRow, 1).Value = reportRow - 5 .Cells(reportRow, 2).Value = empName .Cells(reportRow, 3).Value = empJob .Cells(reportRow, 4).Value = dateCount .Cells(reportRow, 5).Value = dateList .Cells(reportRow, 6).Value = dayList .Cells(reportRow, 5).WrapText = True .Cells(reportRow, 6).WrapText = True If dateCount > 1 Then .Rows(reportRow).RowHeight = 15 * dateCount End If End With reportRow = reportRow + 1 End If NextEmployee: Next i Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic If reportRow > 6 Then ' MsgBox "تم إنشاء التقرير بنجاح", vbInformation + vbMsgBoxRight, "" Else MsgBox "لا توجد أيام غياب في الفترة المحددة", vbInformation + vbMsgBoxRight, "" End If End Sub وتركت لك التعديل متاحاً من خلال تحديد الصف أو العمود ... إلخ . وهذا ملفك بعد التعديل . راجعه وأخبرنا بالنتيجة .. موقف غياب موظفين.zip

اللهم اغفر له وارحمه واجعله مثواه الجنة والهم أهله وذويه الصبر والسلوان

اللهم امين .. أتم يارب شفاءه على أكمل وجه بالشكل الذى يرضيك يا أكرم الأكرمين واربط على اهله وذويه بالصبر على هذا

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

سامحني سأتأخر عليك سأقوم بالمطلوب أو بعضه الليلة إن شاء الله.

تفضل أخي الكريم 3 ملفات الأول إذا كان الأوفيس عندك 365 أو 2016 فيما فوق الثاني إذا كان الأوفيس إصدار أقل من 2016 الثالث باستخدام الأكواد لا تنسى اختيار "اختر تمت الاجابة" إذا تم حل المشكلة استخراج_فواتير_بدون_تكرار (365).xlsx استخراج_فواتير_بدون_تكرار (أوفيس قديم).xlsx استخراج_فواتير_بدون_تكرار (كود).xlsm

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

نعم .. نعم .. هو كذا يا باشمهندس كذا الشغل والا بلاش .. سلمت أناملك .. وفكرك

السلام عليكم استاذى الجليل و معلمى القدير و والدى الحبيب الاستاذ @ابوخليل ممتاز الان اتضحت لى الفكرة تمام انا كانت فكرتى ان لا اقوم بتعديل الاعدادت داخل كافة النماذج ولكن فقط تطبيق الاعدادت الجديدة مع الاحتفاظ بالوضع الاصلى عند التصميم ولكن حضرتك تريد فتح كافة النماذج فى وضع التصميم وتطبيق كل التعديلات على كافة النماذج لخدمة المصمم وطامل انها لخدمة المصمم فقط وتريد كل الاكواد فى النموذج دون الاعتماد على وحدات نمطية ليسهل استخدام النموذج وما بجعبته مع اى قاعدة أخرى بمجرد نسخه اليها لقد قمت بكتابة الكود بالشكل التالى : Option Compare Database Option Explicit '' ======= التصريحات والثوابت #If VBA7 Then Private Declare PtrSafe Function CHOOSECOLOR Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As CHOOSECOLOR) As Long #Else Private Declare Function CHOOSECOLOR Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As CHOOSECOLOR) As Long #End If #If VBA7 Then Private Type CHOOSECOLOR lStructSize As Long hwndOwner As LongPtr hInstance As LongPtr rgbResult As Long lpCustColors As LongPtr Flags As Long lCustData As LongPtr lpfnHook As LongPtr lpTemplateName As LongPtr End Type #Else Private Type CHOOSECOLOR lStructSize As Long hwndOwner As Long hInstance As Long rgbResult As Long lpCustColors As Long Flags As Long lCustData As Long lpfnHook As Long lpTemplateName As Long End Type #End If Private Enum SectionType stHeader = acHeader stDetail = acDetail stFooter = acFooter End Enum Private Enum ControlType ctTextBox = acTextBox ctComboBox = acComboBox ctListBox = acListBox ctLabel = acLabel ctCommandButton = acCommandButton End Enum Private Const COLOR_UNSET As Long = -1 Private Const TABLE_NAME_THEME_SETTINGS As String = "tblThemeSettings" Private Const FIELD_NAME As String = "SettingName" Private Const FIELD_VALUE As String = "SettingValue" Private Theme As Object Private DebugMode As Boolean '' ======= إنشاء القاموس عند بدء التشغيل Private Sub InitializeThemeDictionary() Set Theme = CreateObject("Scripting.Dictionary") Theme.Add "Header", CreateObject("Scripting.Dictionary") Theme("Header").Add "SectionBack", COLOR_UNSET Theme("Header").Add "TextBack", COLOR_UNSET Theme("Header").Add "TextBorder", COLOR_UNSET Theme("Header").Add "TextFont", COLOR_UNSET Theme("Header").Add "LabelBack", COLOR_UNSET Theme("Header").Add "LabelBorder", COLOR_UNSET Theme("Header").Add "LabelFont", COLOR_UNSET Theme.Add "Detail", CreateObject("Scripting.Dictionary") Theme("Detail").Add "SectionBack", COLOR_UNSET Theme("Detail").Add "TextBack", COLOR_UNSET Theme("Detail").Add "TextBorder", COLOR_UNSET Theme("Detail").Add "TextFont", COLOR_UNSET Theme("Detail").Add "LabelBack", COLOR_UNSET Theme("Detail").Add "LabelBorder", COLOR_UNSET Theme("Detail").Add "LabelFont", COLOR_UNSET Theme.Add "Footer", CreateObject("Scripting.Dictionary") Theme("Footer").Add "SectionBack", COLOR_UNSET Theme("Footer").Add "TextBack", COLOR_UNSET Theme("Footer").Add "TextBorder", COLOR_UNSET Theme("Footer").Add "TextFont", COLOR_UNSET Theme("Footer").Add "LabelBack", COLOR_UNSET Theme("Footer").Add "LabelBorder", COLOR_UNSET Theme("Footer").Add "LabelFont", COLOR_UNSET Theme.Add "Button", CreateObject("Scripting.Dictionary") Theme("Button").Add "Back", COLOR_UNSET Theme("Button").Add "Border", COLOR_UNSET Theme("Button").Add "Font", COLOR_UNSET Theme("Button").Add "Hover", COLOR_UNSET Theme("Button").Add "Pressed", COLOR_UNSET Theme("Button").Add "HoverFore", COLOR_UNSET Theme("Button").Add "PressedFore", COLOR_UNSET Theme.Add "Combo", CreateObject("Scripting.Dictionary") Theme("Combo").Add "Back", COLOR_UNSET Theme("Combo").Add "Border", COLOR_UNSET Theme("Combo").Add "Font", COLOR_UNSET Theme.Add "List", CreateObject("Scripting.Dictionary") Theme("List").Add "Back", COLOR_UNSET Theme("List").Add "Border", COLOR_UNSET Theme("List").Add "Font", COLOR_UNSET End Sub '' ======= أحداث النموذج Private Sub Form_Load() InitializeThemeDictionary EnsureThemeTableExists LoadThemeFromTable End Sub Private Sub btnSaveAndApply_Click() SaveThemeToTable ApplyThemeToAllForms MsgBox "تم تطبيق الثيم بنجاح.", vbInformation End Sub Private Sub btnApplyDefaultThemeToCurrentForm_Click() SetDefaultThemeValues ApplyThemePreview End Sub '' ======= أزرار تغيير الألوان Private Sub btnHeaderSectionColor_Click() Dim lngColor As Long lngColor = Theme("Header")("SectionBack") ApplySectionColor lngColor, stHeader Theme("Header")("SectionBack") = lngColor ApplyThemePreview End Sub Private Sub btnHeaderControlBack_Click() Dim lngColor As Long lngColor = Theme("Header")("TextBack") HandleColorPick lngColor, "BackColor", ctTextBox, stHeader Theme("Header")("TextBack") = lngColor ApplyThemePreview End Sub Private Sub btnHeaderControlBorder_Click() Dim lngColor As Long lngColor = Theme("Header")("TextBorder") HandleColorPick lngColor, "BorderColor", ctTextBox, stHeader Theme("Header")("TextBorder") = lngColor ApplyThemePreview End Sub Private Sub btnHeaderControlFore_Click() Dim lngColor As Long lngColor = Theme("Header")("TextFont") HandleColorPick lngColor, "ForeColor", ctTextBox, stHeader Theme("Header")("TextFont") = lngColor ApplyThemePreview End Sub Private Sub btnHeaderLabelBack_Click() Dim lngColor As Long lngColor = Theme("Header")("LabelBack") HandleColorPick lngColor, "BackColor", ctLabel, stHeader Theme("Header")("LabelBack") = lngColor ApplyThemePreview End Sub Private Sub btnHeaderLabelBorder_Click() Dim lngColor As Long lngColor = Theme("Header")("LabelBorder") HandleColorPick lngColor, "BorderColor", ctLabel, stHeader Theme("Header")("LabelBorder") = lngColor ApplyThemePreview End Sub Private Sub btnHeaderLabelFore_Click() Dim lngColor As Long lngColor = Theme("Header")("LabelFont") HandleColorPick lngColor, "ForeColor", ctLabel, stHeader Theme("Header")("LabelFont") = lngColor ApplyThemePreview End Sub Private Sub btnDetailSectionColor_Click() Dim lngColor As Long lngColor = Theme("Detail")("SectionBack") ApplySectionColor lngColor, stDetail Theme("Detail")("SectionBack") = lngColor ApplyThemePreview End Sub Private Sub btnDetailControlBack_Click() Dim lngColor As Long lngColor = Theme("Detail")("TextBack") HandleColorPick lngColor, "BackColor", ctTextBox, stDetail Theme("Detail")("TextBack") = lngColor ApplyThemePreview End Sub Private Sub btnDetailControlBorder_Click() Dim lngColor As Long lngColor = Theme("Detail")("TextBorder") HandleColorPick lngColor, "BorderColor", ctTextBox, stDetail Theme("Detail")("TextBorder") = lngColor ApplyThemePreview End Sub Private Sub btnDetailControlFore_Click() Dim lngColor As Long lngColor = Theme("Detail")("TextFont") HandleColorPick lngColor, "ForeColor", ctTextBox, stDetail Theme("Detail")("TextFont") = lngColor ApplyThemePreview End Sub Private Sub btnDetailLabelBack_Click() Dim lngColor As Long lngColor = Theme("Detail")("LabelBack") HandleColorPick lngColor, "BackColor", ctLabel, stDetail Theme("Detail")("LabelBack") = lngColor ApplyThemePreview End Sub Private Sub btnDetailLabelBorder_Click() Dim lngColor As Long lngColor = Theme("Detail")("LabelBorder") HandleColorPick lngColor, "BorderColor", ctLabel, stDetail Theme("Detail")("LabelBorder") = lngColor ApplyThemePreview End Sub Private Sub btnDetailLabelFore_Click() Dim lngColor As Long lngColor = Theme("Detail")("LabelFont") HandleColorPick lngColor, "ForeColor", ctLabel, stDetail Theme("Detail")("LabelFont") = lngColor ApplyThemePreview End Sub Private Sub btnFooterSectionColor_Click() Dim lngColor As Long lngColor = Theme("Footer")("SectionBack") ApplySectionColor lngColor, stFooter Theme("Footer")("SectionBack") = lngColor ApplyThemePreview End Sub Private Sub btnFooterControlBack_Click() Dim lngColor As Long lngColor = Theme("Footer")("TextBack") HandleColorPick lngColor, "BackColor", ctTextBox, stFooter Theme("Footer")("TextBack") = lngColor ApplyThemePreview End Sub Private Sub btnFooterControlBorder_Click() Dim lngColor As Long lngColor = Theme("Footer")("TextBorder") HandleColorPick lngColor, "BorderColor", ctTextBox, stFooter Theme("Footer")("TextBorder") = lngColor ApplyThemePreview End Sub Private Sub btnFooterControlFore_Click() Dim lngColor As Long lngColor = Theme("Footer")("TextFont") HandleColorPick lngColor, "ForeColor", ctTextBox, stFooter Theme("Footer")("TextFont") = lngColor ApplyThemePreview End Sub Private Sub btnFooterLabelBack_Click() Dim lngColor As Long lngColor = Theme("Footer")("LabelBack") HandleColorPick lngColor, "BackColor", ctLabel, stFooter Theme("Footer")("LabelBack") = lngColor ApplyThemePreview End Sub Private Sub btnFooterLabelBorder_Click() Dim lngColor As Long lngColor = Theme("Footer")("LabelBorder") HandleColorPick lngColor, "BorderColor", ctLabel, stFooter Theme("Footer")("LabelBorder") = lngColor ApplyThemePreview End Sub Private Sub btnFooterLabelFore_Click() Dim lngColor As Long lngColor = Theme("Footer")("LabelFont") HandleColorPick lngColor, "ForeColor", ctLabel, stFooter Theme("Footer")("LabelFont") = lngColor ApplyThemePreview End Sub Private Sub btnCommandBack_Click() Dim lngColor As Long lngColor = Theme("Button")("Back") HandleColorPick lngColor, "BackColor", ctCommandButton Theme("Button")("Back") = lngColor ApplyThemePreview End Sub Private Sub btnCommandBorder_Click() Dim lngColor As Long lngColor = Theme("Button")("Border") HandleColorPick lngColor, "BorderColor", ctCommandButton Theme("Button")("Border") = lngColor ApplyThemePreview End Sub Private Sub btnCommandFore_Click() Dim lngColor As Long lngColor = Theme("Button")("Font") HandleColorPick lngColor, "ForeColor", ctCommandButton Theme("Button")("Font") = lngColor ApplyThemePreview End Sub Private Sub btnCommandHover_Click() Dim lngColor As Long lngColor = Theme("Button")("Hover") lngColor = PickColorFromBase(lngColor) Theme("Button")("Hover") = lngColor ApplyThemePreview End Sub Private Sub btnCommandPressed_Click() Dim lngColor As Long lngColor = Theme("Button")("Pressed") lngColor = PickColorFromBase(lngColor) Theme("Button")("Pressed") = lngColor ApplyThemePreview End Sub Private Sub btnCommandHoverFore_Click() Dim lngColor As Long lngColor = Theme("Button")("HoverFore") lngColor = PickColorFromBase(lngColor) Theme("Button")("HoverFore") = lngColor ApplyThemePreview End Sub Private Sub btnCommandPressedFore_Click() Dim lngColor As Long lngColor = Theme("Button")("PressedFore") lngColor = PickColorFromBase(lngColor) Theme("Button")("PressedFore") = lngColor ApplyThemePreview End Sub Private Sub btnComboBack_Click() Dim lngColor As Long lngColor = Theme("Combo")("Back") HandleColorPick lngColor, "BackColor", ctComboBox Theme("Combo")("Back") = lngColor ApplyThemePreview End Sub Private Sub btnComboBorder_Click() Dim lngColor As Long lngColor = Theme("Combo")("Border") HandleColorPick lngColor, "BorderColor", ctComboBox Theme("Combo")("Border") = lngColor ApplyThemePreview End Sub Private Sub btnComboFore_Click() Dim lngColor As Long lngColor = Theme("Combo")("Font") HandleColorPick lngColor, "ForeColor", ctComboBox Theme("Combo")("Font") = lngColor ApplyThemePreview End Sub Private Sub btnListBack_Click() Dim lngColor As Long lngColor = Theme("List")("Back") HandleColorPick lngColor, "BackColor", ctListBox Theme("List")("Back") = lngColor ApplyThemePreview End Sub Private Sub btnListBorder_Click() Dim lngColor As Long lngColor = Theme("List")("Border") HandleColorPick lngColor, "BorderColor", ctListBox Theme("List")("Border") = lngColor ApplyThemePreview End Sub Private Sub btnListFore_Click() Dim lngColor As Long lngColor = Theme("List")("Font") HandleColorPick lngColor, "ForeColor", ctListBox Theme("List")("Font") = lngColor ApplyThemePreview End Sub '' ======= قيم افتراضية Private Sub SetDefaultThemeValues() Theme("Header")("SectionBack") = RGB(230, 230, 250) Theme("Header")("TextBack") = RGB(255, 255, 255) Theme("Header")("TextBorder") = RGB(180, 180, 180) Theme("Header")("TextFont") = RGB(0, 0, 0) Theme("Header")("LabelBack") = RGB(240, 240, 240) Theme("Header")("LabelBorder") = RGB(240, 240, 240) Theme("Header")("LabelFont") = RGB(0, 0, 0) Theme("Detail")("SectionBack") = RGB(255, 255, 255) Theme("Detail")("TextBack") = RGB(255, 255, 255) Theme("Detail")("TextBorder") = RGB(180, 180, 180) Theme("Detail")("TextFont") = RGB(0, 0, 0) Theme("Detail")("LabelBack") = RGB(240, 240, 240) Theme("Detail")("LabelBorder") = RGB(240, 240, 240) Theme("Detail")("LabelFont") = RGB(0, 0, 0) Theme("Footer")("SectionBack") = RGB(245, 245, 245) Theme("Footer")("TextBack") = RGB(255, 255, 255) Theme("Footer")("TextBorder") = RGB(180, 180, 180) Theme("Footer")("TextFont") = RGB(0, 0, 0) Theme("Footer")("LabelBack") = RGB(240, 240, 240) Theme("Footer")("LabelBorder") = RGB(240, 240, 240) Theme("Footer")("LabelFont") = RGB(0, 0, 0) Theme("Button")("Back") = RGB(220, 220, 220) Theme("Button")("Border") = RGB(180, 180, 180) Theme("Button")("Font") = RGB(0, 0, 0) Theme("Button")("Hover") = RGB(200, 200, 255) Theme("Button")("Pressed") = RGB(150, 150, 220) Theme("Button")("HoverFore") = RGB(0, 0, 80) Theme("Button")("PressedFore") = RGB(255, 255, 255) Theme("Combo")("Back") = RGB(255, 255, 255) Theme("Combo")("Border") = RGB(160, 160, 160) Theme("Combo")("Font") = RGB(0, 0, 0) Theme("List")("Back") = RGB(255, 255, 255) Theme("List")("Border") = RGB(180, 180, 180) Theme("List")("Font") = RGB(0, 0, 0) End Sub '' ======= دوال مساعدة Private Function PickColorFromBase(Optional ByVal lngStartColor As Long = -1) As Long Dim cc As CHOOSECOLOR Dim aColors(15) As Long cc.lStructSize = LenB(cc) cc.hwndOwner = Application.hWndAccessApp cc.lpCustColors = VarPtr(aColors(0)) If lngStartColor <> -1 Then cc.rgbResult = lngStartColor cc.Flags = &H1 End If If CHOOSECOLOR(cc) Then PickColorFromBase = cc.rgbResult Else PickColorFromBase = COLOR_UNSET End If End Function Private Sub HandleColorPick(ByRef lngTargetVar As Long, ByVal strProperty As String, ByVal lngControlType As Long, Optional ByVal lngSection As Variant) Dim lngNewColor As Long Dim ctl As Control Dim bolMatchSection As Boolean lngNewColor = PickColorFromBase(lngTargetVar) If lngNewColor = COLOR_UNSET Then Exit Sub lngTargetVar = lngNewColor For Each ctl In Me.Controls If ctl.ControlType = lngControlType Then On Error Resume Next bolMatchSection = (IsMissing(lngSection) Or ctl.section = lngSection) On Error GoTo 0 If bolMatchSection Then On Error Resume Next CallByName ctl, strProperty, VbLet, lngNewColor On Error GoTo 0 End If End If Next ctl End Sub Private Sub ApplySectionColor(ByRef lngTargetVar As Long, ByVal lngSection As Long) Dim lngNewColor As Long lngNewColor = PickColorFromBase(lngTargetVar) If lngNewColor <> COLOR_UNSET Then lngTargetVar = lngNewColor Me.section(lngSection).BackColor = lngNewColor End If End Sub Private Sub ApplyThemePreview() Dim ctl As Control Dim sec As String If Theme("Header")("SectionBack") <> COLOR_UNSET Then Me.section(stHeader).BackColor = Theme("Header")("SectionBack") If Theme("Detail")("SectionBack") <> COLOR_UNSET Then Me.section(stDetail).BackColor = Theme("Detail")("SectionBack") If Theme("Footer")("SectionBack") <> COLOR_UNSET Then Me.section(stFooter).BackColor = Theme("Footer")("SectionBack") For Each ctl In Me.Controls Select Case ctl.ControlType Case ctTextBox Select Case ctl.section Case stHeader: sec = "Header" Case stDetail: sec = "Detail" Case stFooter: sec = "Footer" Case Else: GoTo NextControl End Select If Theme(sec)("TextBack") <> COLOR_UNSET Then ctl.BackColor = Theme(sec)("TextBack") If Theme(sec)("TextBorder") <> COLOR_UNSET Then ctl.BorderColor = Theme(sec)("TextBorder") If Theme(sec)("TextFont") <> COLOR_UNSET Then ctl.ForeColor = Theme(sec)("TextFont") Case ctComboBox If Theme("Combo")("Back") <> COLOR_UNSET Then ctl.BackColor = Theme("Combo")("Back") If Theme("Combo")("Border") <> COLOR_UNSET Then ctl.BorderColor = Theme("Combo")("Border") If Theme("Combo")("Font") <> COLOR_UNSET Then ctl.ForeColor = Theme("Combo")("Font") Case ctListBox If Theme("List")("Back") <> COLOR_UNSET Then ctl.BackColor = Theme("List")("Back") If Theme("List")("Border") <> COLOR_UNSET Then ctl.BorderColor = Theme("List")("Border") If Theme("List")("Font") <> COLOR_UNSET Then ctl.ForeColor = Theme("List")("Font") Case ctLabel Select Case ctl.section Case stHeader: sec = "Header" Case stDetail: sec = "Detail" Case stFooter: sec = "Footer" Case Else: GoTo NextControl End Select If Theme(sec)("LabelBack") <> COLOR_UNSET Then ctl.BackColor = Theme(sec)("LabelBack") If Theme(sec)("LabelBorder") <> COLOR_UNSET Then ctl.BorderColor = Theme(sec)("LabelBorder") If Theme(sec)("LabelFont") <> COLOR_UNSET Then ctl.ForeColor = Theme(sec)("LabelFont") Case ctCommandButton If Theme("Button")("Back") <> COLOR_UNSET Then ctl.BackColor = Theme("Button")("Back") If Theme("Button")("Border") <> COLOR_UNSET Then ctl.BorderColor = Theme("Button")("Border") If Theme("Button")("Font") <> COLOR_UNSET Then ctl.ForeColor = Theme("Button")("Font") On Error Resume Next If Theme("Button")("Hover") <> COLOR_UNSET Then ctl.HoverColor = Theme("Button")("Hover") If Theme("Button")("Pressed") <> COLOR_UNSET Then ctl.PressedColor = Theme("Button")("Pressed") If Theme("Button")("HoverFore") <> COLOR_UNSET Then ctl.HoverForeColor = Theme("Button")("HoverFore") If Theme("Button")("PressedFore") <> COLOR_UNSET Then ctl.PressedForeColor = Theme("Button")("PressedFore") On Error GoTo 0 End Select NextControl: Next ctl End Sub Private Sub EnsureThemeTableExists() Dim db As DAO.Database Dim tdf As DAO.TableDef Set db = CurrentDb On Error Resume Next Set tdf = db.TableDefs(TABLE_NAME_THEME_SETTINGS) On Error GoTo 0 If tdf Is Nothing Then db.Execute "CREATE TABLE " & TABLE_NAME_THEME_SETTINGS & " (" & _ FIELD_NAME & " TEXT(50) PRIMARY KEY, " & _ FIELD_VALUE & " LONG)", dbFailOnError End If End Sub Private Sub SaveColorSetting(ByRef rs As DAO.Recordset, ByVal strName As String, ByVal lngValue As Long) rs.FindFirst FIELD_NAME & "='" & strName & "'" If rs.NoMatch Then rs.AddNew rs(FIELD_NAME) = strName rs(FIELD_VALUE) = lngValue rs.Update ElseIf rs(FIELD_VALUE) <> lngValue Then rs.Edit rs(FIELD_VALUE) = lngValue rs.Update End If End Sub Private Sub SaveThemeToTable() Dim rs As DAO.Recordset Set rs = CurrentDb.OpenRecordset(TABLE_NAME_THEME_SETTINGS, dbOpenDynaset) SaveColorSetting rs, "Header_SectionBack", Theme("Header")("SectionBack") SaveColorSetting rs, "Header_TextBack", Theme("Header")("TextBack") SaveColorSetting rs, "Header_TextBorder", Theme("Header")("TextBorder") SaveColorSetting rs, "Header_TextFont", Theme("Header")("TextFont") SaveColorSetting rs, "Header_LabelBack", Theme("Header")("LabelBack") SaveColorSetting rs, "Header_LabelBorder", Theme("Header")("LabelBorder") SaveColorSetting rs, "Header_LabelFont", Theme("Header")("LabelFont") SaveColorSetting rs, "Detail_SectionBack", Theme("Detail")("SectionBack") SaveColorSetting rs, "Detail_TextBack", Theme("Detail")("TextBack") SaveColorSetting rs, "Detail_TextBorder", Theme("Detail")("TextBorder") SaveColorSetting rs, "Detail_TextFont", Theme("Detail")("TextFont") SaveColorSetting rs, "Detail_LabelBack", Theme("Detail")("LabelBack") SaveColorSetting rs, "Detail_LabelBorder", Theme("Detail")("LabelBorder") SaveColorSetting rs, "Detail_LabelFont", Theme("Detail")("LabelFont") SaveColorSetting rs, "Footer_SectionBack", Theme("Footer")("SectionBack") SaveColorSetting rs, "Footer_TextBack", Theme("Footer")("TextBack") SaveColorSetting rs, "Footer_TextBorder", Theme("Footer")("TextBorder") SaveColorSetting rs, "Footer_TextFont", Theme("Footer")("TextFont") SaveColorSetting rs, "Footer_LabelBack", Theme("Footer")("LabelBack") SaveColorSetting rs, "Footer_LabelBorder", Theme("Footer")("LabelBorder") SaveColorSetting rs, "Footer_LabelFont", Theme("Footer")("LabelFont") SaveColorSetting rs, "Button_Back", Theme("Button")("Back") SaveColorSetting rs, "Button_Border", Theme("Button")("Border") SaveColorSetting rs, "Button_Font", Theme("Button")("Font") SaveColorSetting rs, "Button_Hover", Theme("Button")("Hover") SaveColorSetting rs, "Button_Pressed", Theme("Button")("Pressed") SaveColorSetting rs, "Button_HoverFore", Theme("Button")("HoverFore") SaveColorSetting rs, "Button_PressedFore", Theme("Button")("PressedFore") SaveColorSetting rs, "Combo_Back", Theme("Combo")("Back") SaveColorSetting rs, "Combo_Border", Theme("Combo")("Border") SaveColorSetting rs, "Combo_Font", Theme("Combo")("Font") SaveColorSetting rs, "List_Back", Theme("List")("Back") SaveColorSetting rs, "List_Border", Theme("List")("Border") SaveColorSetting rs, "List_Font", Theme("List")("Font") rs.Close End Sub Private Sub LoadThemeFromCurrentForm() Dim ctl As Control Dim sec As String Theme("Header")("SectionBack") = Me.section(stHeader).BackColor Theme("Detail")("SectionBack") = Me.section(stDetail).BackColor Theme("Footer")("SectionBack") = Me.section(stFooter).BackColor For Each ctl In Me.Controls Select Case ctl.ControlType Case ctTextBox Select Case ctl.section Case stHeader: sec = "Header" Case stDetail: sec = "Detail" Case stFooter: sec = "Footer" Case Else: GoTo NextControl End Select Theme(sec)("TextBack") = ctl.BackColor Theme(sec)("TextBorder") = ctl.BorderColor Theme(sec)("TextFont") = ctl.ForeColor Case ctComboBox Theme("Combo")("Back") = ctl.BackColor Theme("Combo")("Border") = ctl.BorderColor Theme("Combo")("Font") = ctl.ForeColor Case ctListBox Theme("List")("Back") = ctl.BackColor Theme("List")("Border") = ctl.BorderColor Theme("List")("Font") = ctl.ForeColor Case ctLabel Select Case ctl.section Case stHeader: sec = "Header" Case stDetail: sec = "Detail" Case stFooter: sec = "Footer" Case Else: GoTo NextControl End Select Theme(sec)("LabelBack") = ctl.BackColor Theme(sec)("LabelBorder") = ctl.BorderColor Theme(sec)("LabelFont") = ctl.ForeColor Case ctCommandButton Theme("Button")("Back") = ctl.BackColor Theme("Button")("Border") = ctl.BorderColor Theme("Button")("Font") = ctl.ForeColor On Error Resume Next Theme("Button")("Hover") = ctl.HoverColor Theme("Button")("Pressed") = ctl.PressedColor Theme("Button")("HoverFore") = ctl.HoverForeColor Theme("Button")("PressedFore") = ctl.PressedForeColor On Error GoTo 0 End Select NextControl: Next ctl End Sub Private Sub LoadThemeFromTable() Dim rs As DAO.Recordset On Error GoTo ErrHandler Set rs = CurrentDb.OpenRecordset("SELECT * FROM " & TABLE_NAME_THEME_SETTINGS) If rs.EOF Then LoadThemeFromCurrentForm Else Do Until rs.EOF Select Case rs(FIELD_NAME) Case "Header_SectionBack": Theme("Header")("SectionBack") = rs(FIELD_VALUE) Case "Header_TextBack": Theme("Header")("TextBack") = rs(FIELD_VALUE) Case "Header_TextBorder": Theme("Header")("TextBorder") = rs(FIELD_VALUE) Case "Header_TextFont": Theme("Header")("TextFont") = rs(FIELD_VALUE) Case "Header_LabelBack": Theme("Header")("LabelBack") = rs(FIELD_VALUE) Case "Header_LabelBorder": Theme("Header")("LabelBorder") = rs(FIELD_VALUE) Case "Header_LabelFont": Theme("Header")("LabelFont") = rs(FIELD_VALUE) Case "Detail_SectionBack": Theme("Detail")("SectionBack") = rs(FIELD_VALUE) Case "Detail_TextBack": Theme("Detail")("TextBack") = rs(FIELD_VALUE) Case "Detail_TextBorder": Theme("Detail")("TextBorder") = rs(FIELD_VALUE) Case "Detail_TextFont": Theme("Detail")("TextFont") = rs(FIELD_VALUE) Case "Detail_LabelBack": Theme("Detail")("LabelBack") = rs(FIELD_VALUE) Case "Detail_LabelBorder": Theme("Detail")("LabelBorder") = rs(FIELD_VALUE) Case "Detail_LabelFont": Theme("Detail")("LabelFont") = rs(FIELD_VALUE) Case "Footer_SectionBack": Theme("Footer")("SectionBack") = rs(FIELD_VALUE) Case "Footer_TextBack": Theme("Footer")("TextBack") = rs(FIELD_VALUE) Case "Footer_TextBorder": Theme("Footer")("TextBorder") = rs(FIELD_VALUE) Case "Footer_TextFont": Theme("Footer")("TextFont") = rs(FIELD_VALUE) Case "Footer_LabelBack": Theme("Footer")("LabelBack") = rs(FIELD_VALUE) Case "Footer_LabelBorder": Theme("Footer")("LabelBorder") = rs(FIELD_VALUE) Case "Footer_LabelFont": Theme("Footer")("LabelFont") = rs(FIELD_VALUE) Case "Button_Back": Theme("Button")("Back") = rs(FIELD_VALUE) Case "Button_Border": Theme("Button")("Border") = rs(FIELD_VALUE) Case "Button_Font": Theme("Button")("Font") = rs(FIELD_VALUE) Case "Button_Hover": Theme("Button")("Hover") = rs(FIELD_VALUE) Case "Button_Pressed": Theme("Button")("Pressed") = rs(FIELD_VALUE) Case "Button_HoverFore": Theme("Button")("HoverFore") = rs(FIELD_VALUE) Case "Button_PressedFore": Theme("Button")("PressedFore") = rs(FIELD_VALUE) Case "Combo_Back": Theme("Combo")("Back") = rs(FIELD_VALUE) Case "Combo_Border": Theme("Combo")("Border") = rs(FIELD_VALUE) Case "Combo_Font": Theme("Combo")("Font") = rs(FIELD_VALUE) Case "List_Back": Theme("List")("Back") = rs(FIELD_VALUE) Case "List_Border": Theme("List")("Border") = rs(FIELD_VALUE) Case "List_Font": Theme("List")("Font") = rs(FIELD_VALUE) End Select rs.MoveNext Loop End If rs.Close Set rs = Nothing ApplyThemePreview Exit Sub ErrHandler: If DebugMode Then Debug.Print "LoadThemeFromTable >> " & Err.Number & ": " & Err.Description End Sub Private Sub ApplyThemeToAllForms() Dim frm As Object Dim ctl As Control Dim i As Integer Dim arrSections As Variant Dim sec As section Dim secName As String arrSections = Array(stHeader, stDetail, stFooter) For Each frm In CurrentProject.AllForms On Error Resume Next DoCmd.OpenForm frm.Name, acDesign, , , , acHidden If Err.Number <> 0 Then If DebugMode Then Debug.Print "تعذر فتح النموذج: " & frm.Name Err.Clear GoTo NextForm End If On Error GoTo 0 For i = LBound(arrSections) To UBound(arrSections) Set sec = Forms(frm.Name).section(arrSections(i)) Select Case arrSections(i) Case stHeader: If Theme("Header")("SectionBack") <> COLOR_UNSET Then sec.BackColor = Theme("Header")("SectionBack") Case stDetail: If Theme("Detail")("SectionBack") <> COLOR_UNSET Then sec.BackColor = Theme("Detail")("SectionBack") Case stFooter: If Theme("Footer")("SectionBack") <> COLOR_UNSET Then sec.BackColor = Theme("Footer")("SectionBack") End Select Next i For Each ctl In Forms(frm.Name).Controls Select Case ctl.ControlType Case ctTextBox Select Case ctl.section Case stHeader: secName = "Header" Case stDetail: secName = "Detail" Case stFooter: secName = "Footer" Case Else: GoTo NextControl End Select If Theme(secName)("TextBack") <> COLOR_UNSET Then ctl.BackColor = Theme(secName)("TextBack") If Theme(secName)("TextBorder") <> COLOR_UNSET Then ctl.BorderColor = Theme(secName)("TextBorder") If Theme(secName)("TextFont") <> COLOR_UNSET Then ctl.ForeColor = Theme(secName)("TextFont") Case ctComboBox If Theme("Combo")("Back") <> COLOR_UNSET Then ctl.BackColor = Theme("Combo")("Back") If Theme("Combo")("Border") <> COLOR_UNSET Then ctl.BorderColor = Theme("Combo")("Border") If Theme("Combo")("Font") <> COLOR_UNSET Then ctl.ForeColor = Theme("Combo")("Font") Case ctListBox If Theme("List")("Back") <> COLOR_UNSET Then ctl.BackColor = Theme("List")("Back") If Theme("List")("Border") <> COLOR_UNSET Then ctl.BorderColor = Theme("List")("Border") If Theme("List")("Font") <> COLOR_UNSET Then ctl.ForeColor = Theme("List")("Font") Case ctLabel Select Case ctl.section Case stHeader: secName = "Header" Case stDetail: secName = "Detail" Case stFooter: secName = "Footer" Case Else: GoTo NextControl End Select If Theme(secName)("LabelBack") <> COLOR_UNSET Then ctl.BackColor = Theme(secName)("LabelBack") If Theme(secName)("LabelBorder") <> COLOR_UNSET Then ctl.BorderColor = Theme(secName)("LabelBorder") If Theme(secName)("LabelFont") <> COLOR_UNSET Then ctl.ForeColor = Theme(secName)("LabelFont") Case ctCommandButton If Theme("Button")("Back") <> COLOR_UNSET Then ctl.BackColor = Theme("Button")("Back") If Theme("Button")("Border") <> COLOR_UNSET Then ctl.BorderColor = Theme("Button")("Border") If Theme("Button")("Font") <> COLOR_UNSET Then ctl.ForeColor = Theme("Button")("Font") On Error Resume Next If Theme("Button")("Hover") <> COLOR_UNSET Then ctl.HoverColor = Theme("Button")("Hover") If Theme("Button")("Pressed") <> COLOR_UNSET Then ctl.PressedColor = Theme("Button")("Pressed") If Theme("Button")("HoverFore") <> COLOR_UNSET Then ctl.HoverForeColor = Theme("Button")("HoverFore") If Theme("Button")("PressedFore") <> COLOR_UNSET Then ctl.PressedForeColor = Theme("Button")("PressedFore") On Error GoTo 0 End Select NextControl: Next ctl DoCmd.Close acForm, frm.Name, acSaveYes NextForm: On Error GoTo 0 Err.Clear Next frm End Sub الكود الان يتيح تخصيص مظهر النماذج بشكل مركزي يوفر واجهة لتحديد ألوان الخلفية للأقسام (رأس، تفاصيل، تذييل) يوفر تحديد ألوان الخلفية و الحدود والنصوص للعناصر (مربعات نص - عناوين التسمية ) لكل قسم على حده يوفر تحديد ألوان الخلفية والنصوص للعناصر (مربعات نص - مربعات التحرير والسرد - قوائم القيم - أزرار ) يدعم معاينة فورية وتطبيق الثيم على جميع النماذج بنقرة واحدة مع خيار استعادة الإعدادات الافتراضية يتم حفظ الإعدادات في جدول قاعدة بيانات مما يضمن الاتساق عبر النماذج ينشئ الجدول فى حالة عدم وجوده يحدث البيانات للاعدادت داخل الجدول فى حالة وجود الجدول وأخيرا التعديل على مرفق حضرتك changColor(2).accdb

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

تفضل جرب الملف مصادقة 1.xlsx

السلام عليكم ورحمة الله تعالى وبركاته الشرح الاتى لا يخص الأكسس بصفة خاصة ولكن لحماية حذف القاعدة او اى ملف داخل مجلد او المجلد الذى يحتوى قاعدة البيانات بالخطأ اولا نقوم بعمل مجلد جديد ونعطيه الاسم الذى نريد على سبيل المثال نضع مجلد جديد داخل القطاع D ونعطى المجلد اسم BackDB نقوم بتحديد المسار ونقوم بنسخه فيكون D:\Test\BackDB ولو كان اسم المجلد من مقطعين مثل Back DB سوف يكون المسار نسخ المسار الى ملف نصى ونقوم بتعديله ليكون D:\Test\Back_DB بعد ذلك نقوم بفتح موجه الاومر DOS ونقوم بكتابة او لصق الامر الاتى cacls D:\Test\BackDB /P everyone:n ولو اسم المجلد من مقطعين يكون cacls D:\Test\Back_DB /P everyone:n ثم نضغط على المقتاح Enter من لوحة المقاتيح ثم نضغط على المفتاح Y من لوحة المفاتيح كما هو موضح فى الصورة بعد ذلك نغلق موجه الاوامر DOS ونذهب الى المجلد ونقوم بالضغط عليه كليك يمين ونختار Properties تظهر لنا النافذة الاتية نحدد التبويب Security ثم نضغط بعد ذلك على Advanced كما هو موضع بالصورة ثم بعد ذلك تظهر لنا النافذة الاتية نقوم بالتحديد اولا كما هو فى الخطوة رقم 1 بالصورة ثم بعد ذلك كما هو بالخطوة رقم 2 نقوم بالضغط على Edit ثم بعد ذلك تظهر لنا النافذة الاتية نقوم بالضعط على Show Advanced Permissions ثم بعد ذلك تظهر لنا النافذة الاتية 1- فى الـ Type نختار Allow 2- فى اختيارات الـ Permissions نقوم بإزالة التأشير من على الاتى Delete Delete Subfolders and files لتصبح الاعدادت كما بالشكل الاتى ثم نضغط OK الان انسخ قاعدة البيانات داخل المجلد او اى ملفات تخاف من فقدانها جرب حذف الملفات لن يتم حذفها حاول حذف القاعدة كذلك لن يتم حذفها كذلك اقتح القاعدة واضف اليها بيانات او عدل او احذف منها اى بيانات سوف تعمل القاعدة بشكل طبيعى جدا لو اردت حذف المجلد او اى شئ بداخلة فقط استخدم الامر الاتى فى موجه اوامر الـ DOS cacls D:\Test\BackDB /P everyone:f وبعد حذف ما تريد يمكنك اعادة الخطوات ان اردت ارجاع الحماية مرة اخرى انتهى الشرح دمتم فى امان الله...

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

وعليكم السلام ورحمة الله وبركاته ،، وبما اني اتابع من الجوال ، ولم استطع من رؤية الملف . اعتقد ان هناك أكثر من فكرة !!! الأولى قد تعتمد على دالة تتفقد جميع العناصر ذات النوع "مربع نص" بأنها تحتوي قيم وغير فارغة . وهذا قد يسبب مشكلة لأنه حينها لن يميز بين مربعات النص التي تريدها من مربعات نص أخرى على سبيل المثال . الثانية أنه عند الحفظ وقبل إتمام عملية الحفظ التأكد من مربعات النص التي لها مصدر بيانات مرتبط بحقل وليس مربعات النص الغير مضمنة بمصدر بيانات ، وهنا قد تكون مشكلة أيضاً . الثالثة وما أرجحها بشكل أفضل وأقوى ، وهو من خلال الـ TAG . بحيث تضع وسماً لجميع مربعات النص التي تريدها أن يتم التحقق منها ولنفترض = Ham حيث من خلال زر الحفظ نستعمل كود بهذا الشكل تقريباً - ما لم أكن مخطئاً في بعض الأجزاء .. dim ctl as control, missing as string for each ctl in me.controls if lcase(trim(ctl.tag)) = "Ham" then if nz(ctl.value, "") = "" then missing = missing & vbcrlf & ctl.name end if end if next if missing <> "" then msgbox " : الحقول التالية فارغة" & vbcrlf & missing, vbinformation+ vbmsgboxright, "" exit sub end if docmd.runcommand accmdsaverecord docmd.gotorecord,,acnewrec طبعاً ، إذا كنت من الأشخاص الذين يتركون اسم مربع النص كما هو من مصدره من الجدول ، فقد قمت بإضافة فكرة تحديد اسماء المربعات النصية التي لم يتم ادخال بيانات فيها . بكل الأحوال جرب وأخبرنا بالنتيجة ، عل أحد الأساتذة والأخوة يتابع معك من كمبيوتر 🥴 على كل حال جرب خطر على بالي نقطة أخرى من خلال السطر :- missing = missing & vbcrlf & ctl.name بأن نستبدله بالسطر التالي :- missing = missing & vbcrlf & ctl.controls(0).caption فهنا سيأقرأ التسمية ( label ) المرتبطة بكل مربع نص بدلاً من اسم مربع النص نفسه .

الاستاذ محمد صالح احتاج متوسط السعر (average) وليس اجمالى(sum) السعر شكرا على جهودك

بسيطة أخي الكريم .. تم التعديل الى الكود التالي :- Private Sub ListBox1_Click() If ListBox1.ListIndex = -1 Then Exit Sub Sheets(ListBox1.Column(0)).Activate Cells.Interior.Pattern = xlNone With Range(ListBox1.Column(1)).EntireRow .Interior.Color = vbYellow .Cells(1, 1).Activate End With TextBox2.Value = ListBox1.Column(2) End Sub

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

السلام عليكم -تفضل كان عليك استخدام خاصية البحث بالمنتدى أولا قبل رفع مشاركتك فبه كنوز تحميل نموذج حضور وانصراف الموظفين excel و سلف و مرتبات شيت المرتبات الشامل 2023.xlsm

بارك الله فيك وزادك الله من فضله

أحسنت أستاذنا الكريم بارك الله فيك وزادك الله من فضله موضوع قيم جعله الله فى ميزان حسناتك

IFERROR(LOOKUP(A1,{600001;700001;800001;900001},{525;2775;5025;8025}) بسيطة وسهلة هذا الجزء يعنى ان الشرائح التى تبدأ بـــ600001 يكون الوعاء الضريبى هو المقابل لها بالقوسين الأخرين وهو 525 أما الشريحة الثانية 700001 فالوعاء الضريبى لها هو 2775 ...وهكذا الى اخر الشرائح وشكراً

تفضل المشكلة كانت من عندك لأنك محدد فى الكود ظهور ثلاثة أعمدة فقط تـــم تعديل وضبط الفورم كما تريد حلقات المساجد2.xls

وعليكم السلام-يمكنك استخدام هذه المعادلة ..وذلك فى حالة ان وقت الإنصراف أقل من وقت الحضور ,ولكن لابد ان يكون فى نفس اليوم ,,وبعد ذلك لابد من تصحيح وتعديل وقت الإنصراق عند إدخاله بمعنى اذا انصرف الموظف الساعة مثلاً 5 وربع مساءاً فلابد من كتابتها وادخالها هكذا 17:15 وشكراً =IF($D2<$C2,($D2+"12:00")-$C2,$D2-$C2) back1.xlsx