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

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

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

هذه تساعدك على الترتيب تصاعديا وتنازليا بشكل صحيح = "D:\الهويات\Pictures\" & TEXT(ROW(),"00000") & ".jpg"

كيف تم الاختراق شايبنا ؟ ماذا كتبت مكان كلمة المرور ؟ طيب جرب مع هذا : 🙂👈 قالب تسجيل الدخول مع صلاحيات دخول النماذج.accdb

معالجة جميلة استاذ فادي وهذه محاولة مني لإدراج الترقيم في الجدول Dim rs As Recordset Dim i As String Dim ii As Integer Dim x As Integer Set rs = CurrentDb.OpenRecordset("Query1") rs.MoveLast rs.MoveFirst i = Me.GRADE1.Column(1) ii = Me.GRADE1.Column(2) Do While Not rs.EOF rs.Edit rs!code_stagiere = i & (ii + x) rs.Update x = x + 1 rs.MoveNext Loop baseAA.rar

وعليكم السلام ورحمة الله وبركاته .. تفضل يا صديقي ، تم تعديل الاستعلام في مصدر سجلات التقرير ليصبح :- SELECT info_stagiere.ID, info_stagiere.nom, info_stagiere.prenom, info_stagiere.annee, info_stagiere.grade, [code_grade].[code] & ([code_grade].[numero]+(SELECT COUNT(*) FROM info_stagiere AS T WHERE T.annee = info_stagiere.annee AND T.grade = info_stagiere.grade AND T.ID < info_stagiere.ID)) AS code_stagiere FROM info_stagiere INNER JOIN code_grade ON info_stagiere.grade = code_grade.grade WHERE (((info_stagiere.annee)=[Forms]![frm_stag]![ANNEE1]) AND ((info_stagiere.grade)=[Forms]![frm_stag]![GRADE1])); هل هذا طلبك ؟ baseA.accdb

وعليكم السلام ورحمة الله تعالى وبركاته Sub SaveAsPDF() Const Max As Long = 1000 Dim WS As Worksheet, Irow As Long, OnRng As Range Dim xPath As String, Dossier As String, Fichier As String Set WS = Sheets("Sheet1") Irow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row If Irow > Max Then Irow = Max: Set OnRng = WS.Range("A2:Z" & Irow) If Application.WorksheetFunction.CountA(OnRng) = 0 Then Exit Sub WS.ResetAllPageBreaks With WS.PageSetup .PrintArea = OnRng.Address: .Orientation = xlPortrait: .PaperSize = xlPaperA4 .Zoom = False: .FitToPagesWide = 1: .FitToPagesTall = False End With Dossier = ThisWorkbook.Path & "\ملفات PDF" If Dir(Dossier, vbDirectory) = "" Then MkDir Dossier Fichier = Replace(WS.Range("AA1").Value, "/", "_") xPath = Dossier & "\" & Fichier & " " & Format(Now, "yyyy-mm-dd hh.mm") & ".pdf" WS.ExportAsFixedFormat Type:=xlTypePDF, FileName:=xPath, _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False WS.PageSetup.PrintArea = "" MsgBox "تم حفظ الملف بنجاح ", vbInformation End Sub Test-PDF.xlsb

الدالة لتحويل نتائج دالة التفقيط NoToTxt (لا أعرف كاتبها) إلى أرقام. وقد كتبتها بناءً على طلب أحد أعضاء منتدى الاكسل. Function NoToTxtRev(ByVal TheTxt As String, MyCur As String, MySubCur As String) As Double 'AbuuAhmed, last update 2024/12/30 'Reverse of NoToTxt function Dim Pos As Integer, Step As Byte, Part4 As Integer, Part As Byte Dim i As Byte, ii As Integer Dim Parts(6), a, b, c Dim Text As String Dim Sum4 As Double, Sum As Double Dim Key0, Key1, Key2, Key3 Dim Sp As Integer Dim Pwr As Integer a = Array("", "مائة", "مائتان", "ثلاثمائة", "أربعمائة", "خمسمائة", "ستمائة", "سبعمائة", "ثمانمائة", "تسعمائة", _ "", "عشر", "عشرون", "ثلاثون", "أربعون", "خمسون", "ستون", "سبعون", "ثمانون", "تسعون", _ "", "واحد", "اثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة") b = Array("إحدى", "إثنى", "عشرة", "فقط ", "و ", "ملياران", "مليونان", "ألفان", _ "ومليار", "ومليون", "وألف", "فقط مليار", "فقط مليون", "فقط ألف", "فقط ") c = Array("واحد", "اثنان", "صفر عشر", "فقط ", "و", "اثنان مليار", "اثنان مليون", "اثنان ألف", _ "وواحد مليار", "وواحد مليون", "وواحد ألف", "واحد مليار", "واحد مليون", "واحد ألف", "") Key1 = Array("", "مليار", "ملياران", "مليارات") Key2 = Array("", "مليون", "مليونان", "ملايين") Key3 = Array("", "ألف", "ألفان", "آلاف") For i = 0 To UBound(b) TheTxt = Replace(TheTxt, b(i), c(i)) Next i If MyCur & MySubCur <> "" Then Pos = InStr(1, TheTxt, MyCur) If Pos > 0 Then Parts(5) = Replace(Mid(TheTxt, Pos + Len(MyCur)), MySubCur, "") TheTxt = Left(TheTxt, Pos - 1) Else Pos = InStr(1, TheTxt, MySubCur) If Pos > 0 Then Parts(5) = Replace(TheTxt, MySubCur, "") TheTxt = "" End If End If Else Pos = InStr(1, TheTxt, " ") If Pos > 0 Then Parts(5) = Trim(Mid(TheTxt, Pos + 3)) TheTxt = Left(TheTxt, Pos - 1) End If End If For Part = 1 To 3 Key0 = IIf(Part = 1, Key1, IIf(Part = 2, Key2, Key3)) Pos = InStr(1, TheTxt, Key0(1)) If Pos = 0 Then Pos = InStr(1, TheTxt, Key0(2)) If Pos = 0 Then Pos = InStr(1, TheTxt, Key0(3)) If Pos > 0 Then Parts(Part) = Left(TheTxt, Pos - 1) Pos = InStr(Pos, TheTxt & " ", " ") TheTxt = Mid(TheTxt, Pos) End If Next Part Parts(4) = TheTxt For i = 1 To 5 Parts(i) = Trim(Replace(Parts(i), " و", " ")) Parts(i) = Replace(Parts(i), " احد", " واحد") Next i For Part4 = 0 To 12 Step 3 Part = Part4 / 3 + 1 Sum4 = 0 Sp = 3 - (Len(Parts(Part)) - Len(Replace(Parts(Part), " ", ""))) If Sp < 1 Then Sp = 1 For Step = Sp To 3 Pos = InStr(1, Parts(Part) & " ", " ") Text = Trim(Left(Parts(Part), Pos - 1)) Parts(Part) = Mid(Parts(Part), Pos + 1) If Text <> "" Then For i = 1 To UBound(a) Pwr = 10 ^ (3 - Fix((i - 1) / 10) - 1) ii = i Mod 10 If Text = a(i) Then If Part = 5 Then Sum4 = Sum4 + ii * Pwr Else Sum4 = Sum4 + ii * Pwr * Val("1" & IIf(Part = 5, "", String(9 - Part4, "0"))) End If Exit For End If Next i End If Next Step Sum = Sum + IIf(Part = 5, Sum4 / 100, Sum4) Next Part4 NoToTxtRev = Sum End Function

السلام عليكم قاعدة التطبيق تم عملها على أكسس 2003 وهى تعمل أيضاً على أى أكسس حتى 2024 أكواد القاعدة تحتوى على الكثير والكثير من الأفكار والحيل الرائعة لمحترفى أعضاء المنتدى منهم أبو هادى والأخت زهرة وسيد عبدالعال وابو خليل وغيرهم من الأحباء القدامى والجدد لا أدعى أن البرنامج قد حقق الكثير من أهدافه ، لكنه أرضى كل مدرسة هنا قامت باستخدامه الرقم السري للدخول " 1 " ويمكن تغييره فى الإعدادات وإليكم بعض الصور لشاشاته تحياتى لجميع أعضاء أوفيسنا ، والشكر الكبير لهذا المنتدى العريق بيانات المدرسين.rar

حسب مافهمت من استاذنا @ابوخليل تفضل استاذ @moho58 هذا المرفق انشاء الله بتحصل طلبك . ووافني بالرد baseF-3 .rar

