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

السلام عليكم ورحمة الله تعالى وبركاته الشرح الاتى لا يخص الأكسس بصفة خاصة ولكن لحماية حذف القاعدة او اى ملف داخل مجلد او المجلد الذى يحتوى قاعدة البيانات بالخطأ اولا نقوم بعمل مجلد جديد ونعطيه الاسم الذى نريد على سبيل المثال نضع مجلد جديد داخل القطاع 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 وبعد حذف ما تريد يمكنك اعادة الخطوات ان اردت ارجاع الحماية مرة اخرى انتهى الشرح دمتم فى امان الله...

بسم الله ما شاء الله...

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

طيب جرب هذا .... 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 عفوا لم انته للتعدي ... يبدو ردي وقت التعديل

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

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

تفضل 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

جزاك الله خير اخي

أفضل إرفاق الملف الأصلي للإطلاع عليه .. حيث أن تكوين السطر بهذا الشكل غير منطقي .. حاول تساعد الأعضاء عشان يقدروا يساعدوك تقبل تحياتي عموماً جرب الكود التالي إذا ظبطت معاك كان بها فهي نعمة من الله إذا لم تظبط معاك فلن أساهم في الموضوع إلا بعد إرفاق الملف الأصلي (يسر علينا كي تجد المساعدة) Sub Max() Dim LR3 As Long, LR4 As Long, XX3 LR3 = 10: LR4 = 13 XX3 = Range("B11").Value Range("D7").Value = Worksheets("Seen").Evaluate("=MAX(IF(D" & LR3 & ":D" & LR4 & "= " & XX3 & ",E" & LR3 & ":E" & LR4 & "))") End Sub تقبل تحياتي