بسم الله الرحمن الرحيم الحمد لله رب العالمين، والصلاة والسلام على أشرف المرسلين، سيدنا محمد وعلى آله وصحبه والتابعين. تظل منتديات اوفيسنا علي مدار السنوات من تاريخ ولادتها ونشأتها الي اليوم وهي رمز للعطاء بلا حدود حملت علي عاتقها رسالة ذات هدف وهي مشاركة الخبرات والتعلم معظمنا بدانا كسائلين للمساعدة في معلومة ما حتي وصلنا الي داعمين فاتحين قلوبنا لكل مبتغى مساعدة من خلال المشاركات تعلمنا وعلمنا يمكن معظم الفرسان الذي بدأت معهم انقطعوا عن المنتدي لظروف الحياة ومنهم من وافتهم المنية لكن اعمالهم واطروحتهم باقية تذكرنا بهم لندعو لهم بالرحمة وانا عن نفسي انقطعت كثيرا عن المشاركة لظروف صحية لكن اتابع من بعيد .الشكر لهم جمعيا م محمد طاهر المؤسس – عبدالله باقشير – شوقي ربيع – رجب جاويش –احمد فضيلة – ياسر خليل – حمادة عمر – مجدي يونس – جمال الدغيدي – نارت ليبزو – عبدالله المجرب.........والكثيرون مع حفظ الالقاب بارك الله فيهم جمعيا وفي كل عائلة اوفيسنا من اعضاء وفريق عمل . وبعد: فيسعدني أن أشارك المنتدى ببرنامج ادارة اشتراكات IPTV كان طلب لاحد الاخوة علي الخاص سائلين الله تعالى أن ينفع بما فيه من افكار لاستخدام خصائص الفورم الديناميكية وادارتها بشكل سلس . وما توفيقنا إلا بالله عليه توكلنا وإليه ننيب. شرح بسيط للبرنامج اولا : شاشة الدخول اضافة عدد غير محدود من المستخدمين . تحديد صلاحية المستخدم . حفظ كلمة المرور . عرض كلمة المرور. تقييد الدخول 3 محاولات للدخول الغير صحيح . تقرير عن الدخول لكل مستخدم مع الوقت والتاريخ . التحكم في الخيارات من خلال الفورم تبويب (User). ثانيا يوزالفورم كالتالي يحتوي علي العديد والعديد من المهام والوظائف - اضافة مشترك جديد -البحث عن مشترك بمعلومية الرقم التسلسلي او الاسم - تقارير متنوعة - شاشة مساعدة لشرح البرنامج - ادارة المستخدمين والصلاحيات. التبويب الأول ( تبويب جديد ) ادراج تاريخ اليوم بوالرقم التسلسلي شكل تلقائي - الاختيار من قائمة نوع الاشتراك وتعبئة تاريخ البداية والنهاية والسعر بشكل تلقائي - شروط اجبار المستخدم علي ادخال الييانات. التبويب الثاني (البحث ) - امكانية البحث بمعلومية الرقم التسلسلي أو اسم العميل . - اظهار حالة الاشتراك نشط او غير نشط - رسالة تنبيه علي انتهاء الاشتراك خلال ال5 ايام الاخيرة لنهاية الاشتراك. - تعديل بيانات الاشتراك (كلمة المرور - المستخدم - الماك - رقم الهاتف ) - امكانية تجديد الاشتراك. عند ظهور علامة الواتس بالضغط عليها ينتقل البرنامج لارسال رسالة للمشترك بقرب موعد انتهاء الاشتراك وبعد الارسال تظهر رسالة تفيد نجاح الارسال مع اداراج تاريخ الارسال التبويب الثالث (التقارير) تقارير بكافة الاشتراكات . تقرير بالاشتراكات النشطة. تقرير بالاشتراكات المنتهية . تقرير بالاشتراكات حسب الشهر . تقرير التنبيه علي انتهاء الاشتراك خلال ال5 ايام الاخيرة. كشف حساب عميل . طباعة اي تقرير. التبويب الرابع (ادارة الاشتراكات) اضافة اشتراك جديد مع السعر البحث وتعديل اي اشتراك التبويب الخامس (المساعدة) وفيه شرح لتبويبات وظائف البرنامج التبويب السادس (المستخدمين) ولا يمكن الوصول الي التقرير الا اذا كان الدخول ادمن مع المطالبة بادخال الباس ورد نفسها نفس باس ورد الدخول للبرنامج تقرير عن عمليات الدخول لكل مستخدم بالوقت والتاريخ والصلاحية والتي تظهر اسفل افورم. اضافة مستخدم جديد وتحديد صلاحياته البحث وتعديل مستخدم حالي. البرنامج بالمرفقات كلمة المرور الافتراضية 1234 المستخدم Dahy يعمل فقط علي 32bit ZAD IPTV Subscription.xlsm

ممكن كتابة الكود التالى فى ملف Text ثم بعد ذلك حفظ الملف باسم : UnblockDatabase.ps1 حتى يكون الملف الناتج عبارة عن ملف : PowerShell ويتم تشعيل الملف كمسئول وظيفة الكود الدوران على قواعد البيانات الموجوده فى المجلد الحالى او المجلدات الفرعيه للمجلد الحالى وازالة الحظر لهذه القواعد واقصد بالحظر هنا الموجودة بالصورة التاليه # التحقق من صلاحيات المسؤول if (-not ([Security.Principal.WindowsPrincipal] [Security.Principal.WindowsIdentity]::GetCurrent()).IsInRole([Security.Principal.WindowsBuiltInRole] "Administrator")) { Write-Host "❌ يجب تشغيل السكربت بصلاحيات المسؤول لتعيين سياسة التنفيذ." exit } # تعيين سياسة التنفيذ Set-ExecutionPolicy -Scope LocalMachine -ExecutionPolicy RemoteSigned -Force Write-Host "✅ تم تعيين سياسة التنفيذ إلى RemoteSigned على مستوى الجهاز." # الحصول على المسار الحالي للمجلد الذي يحتوي على الكود $currentFolder = $PSScriptRoot # البحث عن جميع ملفات قواعد البيانات (مثل *.accdb و *.mdb) في المجلد الحالي والمجلدات الفرعية $databaseFiles = Get-ChildItem -Path $currentFolder -Include *.accdb, *.mdb -Recurse # التحقق من وجود ملفات قاعدة البيانات if ($databaseFiles) { foreach ($file in $databaseFiles) { try { # إزالة الحظر من الملف $zoneIdentifier = "$($file.FullName):Zone.Identifier" if (Test-Path $zoneIdentifier) { Remove-Item -Path $zoneIdentifier -Force Write-Host "تم إزالة الحظر من الملف: $($file.FullName)" } else { Write-Host "الملف غير محظور: $($file.FullName)" } } catch { Write-Host "حدث خطأ أثناء محاولة إزالة الحظر من الملف: $($file.FullName) - $_" } } } else { Write-Host "لم يتم العثور على ملفات قاعدة بيانات في المجلد الحالي." } UnblockDatabase.zip

وعليكم السلام ورحمة الله وبركاته ="D:\الهويات\Pictures\" & ROW(A1) & ".jpg" ثم لسحب للاسفل ويمكنك نسخها ولصقها كقيم يعد ذلك New Microsoft Excel Worksheet.xlsx

نعم يا استاذنا هذه واحدة وثغرة اخرى من خلال ارسال امر يتجاوز شاشة تسجيل الدخول ولكن لم اقم بتصويرها اخونا الشايب مبتدئ وليس باستاذ ولكن اعتقد انه يكفي مع الاخذ بعين الاعتبار ان اكسس ضعيف في موضوع الحماية واذكر في موضوع سابق من عدة سنوات تحدثنا عن ثغرة مختلفة وقمتم بارسال ملف عالج الموضوع بشكل متميز لذا يعتقد الاخ شايب ان اكواد محمد عصام عصيه على الكسر وخصوصا من شايب مبتدئ تم الاختراق عن طريق حقن النصوص وهنا كتبنا كلمة المرور باسلوب معين وهذه الطريقة ليست حكرا على الاكسس وانما اي استعلام لم يتم اخذ الاحتياطات الخاص ببعض الحروف والرموز كتبت x' or 'x'='x او اي كلمة المهم توظيف الرمز . بشكل صحيح ممتاز 👍 اخونا الشايب

اساتذتي @ابو جوديو @Foksh جزاكم الله كل خير على هذه المعلومات القيمة

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

الله يبارك فيك أستاذ @Foksh طبعاَ بعد توفيق الله واتباع جميع الملاحظات في مشاركتكم و الأستاذ @ابو جودي وتحديداً إزالة إلغاء الحظر (Unblock) من خصائص قاعدة البيانات قبل تشغيل البرنامج ، وأكرر شكري لكم جميعاَ

دعنا نتبع طريقة الاستاذ جعفر .. وحقيقة هي الطريقة النظامية التي تحترم خصوصية العميل و هي خفض امان برنامجنا فقط .. وابقاء الحماية على اي ملف اكسس آخر يتم تشغيله وتتم من خلال أضافة موقع قاعدة البيانات ( المجلد ) إلى المواقع الموثوقة. وجعله مجلدا موثوقًا وبما في داخله من ملفات اكسس. يتم ذلك يدويا في مركز التوثيق ضمن خيارات اكسس . وبما انك ذكرت ان الاجهزة الاخرى لا تحتوي على اكسس كامل فيمكن معالجة الامر برمجيا واضافة توثيق مجلد البرنامج لاحظ ان موقع البرنامج سيكون ثابت في مكان محدد .. ولو تم تغيير الموقع مستقبلا فستعود الحماية طبعا الموقع وتحديده او تغييره متاح لك من خلال سطر الكود في المرفقات ملف ريجستري يقوم باعطاء الثقة لمجلد محدد .. للتجربة : ارفع مستوى الحماية في اكسس عندك .. وافتح قاعدة بيانات محددة للتأكد ان الحماية فعالة غير الامتداد الى txt وافتح الملف وغير اسم المجلد وموقعه حسب ما لديك .. واحفظ واغلق ثم اعد تسمية الامتداد انتبه لرقم اصدار اكسس .. فالموجود في الملف 14 لأكسس 10 شغل الملف اذهب بعدها للمقارنة بين القواعد التي خارج المجلد الهدف والقاعدة التي داخله ---------------------------------------------------------------------------------------------------- نعم يمكن .. انا استخدم ملفات باتش bat. يتم تشغيلها اثناء او بالاصح في نهاية عملية التنصيب ,, واستخدمها لاغراض اخرى وليست للأمان وانما استخدم ملفات exe لخفض الأمان لم اجرب reg فلعلك تجرب وتخبرنا بالنتيجة ( يمكنك كتابة الاسطر داخل برنامج التحزيم .. ان كان يدعم ذلك ) AccessTrusted.rar

انت دائمًا نعمل على تحسين وتطوير التطبيق لتقديم أفضل تجربة ممكنة. إذا كنت تتساءل عن التحديثات الأخيرة أو القادمة، لمعرفة إذا كانت هناك نسخة جديدة متاحة.

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

وأنا فكرتي أني ما غيرتش في طريقة عرض البيانات حسب رغبة صاحب المشروع مراعياً حاجته ، فقد تكون الفكرة عدم إظهار السجلات إلى المفلترة فقط ( خصوصية مثلاً ، أو سجلات كبيرة وكثيرة )

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

كليك يمين على قاعدة البيانات واختر خصائص التأكد من ازالة التاشير ان كان موجودا وبعد فتح قاعدة البيانات التأكد من الاعدادت

هذه المشكلة تخص مركز التوثيق في آكسيس .. وتفعيل الماكرو أو تأكد من التالي ..

تتعدد الأسباب ، والموت واحد

طيب ودى فكرتى test(2).accdb

وعليكم السلام ورحمة الله وبركاته .. تفضل محاولتي البسيطة test.accdb

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

ده بسبب اعدادات اللغة المحلية والاقليمية راجع هذا الموضوع للاستاذ @Foksh تجد فيه الحل ان شاء الله لهذه المشكلة العويصة التى تؤرق حياة الناس

انا الان بت حريصا على استخدام التالى : تشفير كلمة المرور : HashPasswordSHA256 استخدام المعلمات عن طريق : QueryDef هل هذا كافى يا استاذ @شايب لتجنب مثل هذه الهجمات والاختراقات المتقدمه الممكنة كود تشفير كلمات المرور بالشكل التالى Public Function HashPasswordSHA256(ByVal Password As String) As String Dim xmlObj As Object Dim bytes() As Byte Dim hash() As Byte Dim i As Integer Dim result As String ' استخدام كائن MSXML2 Set xmlObj = CreateObject("System.Security.Cryptography.SHA256Managed") ' تحويل النص إلى مصفوفة بايتات bytes = StrConv(Password, vbFromUnicode) ' حساب التجزئة hash = xmlObj.ComputeHash_2(bytes) ' تحويل النتيجة إلى سلسلة نصوص For i = LBound(hash) To UBound(hash) result = result & LCase(Right("0" & Hex(hash(i)), 2)) Next i ' إعادة النتيجة النهائية HashPasswordSHA256 = result ' تنظيف الموارد Set xmlObj = Nothing End Function اما بخصوص استخدام المعلمات عن طريق : QueryDef هذا شكل الاستعلام للتحقق من البيانات Dim db As DAO.Database Dim qdf As DAO.QueryDef Dim rst As DAO.Recordset Dim strSQL As String ' SQL مع معلمات strSQL = "SELECT UserName, IsActive FROM Users WHERE UserName = [paramUserName] AND Password = [paramPassword]" ' إعداد قاعدة البيانات وإنشاء QueryDef Set db = CurrentDb Set qdf = db.CreateQueryDef("", strSQL) ' تعيين القيم للمعلمات qdf.Parameters("paramUserName").Value = Me.UserNametxt qdf.Parameters("paramPassword").Value = Me.Passwordtxt

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

السلام عليكم في اعمالي دوما اجعل خصائص النماذج والتقارير منبثق ( pop Up) = نعم و النمط النموذجي (modal ) = نعم وكذلك التقارير مخالفا في ذلك طريقة الاستاذ جعفر .. حيث اوضح في احدى مشاركاته انه يتجنب هذه الخصيصة . ولكن في معمعة التصميم اجعلها كلها = لا والسبب انني احتاج الى فتح اكثر من نموذج وتقرير والتعامل معها في نفس الوقت واحيانا انتهي من المشروع واضبط الجميع على الخصيصة = نعم ثم يطرأ تعديلات في المشروع على اكثر من نموذج وتقرير وهنا انا ملزم بتغيير الخصيصة الى = لا من اجل تسهيل العمل والتنقل احيانا يكون التعديل على 3 او 4 نماذج او اكثر ولكم ان تتخيلوا ان المشروع احيانا يشتمل على اكثر من 20 نموذجا ومثلها او اكثر من التقارير وفي النهاية ومن باب الحرص على الضبط .. اقوم بفتح جميع النماذج والتقارير للتأكد من ان الخصيصة على ما يرام ، وهذا لا شك مرهق ويأخذ من الجهد والوقت الكثير .. لذا هداني الله لدالة تقوم بالعمل نيابة عني في جزء من الثانية تجدون ادناه الدالة لتفعيل الخصائص المختارة .. ولاحظوا انه يمكن عكس العملية وبسهولة الدالة عامة لجميع الخصائص .. عليك اختيار الخصيصة فقط لتعميمها على جميع النماذج ومثلها ايضا على جميع التقارير 'تطبيق على جميع النماذج Public Function funforms() Dim frm As Object For Each frm In CurrentProject.AllForms DoCmd.OpenForm frm.Name, acDesign Forms(frm.Name).PopUp = True Forms(frm.Name).Modal = True Forms(frm.Name).ShortcutMenu = False DoCmd.Close acForm, frm.Name, acSaveYes Next End Function ' ومثلها للتقارير Public Function funreports() Dim rep As Object For Each rep In CurrentProject.AllReports DoCmd.OpenReport rep.Name, acDesign Reports(rep.Name).PopUp = True Reports(rep.Name).Modal = True Reports(rep.Name).ShortcutMenuBar = "cmb_Copy_Sort_Filter" 'قائمة استاذنا جعفر المختصرة DoCmd.Close acReport, rep.Name, acSaveYes Next End Function

السلام عليكم ورحمة الله وبركاته استاذى الجليل و معلمى القدير و والدى الحبيب الاستاذ @ابوخليل ممكن نكتب الكود بالشكل ده ليكون دالة واحدة فقط ' دالة لتطبيق الإعدادات على النماذج والتقارير Public Sub ApplySettingsToAllObjects() Dim obj As Object On Error Resume Next ' تجاهل الأخطاء لتجنب توقف الكود ' تطبيق الإعدادات على النماذج For Each obj In CurrentProject.AllForms DoCmd.openForm obj.Name, acDesign Forms(obj.Name).PopUp = True Forms(obj.Name).Modal = True Forms(obj.Name).ShortcutMenu = False DoCmd.Close acForm, obj.Name, acSaveYes Next ' تطبيق الإعدادات على التقارير For Each obj In CurrentProject.AllReports DoCmd.openReport obj.Name, acDesign Reports(obj.Name).PopUp = True Reports(obj.Name).Modal = True Reports(obj.Name).ShortcutMenuBar = "cmb_Copy_Sort_Filter" ' قائمة استاذنا جعفر المختصرة DoCmd.Close acReport, obj.Name, acSaveYes Next On Error GoTo 0 ' إعادة تفعيل التعامل مع الأخطاء MsgBox "تم تطبيق الإعدادات على جميع النماذج والتقارير بنجاح!", vbInformation End Sub وزيادة فى الخير واثراء للموضوع هذا الموضوع ايضا لاشرطة الاوامر المختصرة

وفى هذا الرابط شرح الـ Command Line الخاص بالاداة المستخدمه من الموقع الرسمى لها https://zint.org.uk/manual/chapter/4

اظافة زر طباعة attedance report.xlsb

أظن أنه يمكننا إضافة شرط التحقق من كلمة المرور عند محاولة غلق الحسابات في الكود بحيث لا يمكن لأي شخص تنفيذه إلا إذا كان يعرف كلمة المرور الصحيحة هذا يضيف طبقة أمان إضافية للحماية ويضمن أن الشخص الذي يقوم بالعملية هو الشخص المخول فقط جرب هدا التعديل Option Explicit Private Const Clé As String = "1234" Public Property Get WS() As Worksheet Set WS = Sheets("Sheet1") End Property Sub ProtectSheet(xligne As Long) With WS .Unprotect Password:=Clé: .Cells.Locked = False .Range("A2:M" & xligne).FormulaHidden = True .Range("A2:M" & xligne).Locked = True: .Protect Password:=Clé End With End Sub Sub WSUnprotect() With WS .Unprotect Password:=Clé .Cells.Locked = False .Cells.FormulaHidden = False End With End Sub Sub Data_Protection() Dim xligne As Long If InputBox("أدخل كلمة المرور للمتابعة") <> Clé Then MsgBox "كلمة المرور غير صحيحة تم إلغاء العملية", vbCritical Exit Sub End If xligne = Application.InputBox("أدخل رقم الصف الأخير لقفل الخلايا", Type:=1) If xligne < 1 Or xligne > WS.Rows.Count Then MsgBox "خطأ في الإدخال يرجى إدخال رقم صف صحيح", vbExclamation Exit Sub End If SetApp False ProtectSheet xligne SetApp True MsgBox "تم قفل الحسابات بنجاح لغاية الصف: " & xligne, vbInformation End Sub Sub Data_UnProtection() Dim PassProtect As String PassProtect = InputBox("أدخل كلمة المرور لفك الحماية") If PassProtect = Clé Then SetApp False: WSUnprotect: SetApp True MsgBox "تم فتح جميع الحسابات بنجاح", vbInformation ElseIf PassProtect <> "" Then MsgBox "كلمة المرور غير صحيحة", vbCritical End If End Sub Private Sub SetApp(ByVal enable As Boolean) On Error GoTo xError Application.ScreenUpdating = enable Application.EnableEvents = enable Application.Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) Exit Sub xError: End Sub غلق المدى المحدد .xlsb

اثراء للموضوع ومشاركة مع احبابى واساتذتى العظماء اليكم تجميعه بأهم دوال الوقت الوتاريخ مجمعة فى وحدة نمطية عامة واحدة Public Function IsValidDate(ByVal dtDate As Date) As Boolean ' الغرض: التحقق مما إذا كان التاريخ المقدم تاريخًا صالحًا. ' الوسائط: dtDate - التاريخ المطلوب التحقق منه. ' الإرجاع: True إذا كان التاريخ صالحًا؛ وإلا False. ' مثال الاستخدام: ' If IsValidDate(txtDate) Then ' ' قم بعمل شيء ما مع التاريخ الصالح ' End If On Error Resume Next IsValidDate = IsDate(dtDate) On Error GoTo 0 End Function '1 Function FormatDate(ByVal vDate As Variant) As String ' الغرض: إرجاع سلسلة نصية بتنسيق التاريخ المستخدم بشكل طبيعي في . ' JET SQL. ' الوسيط: قيمة تاريخ/وقت. ' ملاحظة: يتم إرجاع تنسيق التاريخ فقط إذا لم يكن هناك مكون وقت، أو تنسيق التاريخ/الوقت إذا كان موجودًا. ' ' مثال الاستخدام: ' a = DLookup("[some field]", "some table", "[id]=" & Me.ID & " And [Date_Field]=" & FormatDate(The_Date_Field)) If IsDate(vDate) Then If DateValue(vDate) = vDate Then FormatDate = Format$(vDate, "\#mm\/dd\/yyyy\#") Else FormatDate = Format$(vDate, "\#mm\/dd\/yyyy hh\:nn\:ss\#") End If End If End Function Function GetAmericanDateFormat(ByVal vDate As Variant) As Date ' الغرض: تنسيق قيمة التاريخ إلى التنسيق الأمريكي (MM-dd-yyyy). ' الوسيط: قيمة تاريخ/وقت أو قيمة فارغة/غير محددة. ' ملاحظة: يتم إرجاع التاريخ الحالي بتنسيق MM-dd-yyyy إذا كانت الوسيطة فارغة أو غير محددة. ' ' ' ' مثال الاستخدام: ' formattedDate = GetAmericanDateFormat(SomeDateField) If IsNull(vDate) Or vDate = vbNullString Or Len(vDate) = 0 Then GetAmericanDateFormat = Format(Date, "MM-dd-yyyy", vbUseSystem) ElseIf IsValidDate(vDate) Then GetAmericanDateFormat = Format(CDate(vDate), "MM-dd-yyyy", vbUseSystem) Else GetAmericanDateFormat = "" End If End Function Function GetDateInEuropeanFormat(ByVal vDate As Variant) As Date ' الغرض: تنسيق قيمة التاريخ إلى التنسيق الأوروبي (dd-MM-yyyy). ' الوسيط: قيمة تاريخ/وقت أو قيمة فارغة/غير محددة. ' ملاحظة: يتم إرجاع التاريخ الحالي بتنسيق dd-MM-yyyy إذا كانت الوسيطة فارغة أو غير محددة. ' ' مثال الاستخدام: ' formattedDate = GetDateInEuropeanFormat(SomeDateField) If IsNull(vDate) Or Len(vDate) = 0 Then GetDateInEuropeanFormat = Format(Date, "dd-MM-yyyy", vbUseSystem) ElseIf IsValidDate(vDate) Then GetDateInEuropeanFormat = Format(CDate(vDate), "dd-MM-yyyy", vbUseSystem) Else GetDateInEuropeanFormat = "" End If End Function '----------------------------End------------------------------------------------------------------------------------------- '2 Public Function ConvertDate(ByRef strInputDate As String, ByVal strConversionType As String) As String ' الغرض: تحويل التاريخ بين التنسيق الهجري والميلادي بناءً على نوع التحويل المحدد. ' الوسائط: strInputDate - التاريخ المراد تحويله كسلسلة نصية. ' strConversionType - نوع التحويل، "H" للتحويل من الهجري إلى الميلادي، "M" للتحويل من الميلادي إلى الهجري. ' ملاحظة: يتم تعديل التاريخ وفقًا لليوم التصحيحي من الجدول tblAdjustHjriDate. ' ' مثال الاستخدام: ' convertedDate = ConvertDate(txtHijriDate, "H") ' تحويل من الهجري إلى الميلادي ' convertedDate = ConvertDate(txtMiladyDate, "M") ' تحويل من الميلادي إلى الهجري Dim intCorrectionDay As Integer Dim intSavedCalendar As Integer Dim dtConvertedDate As Date Dim strFormattedDate As String On Error GoTo ErrorHandler ' الحصول على يوم التصحيح من الجدول intCorrectionDay = DLookup("[AdjustDay]", "tblAdjustHjriDate") ' التحقق من صحة التاريخ المدخل If IsValidDate(strInputDate) Then ' تعيين نوع التقويم وتحويل التاريخ بناءً على نوع التحويل If strConversionType = "M" Then ' الميلادي إلى الهجري strInputDate = Trim(Format(DateAdd("d", -intCorrectionDay, strInputDate), "dd/mm/yyyy")) intSavedCalendar = VBA.calendar VBA.calendar = 1 dtConvertedDate = CDate(strInputDate) VBA.calendar = intSavedCalendar Else ' الهجري إلى الميلادي strInputDate = Trim(Format(DateAdd("d", intCorrectionDay, strInputDate), "dd/mm/yyyy")) intSavedCalendar = VBA.calendar VBA.calendar = 0 dtConvertedDate = CDate(strInputDate) VBA.calendar = 1 End If ' تنسيق التاريخ المحول كسلسلة نصية strFormattedDate = Format(dtConvertedDate, "dd/mm/yyyy") ConvertDate = strFormattedDate Else ConvertDate = "" End If Exit Function ErrorHandler: If err.Number = 13 Then MsgBox "تنسيق تاريخ غير صالح. يرجى التحقق من البيانات المدخلة.", vbOKOnly + vbExclamation, "خطأ" Else MsgBox "حدث خطأ غير متوقع: " & err.Description, vbOKOnly + vbCritical, "خطأ" End If Exit Function End Function '----------------------------End------------------------------------------------------------------------------------------- '3 Public Function ConvertNumberToLocale(ByVal strNumber As String, ByVal strLocale As String) As String ' الغرض: تحويل الأرقام بين النظام العددي العربي والإنجليزي بناءً على اللغة المحددة. ' الوسائط: strNumber - السلسلة الرقمية المراد تحويلها. ' strLocale - نوع اللغة، "Ar" للأرقام العربية، "En" للأرقام الإنجليزية. ' ملاحظة: تقوم بتحويل الأرقام من العربية إلى الإنجليزية والعكس. ' ' مثال الاستخدام: ' txtNumberToArabic = ConvertNumberToLocale(txtNumber, "Ar") ' تحويل الأرقام الإنجليزية إلى عربية ' txtNumberToEnglish = ConvertNumberToLocale(txtNumber, "En") ' تحويل الأرقام العربية إلى إنجليزية Dim strConvertedNumber As String If strLocale = "Ar" Then ' تحويل الأرقام الإنجليزية إلى عربية strConvertedNumber = Replace(strNumber, ChrW(48), ChrW(1632)) ' 0 strConvertedNumber = Replace(strConvertedNumber, ChrW(49), ChrW(1633)) ' 1 strConvertedNumber = Replace(strConvertedNumber, ChrW(50), ChrW(1634)) ' 2 strConvertedNumber = Replace(strConvertedNumber, ChrW(51), ChrW(1635)) ' 3 strConvertedNumber = Replace(strConvertedNumber, ChrW(52), ChrW(1636)) ' 4 strConvertedNumber = Replace(strConvertedNumber, ChrW(53), ChrW(1637)) ' 5 strConvertedNumber = Replace(strConvertedNumber, ChrW(54), ChrW(1638)) ' 6 strConvertedNumber = Replace(strConvertedNumber, ChrW(55), ChrW(1639)) ' 7 strConvertedNumber = Replace(strConvertedNumber, ChrW(56), ChrW(1640)) ' 8 strConvertedNumber = Replace(strConvertedNumber, ChrW(57), ChrW(1641)) ' 9 ElseIf strLocale = "En" Then ' تحويل الأرقام العربية إلى إنجليزية strConvertedNumber = Replace(strNumber, ChrW(1632), ChrW(48)) ' 0 strConvertedNumber = Replace(strConvertedNumber, ChrW(1633), ChrW(49)) ' 1 strConvertedNumber = Replace(strConvertedNumber, ChrW(1634), ChrW(50)) ' 2 strConvertedNumber = Replace(strConvertedNumber, ChrW(1635), ChrW(51)) ' 3 strConvertedNumber = Replace(strConvertedNumber, ChrW(1636), ChrW(52)) ' 4 strConvertedNumber = Replace(strConvertedNumber, ChrW(1637), ChrW(53)) ' 5 strConvertedNumber = Replace(strConvertedNumber, ChrW(1638), ChrW(54)) ' 6 strConvertedNumber = Replace(strConvertedNumber, ChrW(1639), ChrW(55)) ' 7 strConvertedNumber = Replace(strConvertedNumber, ChrW(1640), ChrW(56)) ' 8 strConvertedNumber = Replace(strConvertedNumber, ChrW(1641), ChrW(57)) ' 9 End If ConvertNumberToLocale = strConvertedNumber End Function '----------------------------End------------------------------------------------------------------------------------------- '4 Public Function GetMonthName(ByVal dtDate As Date, ByVal strLocale As String) As String ' الغرض: إرجاع اسم الشهر بناءً على اللغة المحددة. ' الوسائط: dtDate - التاريخ الذي يتم استخراج اسم الشهر منه. ' strLocale - نوع اللغة لتحديد لغة اسم الشهر. ' "HJ" للهجري، "Ar" للعربية، "En" للإنجليزية، "EnShrt" للإنجليزية المختصرة، ' "Cpti" للقبطية، "Syr" للسريانية. ' الإرجاع: اسم الشهر باللغة المحددة. ' ' مثال الاستخدام: ' txtMonthNameHijri = GetMonthName(txtDate, "HJ") ' اسم الشهر الهجري ' txtMonthNameArabic = GetMonthName(txtDate, "Ar") ' اسم الشهر العربي ' txtMonthNameEnglish = GetMonthName(txtDate, "En") ' اسم الشهر الإنجليزي ' txtMonthNameEnglishShort = GetMonthName(txtDate, "EnShrt") ' اسم الشهر الإنجليزي المختصر ' txtMonthNameCoptic = GetMonthName(txtDate, "Cpti") ' اسم الشهر القبطي ' txtMonthNameSyriac = GetMonthName(txtDate, "Syr") ' اسم الشهر السرياني Dim strMonthName(12) As String ' التحقق من صحة اللغة المحددة If strLocale <> "HJ" And strLocale <> "Ar" And strLocale <> "En" And strLocale <> "EnShrt" And strLocale <> "Cpti" And strLocale <> "Syr" And strLocale <> "No" Then MsgBox "اللغة المحددة غير صالحة. يرجى استخدام 'HJ'، 'Ar'، 'En'، 'EnShrt'، 'Cpti'، 'Syr'، أو 'No'.", vbExclamation, "خطأ" Exit Function End If If IsValidDate(dtDate) Then ' تحديد أسماء الأشهر لكل لغة Select Case strLocale Case "HJ" ' أسماء الأشهر الهجرية strMonthName(1) = "محرم" strMonthName(2) = "صفر" strMonthName(3) = "ربيع الأول" strMonthName(4) = "ربيع الآخر" strMonthName(5) = "جمادى الأولى" strMonthName(6) = "جمادى الآخرة" strMonthName(7) = "رجب" strMonthName(8) = "شعبان" strMonthName(9) = "رمضان" strMonthName(10) = "شوال" strMonthName(11) = "ذو القعدة" strMonthName(12) = "ذو الحجة" Case "Ar" ' أسماء الأشهر العربية strMonthName(1) = "يناير" strMonthName(2) = "فبراير" strMonthName(3) = "مارس" strMonthName(4) = "أبريل" strMonthName(5) = "مايو" strMonthName(6) = "يونيو" strMonthName(7) = "يوليو" strMonthName(8) = "أغسطس" strMonthName(9) = "سبتمبر" strMonthName(10) = "أكتوبر" strMonthName(11) = "نوفمبر" strMonthName(12) = "ديسمبر" Case "En" ' أسماء الأشهر الإنجليزية strMonthName(1) = "January" strMonthName(2) = "February" strMonthName(3) = "March" strMonthName(4) = "April" strMonthName(5) = "May" strMonthName(6) = "June" strMonthName(7) = "July" strMonthName(8) = "August" strMonthName(9) = "September" strMonthName(10) = "October" strMonthName(11) = "November" strMonthName(12) = "December" Case "EnShrt" ' أسماء الأشهر الإنجليزية المختصرة strMonthName(1) = "Jan" strMonthName(2) = "Feb" strMonthName(3) = "Mar" strMonthName(4) = "Apr" strMonthName(5) = "May" strMonthName(6) = "Jun" strMonthName(7) = "Jul" strMonthName(8) = "Aug" strMonthName(9) = "Sep" strMonthName(10) = "Oct" strMonthName(11) = "Nov" strMonthName(12) = "Dec" Case "Cpti" ' أسماء الأشهر القبطية strMonthName(1) = "Thout" strMonthName(2) = "Paope" strMonthName(3) = "Hator" strMonthName(4) = "Kiahk" strMonthName(5) = "Tobi" strMonthName(6) = "Meshir" strMonthName(7) = "Paremhat" strMonthName(8) = "Paremhou" strMonthName(9) = "Pashons" strMonthName(10) = "Paoni" strMonthName(11) = "Epip" strMonthName(12) = "Nasi" Case "Syr" ' أسماء الأشهر السريانية strMonthName(1) = "Nisan" strMonthName(2) = "Iyar" strMonthName(3) = "Sivan" strMonthName(4) = "Tammuz" strMonthName(5) = "Ab" strMonthName(6) = "Elul" strMonthName(7) = "Tishri" strMonthName(8) = "Heshvan" strMonthName(9) = "Kislev" strMonthName(10) = "Tevet" strMonthName(11) = "Shevat" strMonthName(12) = "Adar" Case "No" ' أسماء الأشهر بالأرقام strMonthName(1) = "( 01 )" strMonthName(2) = "( 02 )" strMonthName(3) = "( 03 )" strMonthName(4) = "( 04 )" strMonthName(5) = "( 05 )" strMonthName(6) = "( 06 )" strMonthName(7) = "( 07 )" strMonthName(8) = "( 08 )" strMonthName(9) = "( 09 )" strMonthName(10) = "( 10 )" strMonthName(11) = "( 11 )" strMonthName(12) = "( 12 )" End Select ' إرجاع اسم الشهر للتاريخ المحدد GetMonthName = strMonthName(Month(dtDate)) Else ' إرجاع سلسلة فارغة إذا كان التاريخ غير صالح GetMonthName = "" End If End Function '----------------------------End------------------------------------------------------------------------------------------- '5 Public Function GetDayName(ByVal dtAnyDate As Date, ByVal strLng As String) As String ' الغرض: إرجاع اسم اليوم بناءً على التاريخ واللغة المحددة. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج اسم اليوم منه. ' strLng - نوع اللغة لاسم اليوم: ' "Ar" للعربية، "En" للإنجليزية، "EnShrt" للإنجليزية المختصرة. ' الإرجاع: اسم اليوم باللغة المحددة. ' ' مثال الاستخدام: ' txtDayNameAR = DayName(txtDate, "Ar") ' اسم اليوم بالعربية ' txtDayNameEn = DayName(txtDate, "En") ' اسم اليوم بالإنجليزية ' txtDayNameEnShrt = DayName(txtDate, "EnShrt") ' اسم اليوم بالإنجليزية المختصرة Dim strSat As String Dim strSun As String Dim strMon As String Dim strTues As String Dim strWed As String Dim strThurs As String Dim strFri As String ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetDayName = "تاريخ غير صالح" Exit Function End If ' التحقق من صحة اللغة المحددة If strLng <> "Ar" And strLng <> "En" And strLng <> "EnShrt" Then MsgBox "اللغة المحددة غير صالحة. يرجى استخدام 'Ar'، 'En'، أو 'EnShrt'.", vbExclamation, "خطأ" Exit Function End If ' تحديد أسماء الأيام بناءً على اللغة Select Case strLng Case "Ar" strSat = "السبت" strSun = "الأحد" strMon = "الاثنين" strTues = "الثلاثاء" strWed = "الأربعاء" strThurs = "الخميس" strFri = "الجمعة" Case "En" strSat = "Saturday" strSun = "Sunday" strMon = "Monday" strTues = "Tuesday" strWed = "Wednesday" strThurs = "Thursday" strFri = "Friday" Case "EnShrt" strSat = "Sat" strSun = "Sun" strMon = "Mon" strTues = "Tue" strWed = "Wed" strThurs = "Thu" strFri = "Fri" End Select ' إرجاع اسم اليوم بناءً على يوم الأسبوع للتاريخ المحدد GetDayName = Choose(Weekday(dtAnyDate), strSun, strMon, strTues, strWed, strThurs, strFri, strSat) End Function '----------------------------End------------------------------------------------------------------------------------------- '6 Public Function NumofDays(ByVal dtAnyDate As Date) As Integer ' الغرض: إرجاع عدد الأيام في شهر التاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج عدد الأيام في شهره. ' الإرجاع: عدد الأيام في شهر التاريخ المحدد. ' ' مثال الاستخدام: ' txtNumofDaysMonth = NumofDays(txtDate) ' حساب آخر يوم في الشهر الحالي باستخدام الدالة DateSerial ' ثم إرجاع جزء اليوم من ذلك التاريخ، والذي يمثل العدد الإجمالي للأيام في ذلك الشهر. ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" NumofDays = -1 ' إرجاع قيمة غير صالحة للإشارة إلى خطأ Exit Function End If NumofDays = Day(DateSerial(Year(dtAnyDate), Month(dtAnyDate) + 1, 0)) End Function '----------------------------End------------------------------------------------------------------------------------------- '7 Public Function GetLastDayInMonth(ByVal dtAnyDate As Date) As Date ' الغرض: إرجاع آخر يوم في شهر التاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج آخر يوم في شهره. ' الإرجاع: آخر يوم في شهر التاريخ المحدد. ' ' مثال الاستخدام: ' txtLastDayInMonth = GetLastDayInMonth(txtDate) ' حساب آخر يوم في الشهر الحالي باستخدام الدالة DateSerial. ' تقوم هذه الدالة بإنشاء تاريخ مع السنة والشهر من التاريخ المحدد وتعيين اليوم إلى 0، ' مما يعطينا بشكل فعال آخر يوم في الشهر السابق، أي آخر يوم في الشهر الحالي. ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetLastDayInMonth = CDate("0001-01-01") ' إرجاع تاريخ غير صالح للإشارة إلى خطأ Exit Function End If GetLastDayInMonth = DateSerial(Year(dtAnyDate), Month(dtAnyDate) + 1, 0) End Function '----------------------------End------------------------------------------------------------------------------------------- '8 Public Function GetFirstDayOfMonth(ByVal dtAnyDate As Date) As Date ' الغرض: إرجاع أول يوم في شهر التاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج أول يوم في شهره. ' الإرجاع: أول يوم في شهر التاريخ المحدد. ' ' مثال الاستخدام: ' txtFirstDayOfMonth = GetFirstDayOfMonth(txtDate) ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetFirstDayOfMonth = CDate("0001-01-01") ' إرجاع تاريخ غير صالح للإشارة إلى خطأ Exit Function End If ' حساب أول يوم في الشهر الحالي باستخدام الدالة DateSerial GetFirstDayOfMonth = DateSerial(Year(dtAnyDate), Month(dtAnyDate), 1) End Function '----------------------------End------------------------------------------------------------------------------------------- '9 Public Function GetFirstDayOfNextMonth(ByVal dtAnyDate As Date) As Date ' الغرض: إرجاع أول يوم في الشهر التالي للتاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج أول يوم في الشهر التالي له. ' الإرجاع: أول يوم في الشهر التالي للتاريخ المحدد. ' ' مثال الاستخدام: ' txtFirstDayOfNextMonth = GetFirstDayOfNextMonth(txtDate) ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetFirstDayOfNextMonth = CDate("0001-01-01") ' إرجاع تاريخ غير صالح للإشارة إلى خطأ Exit Function End If ' إرجاع أول يوم في الشهر التالي باستخدام الدالة DateSerial GetFirstDayOfNextMonth = DateSerial(Year(dtAnyDate), Month(dtAnyDate) + 1, 1) End Function '----------------------------End------------------------------------------------------------------------------------------- '10 Public Function GetFirstDayOfPreviousMonth(ByVal dtAnyDate As Date) As Date ' الغرض: إرجاع أول يوم في الشهر السابق للتاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج أول يوم في الشهر السابق له. ' الإرجاع: أول يوم في الشهر السابق للتاريخ المحدد. ' ' مثال الاستخدام: ' txtFirstDayOfPreviousMonth = GetFirstDayOfPreviousMonth(txtDate) ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetFirstDayOfPreviousMonth = CDate("0001-01-01") ' إرجاع تاريخ غير صالح للإشارة إلى خطأ Exit Function End If ' إرجاع أول يوم في الشهر السابق باستخدام الدالة DateSerial GetFirstDayOfPreviousMonth = DateSerial(Year(dtAnyDate), Month(dtAnyDate) - 1, 1) End Function '----------------------------End------------------------------------------------------------------------------------------- '11 Public Function GetLastDayOfMonth(ByVal dtAnyDate As Date) As Date ' الغرض: إرجاع آخر يوم في شهر التاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج آخر يوم في شهره. ' الإرجاع: آخر يوم في شهر التاريخ المحدد. ' ' مثال الاستخدام: ' txtLastDayOfMonth = GetLastDayOfMonth(txtDate) ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetLastDayOfMonth = CDate("0001-01-01") ' إرجاع تاريخ غير صالح للإشارة إلى خطأ Exit Function End If ' إرجاع آخر يوم في الشهر باستخدام الدالة DateSerial GetLastDayOfMonth = DateSerial(Year(dtAnyDate), Month(dtAnyDate) + 1, 0) End Function '----------------------------End------------------------------------------------------------------------------------------- '12 Public Function GetLastDayOfNextMonth(ByVal dtAnyDate As Date) As Date ' الغرض: إرجاع آخر يوم في الشهر التالي للتاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج آخر يوم في الشهر التالي له. ' الإرجاع: آخر يوم في الشهر التالي للتاريخ المحدد. ' ' مثال الاستخدام: ' txtLastDayOfNextMonth = GetLastDayOfNextMonth(txtDate) ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetLastDayOfNextMonth = CDate("0001-01-01") ' إرجاع تاريخ غير صالح للإشارة إلى خطأ Exit Function End If ' إرجاع آخر يوم في الشهر التالي باستخدام الدالة DateSerial GetLastDayOfNextMonth = DateSerial(Year(dtAnyDate), Month(dtAnyDate) + 2, 0) End Function '----------------------------End------------------------------------------------------------------------------------------- '13 Public Function GetLastDayOfPreviousMonth(ByVal dtAnyDate As Date) As Date ' الغرض: إرجاع آخر يوم في الشهر السابق للتاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج آخر يوم في الشهر السابق له. ' الإرجاع: آخر يوم في الشهر السابق للتاريخ المحدد. ' ' مثال الاستخدام: ' txtLastDayOfPreviousMonth = GetLastDayOfPreviousMonth(txtDate) ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetLastDayOfPreviousMonth = CDate("0001-01-01") ' إرجاع تاريخ غير صالح للإشارة إلى خطأ Exit Function End If ' إرجاع آخر يوم في الشهر السابق باستخدام الدالة DateSerial GetLastDayOfPreviousMonth = DateSerial(Year(dtAnyDate), Month(dtAnyDate), 0) End Function '----------------------------End------------------------------------------------------------------------------------------- '14 Public Function TimeByLanguage(ByVal dtAnyDate As Variant, ByVal strLng As String) As String ' الغرض: إرجاع الوقت بتنسيق اللغة المحددة. ' الوسائط: dtAnyDate - التاريخ/الوقت الذي يتم تنسيقه. ' strLng - اللغة المحددة لتنسيق الوقت ("Ar" للعربية، "En" للإنجليزية). ' الإرجاع: الوقت بتنسيق اللغة المحددة. ' ' مثال الاستخدام: ' txtTimeArabic = TimeByLanguage(txtDateTime, "Ar") ' الوقت بالعربية ' txtTimeEnglish = TimeByLanguage(txtDateTime, "En") ' الوقت بالإنجليزية ' التحقق من أن dtAnyDate تاريخ/وقت صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا/وقتًا صالحًا. يرجى إدخال تاريخ/وقت صحيح.", vbExclamation, "تاريخ/وقت غير صالح" TimeByLanguage = "تاريخ/وقت غير صالح" Exit Function End If ' تعريف نصوص AM وPM للغة العربية Dim strAm As String: strAm = "صباحًا " Dim strPm As String: strPm = "مساءً " ' تنسيق الوقت بناءً على اللغة المحددة Select Case strLng Case "Ar" ' تحويل الوقت إلى العربية واستبدال AM/PM بالنصوص العربية TimeByLanguage = ConvertNumberToLocale(Replace(Replace(Format(dtAnyDate, "hh:nn:ss AM/PM"), "AM", strAm), "PM", strPm), "Ar") Case "En" ' تحويل الوقت إلى الإنجليزية واستبدال النصوص العربية بـ AM/PM TimeByLanguage = ConvertNumberToLocale(Replace(Replace(Format(dtAnyDate, "hh:nn:ss AM/PM"), strAm, "AM"), strPm, "PM"), "En") Case Else ' إرجاع رسالة خطأ إذا كانت اللغة غير مدعومة TimeByLanguage = "اللغة غير مدعومة" End Select End Function '----------------------------End------------------------------------------------------------------------------------------- '15 Public Function GetLocalizedTimeString(ByVal strLng As String) As String ' الغرض: إرجاع الوقت الحالي بتنسيق اللغة المحددة. ' الوسائط: strLng - اللغة المحددة لتنسيق الوقت ("Ar" للعربية، "En" للإنجليزية). ' الإرجاع: الوقت الحالي بتنسيق اللغة المحددة. ' ' مثال الاستخدام: ' txtTimeArabic = GetLocalizedTimeString("Ar") ' الوقت الحالي بالعربية ' txtTimeEnglish = GetLocalizedTimeString("En") ' الوقت الحالي بالإنجليزية ' تعريف نصوص AM وPM للغة العربية Dim strAm As String: strAm = "صباحًا " Dim strPm As String: strPm = "مساءً " ' تنسيق الوقت بناءً على اللغة المحددة Select Case strLng Case "Ar" ' تحويل الوقت الحالي إلى العربية واستبدال AM/PM بالنصوص العربية GetLocalizedTimeString = ConvertNumberToLocale(Replace(Replace(Format(Now(), "hh:nn:ss AM/PM"), "AM", strAm), "PM", strPm), "Ar") Case "En" ' تحويل الوقت الحالي إلى الإنجليزية واستبدال النصوص العربية بـ AM/PM GetLocalizedTimeString = ConvertNumberToLocale(Replace(Replace(Format(Now(), "hh:nn:ss AM/PM"), strAm, "AM"), strPm, "PM"), "En") Case Else ' إرجاع رسالة خطأ إذا كانت اللغة غير مدعومة GetLocalizedTimeString = "اللغة غير مدعومة" End Select End Function '----------------------------End------------------------------------------------------------------------------------------- '16 Public Function FormatDateByLanguage(ByVal dtAnyDate As Variant, ByVal strLng As String) As String ' الغرض: إرجاع التاريخ بتنسيق اللغة المحددة. ' الوسائط: dtAnyDate - التاريخ الذي يتم تنسيقه. ' strLng - اللغة المحددة لتنسيق التاريخ ("Ar" للعربية، "En" للإنجليزية). ' الإرجاع: التاريخ بتنسيق اللغة المحددة. ' ' مثال الاستخدام: ' txtDateArabic = FormatDateByLanguage(txtDate, "Ar") ' التاريخ بالعربية ' txtDateEnglish = FormatDateByLanguage(txtDate, "En") ' التاريخ بالإنجليزية ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" FormatDateByLanguage = "تاريخ غير صالح" Exit Function End If ' تنسيق التاريخ بناءً على اللغة المحددة Select Case strLng Case "Ar" ' تحويل التاريخ إلى العربية وإضافة رمز "م" (لتحديد التقويم الميلادي) FormatDateByLanguage = ConvertNumberToLocale(Format(dtAnyDate, "dd\/mm\/yyyy") & Space(2) & "م ", "Ar") Case "En" ' تحويل التاريخ إلى الإنجليزية وإضافة رمز "هـ" (لتحديد التقويم الهجري) FormatDateByLanguage = ConvertNumberToLocale(Format(dtAnyDate, "dd\/mm\/yyyy") & Space(2) & "هـ ", "En") Case Else ' إرجاع رسالة خطأ إذا كانت اللغة غير مدعومة FormatDateByLanguage = "اللغة غير مدعومة" End Select End Function '----------------------------End------------------------------------------------------------------------------------------- Public Function GetFirstDayOfYear(Optional ReferenceYear As Integer = 0) As Date ' الغرض: إرجاع أول يوم في السنة المحددة. ' الوسائط: ReferenceYear - السنة المرجعية (اختياري، إذا لم يتم تحديدها، يتم استخدام السنة الحالية). ' الإرجاع: أول يوم في السنة المحددة (1 يناير). ' ' مثال الاستخدام: ' txtFirstDayOfYear = GetFirstDayOfYear(2023) ' أول يوم في سنة 2023 ' txtFirstDayOfYear = GetFirstDayOfYear() ' أول يوم في السنة الحالية ' تحديد السنة المرجعية If ReferenceYear = 0 Then ReferenceYear = Year(Now) ' استخدام السنة الحالية إذا لم يتم تحديد سنة مرجعية End If ' إرجاع أول يوم في السنة (1 يناير) GetFirstDayOfYear = DateSerial(ReferenceYear, 1, 1) End Function '----------------------------End------------------------------------------------------------------------------------------- Public Function GetLastDayOfYear(Optional ReferenceYear As Integer = 0) As Date ' الغرض: إرجاع آخر يوم في السنة المحددة. ' الوسائط: ReferenceYear - السنة المرجعية (اختياري، إذا لم يتم تحديدها، يتم استخدام السنة الحالية). ' الإرجاع: آخر يوم في السنة المحددة (31 ديسمبر). ' ' مثال الاستخدام: ' txtLastDayOfYear = GetLastDayOfYear(2023) ' آخر يوم في سنة 2023 ' txtLastDayOfYear = GetLastDayOfYear() ' آخر يوم في السنة الحالية ' تحديد السنة المرجعية If ReferenceYear = 0 Then ReferenceYear = Year(Now) ' استخدام السنة الحالية إذا لم يتم تحديد سنة مرجعية End If ' إرجاع آخر يوم في السنة (31 ديسمبر) GetLastDayOfYear = DateSerial(ReferenceYear, 12, 31) End Function '----------------------------End------------------------------------------------------------------------------------------- ' حساب الفرق بين تاريخين (بالأيام، الأشهر، السنوات) Public Function GetDateDifferenceInDays(ByVal dtStartDate As Date, ByVal dtEndDate As Date) As Long ' الغرض: حساب الفرق بين تاريخين بالأيام. GetDateDifferenceInDays = DateDiff("d", dtStartDate, dtEndDate) End Function Public Function GetDateDifferenceInMonths(ByVal dtStartDate As Date, ByVal dtEndDate As Date) As Long ' الغرض: حساب الفرق بين تاريخين بالأشهر. GetDateDifferenceInMonths = DateDiff("m", dtStartDate, dtEndDate) End Function Public Function GetDateDifferenceInYears(ByVal dtStartDate As Date, ByVal dtEndDate As Date) As Long ' الغرض: حساب الفرق بين تاريخين بالسنوات. GetDateDifferenceInYears = DateDiff("yyyy", dtStartDate, dtEndDate) End Function '----------------------------End------------------------------------------------------------------------------------------- ' إضافة أو طرح أيام/أشهر/سنوات من تاريخ معين Public Function AddDaysToDate(ByVal dtDate As Date, ByVal intDays As Integer) As Date ' الغرض: إضافة أو طرح عدد محدد من الأيام من تاريخ معين. AddDaysToDate = DateAdd("d", intDays, dtDate) End Function Public Function AddMonthsToDate(ByVal dtDate As Date, ByVal intMonths As Integer) As Date ' الغرض: إضافة أو طرح عدد محدد من الأشهر من تاريخ معين. AddMonthsToDate = DateAdd("m", intMonths, dtDate) End Function Public Function AddYearsToDate(ByVal dtDate As Date, ByVal intYears As Integer) As Date ' الغرض: إضافة أو طرح عدد محدد من السنوات من تاريخ معين. AddYearsToDate = DateAdd("yyyy", intYears, dtDate) End Function '----------------------------End------------------------------------------------------------------------------------------- ' التحقق مما إذا كان تاريخ معين ضمن نطاق تاريخين Public Function IsDateInRange(ByVal dtDate As Date, ByVal dtStartDate As Date, ByVal dtEndDate As Date) As Boolean ' الغرض: التحقق مما إذا كان تاريخ معين يقع بين تاريخين محددين. IsDateInRange = (dtDate >= dtStartDate And dtDate <= dtEndDate) End Function '----------------------------End------------------------------------------------------------------------------------------- ' حساب العمر بناءً على تاريخ الميلاد Public Function CalculateAge(ByVal dtBirthDate As Date) As Integer ' الغرض: حساب العمر بالسنوات بناءً على تاريخ الميلاد. CalculateAge = DateDiff("yyyy", dtBirthDate, Now) If DateSerial(Year(Now), Month(dtBirthDate), Day(dtBirthDate)) > Now Then CalculateAge = CalculateAge - 1 End If End Function '----------------------------End------------------------------------------------------------------------------------------- ' تحديد عدد الأيام منذ تاريخ معين Public Function GetDaysSinceDate(ByVal dtStartDate As Date) As Integer ' الغرض: حساب عدد الأيام المنقضية منذ تاريخ معين. GetDaysSinceDate = DateDiff("d", dtStartDate, Now) End Function '----------------------------End-------------------------------------------------------------------------------------------

تفضل أخي @al.sheen2000 دوال أول يوم بالشهر .... وآخر يوم بالشهر .... وأول يوم بالسنة .... وآخر يوم بالسنة . Private Sub BtnChangeDate_Click() If Len(Me.Txt1 & "") = 0 Then MsgBox "أدخل التاريخ " Undo Me.Txt1.SetFocus Exit Sub Else 'أول يوم بالشهر Me.Txt2 = DateSerial(Year(Me.Txt1), Month(Me.Txt1), 1) 'آخر يوم بالشهر Me.Txt3 = DateSerial(Year(Me.Txt1), Month(Me.Txt1) + 1, 0) Dim inputDate As Date Dim inputYear As Integer Dim lastDayOfYear As Date Dim firstDayOfYear As Date inputDate = CDate(Me.Txt1.Value) inputYear = Year(inputDate) ' Extract the year from the date 'أول يوم بالسنة firstDayOfYear = DateSerial(inputYear, 1, 1) ' Calculate the first day of the year Me.Txt4.Value = firstDayOfYear 'آخر يوم بالسنة lastDayOfYear = DateSerial(inputYear, 12, 31) ' Calculate the last day of the year Me.Txt5.Value = lastDayOfYear End If End Sub

شكرا لك , طبعا شرح ممتاز و الاداة جيدة جدا , اعتقد انه من زمان بندور على شغل زي كده , بس لو تكرمت , ممكن تكوين نموذج من الموبايل , بدل من الادخال , يكون للبحث يعني الادحال من الكومبيوتر والبحث يكون من الموبايل تحياتي الحارة لك

وعليكم السلام ورحمة الله تعالى وبركاته Sub MergeTotal() Dim WS As Worksheet, crWS As Worksheet, LastRow As Long, Irow As Long On Error Resume Next Set crWS = Sheets("total") On Error GoTo 0 If crWS Is Nothing Then MsgBox " غير موجودة total ورقة ", vbInformation Exit Sub Else Application.ScreenUpdating = False crWS.Range("A2:O" & crWS.Rows.Count).Clear End If Irow = 2 For Each WS In ThisWorkbook.Sheets If WS.Name <> crWS.Name Then LastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row If LastRow >= 2 Then WS.Range("A2:O" & LastRow).Copy crWS.Cells(Irow, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme Irow = crWS.Cells(crWS.Rows.Count, 1).End(xlUp).Row + 1 End If End If Next WS Application.CutCopyMode = False Application.ScreenUpdating = True End Sub or Sub MergeTotal() Dim WS As Worksheet, Src As Worksheet Dim OnRng As Variant, rng As Range, r As Range Dim lastRow As Long, tmp As Long, col As Integer Set WS = Sheets("total") Application.ScreenUpdating = False lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row If lastRow > 1 Then: WS.Rows("2:" & lastRow).Clear tmp = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row + 1 For Each Src In ThisWorkbook.Sheets If Src.Name <> WS.Name Then OnRng = Src.Range("A2:O" & Src.Cells(Src.Rows.Count, "A").End(xlUp).Row).Value WS.Cells(tmp, 1).Resize(UBound(OnRng, 1), UBound(OnRng, 2)).Value = OnRng For lastRow = 1 To Src.Cells(Src.Rows.Count, "A").End(xlUp).Row WS.Rows(tmp + lastRow - 1).RowHeight = 18.5 Next lastRow tmp = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row + 1 End If Next Src With WS.Range("A1:O" & WS.Cells(WS.Rows.Count, "A").End(xlUp).Row) .Borders.LineStyle = xlContinuous: .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter End With Application.ScreenUpdating = True End Sub الرواتب.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Dim PassProtect As String, OnRng As Range Private Const Clé As String = "1234" Public Property Get WS() As Worksheet: Set WS = Sheets("Sheet1"): End Property Sub Data_Protection() Dim linge As Variant Do linge = Application.InputBox("أدخل رقم الصف الأخير لقفل الخلايا", Type:=1) If linge = False Then Exit Sub If Not IsNumeric(linge) Or linge < 1 Or linge > WS.Rows.Count Then: MsgBox "خطأ في الإدخال" Exit Do Loop Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ' قم بتعديل النطاق بما يناسبك Set OnRng = WS.Range("A2:M" & linge) With WS If .ProtectContents Then .Unprotect password:=Clé .Cells.Locked = False OnRng.FormulaHidden = True OnRng.Locked = True .Protect password:=Clé End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox linge & ":" & "تم قفل الحسابات بنجاح لغاية الصف ", vbInformation End Sub '======================================================================= Sub Data_UnProtection() Dim result As VbMsgBoxResult Do PassProtect = InputBox("أدخل كلمة المرور لفك الحماية") If PassProtect = "" Then Exit Sub If PassProtect = Clé Then Application.ScreenUpdating = False Application.Calculation = xlCalculationManual WS.Unprotect password:=Clé WS.Cells.Locked = False WS.Cells.FormulaHidden = False Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox "تم فتح جميع الحسابات بنجاح", vbInformation Exit Sub Else result = MsgBox( _ "كلمة المرور غير صحيحة" & vbNewLine & "هل ترغب في المحاولة مرة أخرى؟", _ vbCritical + vbYesNo, "خطأ في كلمة المرور") If result = vbNo Then MsgBox "تم إلغاء العملية", vbInformation Exit Sub End If End If Loop End Sub غلق المدى المحدد .xlsb

Sub Print_certificates() Dim wb As Workbook, wsData As Worksheet, wsDest As Worksheet Dim fRow, fName As String, MyRng As Range, FndRng As Range Dim Cpt As Range, Linge As String, myValue As String, Question As Integer Set wb = ThisWorkbook: Set wsData = wb.Sheets("Mark All"): Set wsDest = wb.Sheets("Moncer") Set MyRng = wsDest.[A3:I46] myValue = "توقيع ولي الأمر:" Question = MsgBox("طباعة شهادات جميع الطلاب ؟", vbYesNo + vbInformation + vbDefaultButton2, "...تأكيد") If Question = vbYes Then If Len(wsDest.[J1].Value) = 0 Then: MsgBox "المرجوا إدخال إسم الملف", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "إنتباه": Exit Sub Application.ScreenUpdating = False Application.DisplayAlerts = False With model .Visible = xlSheetVisible: .Cells.Clear: .ResetAllPageBreaks End With On Error Resume Next With ActiveWorkbook fFolder = .path & Application.PathSeparator & "شهادات الطلاب" & Application.PathSeparator If Len(Dir(fFolder, vbDirectory)) = 0 Then End If MkDir fFolder On Error GoTo 0 For cList = 9 To wsData.Cells(Rows.Count, "B").End(xlUp).Row cName = wsData.Cells(cList, "B"): wsDest.[B8] = cName wsDest.[T1] = cName: fName = wsDest.[J1] MyRng.Copy With model.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats: .PasteSpecial xlPasteColumnWidths Application.CutCopyMode = False End With Next cList End With With model fRow = .Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set FndRng = .Range("A17:A" & fRow) Set Cpt = FndRng.Find(What:=myValue, LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext) If Not Cpt Is Nothing Then: Linge = Cpt.Address Do If Not Cpt Is Nothing Then: Cpt.RowHeight = 21: Cpt.Offset(2).PageBreak = xlPageBreakManual: Cpt.Offset(-1).RowHeight = 36 Set Cpt = FndRng.FindNext(Cpt) If Cpt Is Nothing Then: Exit Do If Cpt.Address = Linge Then: Exit Do Loop model.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fFolder & fName & ".pdf" 'قم بتفعيل هداالسطر في حالة الرغبة بطباعة الشواهد ' .PrintOut .Visible = xlSheetVeryHidden End With Application.ScreenUpdating = True Application.DisplayAlerts = True MsgBox fFolder & "" & fName, vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, " :تم حفظ شهادات الطلاب بنجاج في" End If End Sub Test13.xlsm

الأخت الكريمة جربي الملف التالي يوجد كود في ThisWorkbook من أعمال الأخ الحبيب جعفر تريباك (وهو من عمالقة الإكسيل) جزاه الله عنا خيراً ReverseArrowKeys.rar