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

Calendar.mdb

السلام عليكم ورحمة الله تعالى وبركاته الجزء الاول من صلاحيات دخول المستخدمين الى البرنامج فى هذا الجزء - فى حالة عدم وجود مستخدم مسجل اى عند فتح القاعدة للمرة الأولى يتم انشاء المستخدم الأدمن اليا يا سلام يا سلام -البيانات فى الجداول مشفرة << -----------< تلبية ورغبة لطلب احبائى الكرام -تم إخفاء معظم كائنات قاعدة البيانات التى تخص دخول المستخدمين -نموذج الدخول يمكن من خلاله تسجيل مستخدم جديد فى انتظار الادمن للموافقة عليه وتصنيفه تبعا لمجموهة الصلاحيات << -----------< الادمن كده هيستريح الله الله الله -نموذج الدخول يمكن من خلاله استرجاع كلمة المرور فى حالة النسيان ولكن بعد ادخال بيانات التسجيل الصحيحة ( اسم الدخول - الاسم الرباعى - الايميل- سؤال الامان - اجابة السؤال) -امكانية كشف نجوم كلمة المرور ما تيجو نشوف كده قد يكون هناك اخطاء سهوا منى وقد تكون هناك لدى احد اساتذتى الكرام واحبائى فكرة افضل يسعدنى تلقى مقترحاتكم حول المرفق القاعدة مطروحة للتجربة ـــــــــــــــــــــــــــــــــــــــــــــ SecurityLevel group.accdb SecurityLevel group.mdb

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

انصحك باستعمال هذا الملف الذي وضعته للمدرسة عندي Works_Days.xlsm

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

جرب هذا الكود البيانات كثيرة عندك كان يحب رفع نموذج عن الملف ولبي الملف بكامله (لمعرفة كيفية عمل الكود بشكل مريح) Option Explicit Sub give_uniques() Dim m%: m = 6 Dim Ro_wared%, Ro_Mons% Dim wared As Worksheet: Set wared = Sheets("وارد") Dim Mons As Worksheet: Set Mons = Sheets("منصرف") Ro_wared = wared.Cells(Rows.Count, 1).End(3).Row Ro_Mons = Mons.Cells(Rows.Count, 1).End(3).Row Dim my_sh As Worksheet: Set my_sh = Sheets("salim") my_sh.Range("a6:f5000").ClearContents my_sh.Range("a6:f5000").Font.ColorIndex = xlAutomatic '================================== my_sh.Cells(m, 1).Resize(Ro_wared - 4, 3).Value = _ wared.Cells(5, 1).Resize(Ro_wared - 4, 3).Value my_sh.Cells(m, 4).Resize(Ro_wared - 4, 1).Value = _ wared.Cells(5, 4).Resize(Ro_wared - 4, 1).Value my_sh.Cells(m, 6).Resize(Ro_wared - 4, 1).Value = _ wared.Cells(5, 5).Resize(Ro_wared - 4, 1).Value my_sh.Cells(m, 1).Resize(Ro_wared - 4, 6).Font.ColorIndex = 3 m = Ro_wared + 3 '====================================== my_sh.Cells(m, 1).Resize(Ro_Mons - 4, 3).Value = _ Mons.Cells(5, 1).Resize(Ro_Mons - 4, 3).Value my_sh.Cells(m, 5).Resize(Ro_wared - 4, 1).Value = _ Mons.Cells(5, 4).Resize(Ro_Mons - 4, 1).Value my_sh.Cells(m, 6).Resize(Ro_Mons - 4, 1).Value = _ Mons.Cells(5, 5).Resize(Ro_Mons - 4, 1).Value End Sub الملف مرفق alex_Wared.xlsx

أ/ishak19 إهدا علينا الله يكرمك حضرتك سألت السؤال وفى نفس اللحظة تقريبا رد عليك أستاذنا ابا جودى المنتدى ده مجموعة من الإخوة المحترفون والمبرمجون والهواه تربطهم علاقة حب المعرفة وتعليمها .. وعلى حسب وقتهم وإستطاعتهم يجيبون عن إستفساراتنا .. فكن صبوراً أخى الكريم .. ابا جودى أعطاك فكرة طبقها أنت كما تريد على برنامجك الذى لم تتفضل وترفقه كى يتم التعديل عليه. وعموما أرفق لك مثالا آخر أرجو أن أكون قد فهمت ما تريد. الرقم_الأكبر.zip

بعد اذن اخي مصطفى لا ضرورة لنبحث في العامود صفاً بعد صف عن رقم معين من خلال استعمال الحلقات التكرارية المرهقة للبرنامح (خاصة اذا كان هناك المئات او الالوف من الصفوف) يوجد طريقة اخرى من خلال الدالة المميزة Find التي تنبش المعلومة اينما كانت (وتضع بدها على الجرح مباشرة ---كما يقول المثل) وتملك خاصية ( النبش) مئات المرات دون كلل او ملل الكود Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$G$3" And Target.Count = 1 Then Get_Data End If Application.EnableEvents = True End Sub '+++++++++++++++++++++++++++++++++++++++++++++++++++++++ Sub Get_Data() Dim ws As Worksheet: Set ws = Sheets("البيانات") Dim sh As Worksheet: Set sh = Sheets("البحث") sh.Range("a6").CurrentRegion.Offset(2).ClearContents Dim My_Number: My_Number = sh.Range("g3") Dim But_Rg As Range: Set But_Rg = ws.Range("a2").CurrentRegion.Columns(2) Dim ro%, fixed_ro% Dim m%: m = 7 Dim Search_Rg As Range Set Search_Rg = But_Rg.Find(My_Number) If Not Search_Rg Is Nothing Then ro = Search_Rg.Row: fixed_ro = ro Do sh.Cells(m, 1).Resize(, 10).Value = ws.Cells(ro, 1).Resize(, 10).Value m = m + 1 Set Search_Rg = But_Rg.FindNext(Search_Rg) ro = Search_Rg.Row If ro = fixed_ro Then Exit Do Loop Else MsgBox "No Data" End If End Sub Search_by Find.xlsm

جرب هذا التعديل ComboBox With Drop List_new.xlsm

معلش يا استاذ محمد ، اخذني على قدر عقلي ، طلبت منك عدم ادخال عدة اسئلة في الموضوع ، واذا بك واصلت في السؤال الآخر "على سبيل الدعابة ليس أكثر" ، وفي الموضوع الآخر كذلك عملت نفس المخالفة وسألت سؤال خارج عن الموضوع!! شو اللي تريد ان نعمله نحن المشرفين !! فنحن لسنا شرطة كما قال عنا البعض ، وانما نعطي من وقتنا الخاص لجعل المنتدى يعمل بسلاسة ، واذا تركنا المواضيع بدون رقابه والاعضاء يكتبون ما يشائون ، فذلك المنتدى سيتغير اسمه الى منتدى سوق السمك لقواعد البيانات 🙂 جعفر

ممكن تجربة التعديل على الكود الأخير الذي وضعه أستاذنا الفاضل سليم ComboBox With Drop List_new.xlsm

تفضل الكود خلف زر الأمر يصبح بهذا الشكل: Dim reportName As String Dim fileName As String Dim criteria As String fileName = CurrentProject.Path & "\نتيجة البحث" If Len(Dir(fileName, vbDirectory)) = 0 Then MkDir (fileName) ' إنشاء مجلد بالمسار المحدد End If reportName = "ResultPrint" fileName = fileName & "\" & reportName & ".pdf" 'criteria = "SomeTextField = 'ABC' AND SomeNumberField = 123" DoCmd.OpenReport reportName, acViewPreview, , criteria, acHidden DoCmd.OutputTo acOutputReport, reportName, acFormatPDF, fileName DoCmd.Close acReport, reportName, acSaveNo

وهنـــــــا

بارك الله بك, لو تضمن المرفق التاريخ الهجري لكانت الفائدة اكبر.

اتفضل الباس ورد 1 وصلحت لك نموذج الدخول وعملت لك استعلام لفك التشفير بس نصيخة انا واجهت مشاكل مع خوارزمية التشفير دى ان مهتم بموضوع الصلاحيات هاقولك سر ولا تحكى لحد تابع الموضوع ده New Microsoft Access Database.rar

بعد اذن اخي مصطفى حل اخر بواسطة الكود Option Explicit Sub get_missing_date() Dim my_min#, my_max# Dim cel As Range Dim Col As Object Dim i#, m%: m = 2 Range("G2:G" & Rows.Count).ClearContents Set Col = CreateObject("System.Collections.Arraylist") With Col For Each cel In Range("B2", Range("b1").End(4)) cel.Value = CDate(cel.Value) cel.NumberFormat = "d/m/yyyy" .Add CLng(cel.Value) Next: .Sort End With my_min = Application.Min(Range("B2", Range("b1").End(4))) my_max = Application.Max(Range("B2", Range("b1").End(4))) For i = my_min + 1 To my_max - 1 If (IsError(Application.Match(i, Col.toarray, 0))) _ Then Cells(m, "g") = i: m = m + 1 Next Col.Clear: Set Col = Nothing End Sub الملف مرفق Missing Dates.xlsm

هنا نفس الفكرة ويمكن اختصار مشاركة الاستاذ عصام كالتالي وكتعبير في المربع المراد به النتيجة =IIf([t1]>[t2] And [t1]>[t3],[t1],IIf([t2]>[t1] And [t2]>[t3],[t2],[t3])) بالتوفيق

جزاك الله خيراً أستاذى

الحمد لله رب العالمين الحمد لله الذى تتم بنعمته الصالحات سبحانك اللهم لا علم لنا الا ما علمتنا يارب لك الحمد حمدا كثيرا طيبا طاهر مباركا يارب لك الحمد كما ينبغى لجلال وجهك ولعظيم سلطانك

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

اتفضل مثالك بعد التعديل لاحتساب عدد كل ايام الاسبوع بين تاريخين عدد ايام الاجازة الاسبوعية فى الشهر.accdb

تفضل إجمالى السعر لكل صفحة والإجمالى العام آخر صفحة بالتقرير. تحياتى alziraeia.zip

مشكور جدا أخي سليم وبارك الله فيك وأن شاء الله في ميزان حساناتك

'الجمعة Public Function TotalFriDays(pYear As Integer, pMonth As Integer, pDay As Integer) Dim xindex As Integer Dim endDate As Integer endDate = Day(DateSerial(pYear, pMonth + 1, 0)) For xindex = 1 To endDate If Weekday(DateSerial(pYear, pMonth, xindex)) = pDay Then TotalFriDays = TotalFriDays + 1 End If Next End Function وبنحصل من خلاله على طلب حضرتك بالطريقة دى من النموذج xx= TotalFriDays(Format(txtDate, "yyyy"), Format(txtDate, "m"), Format(txtDate, "dd")) حيث ان txtDate = التاريخ على شكل 1/3/2019 من الاستعلام Fri: TotalFriDays(2019,3,1) لاحظ شكل التاريخ وكيفية كتابته السنة ثم , الشهر ثم , اليوم ----------------------------------------------- انا مش مبرمج انا مجرد هاوى انا بحثت على الانترنت عن مشكلتك الى تخص الجمع علشان اساعد ان امكننى ذلك والحمد لاقيت الكود

أسف تم تحميل الملف بدون الماكرو بالخطأ الملف الجديد alex_Wared.xlsm أسف لم انتبه الى ان الملف المرفوع بصيغة xlsx

تفضل معادلة للبحث عن قيمة بأكثر من شرط.xlsx

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

اتفضل Calendar.mdb

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

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

عمل جميل بالتوفيق عزيزي

بعد اذن استاذنا واخونا الحبيب الاستاذ على واثراء للموضوع هذا حل اخر بالاكواد ان كان هذا هو المطلوب نكمل لك الباقى نسخة من العملاء 2019.xlsm

تفضل العملاء 2019.xlsm

والله يا استاذ انا كنت بافكر فى اضافة التاريخ الهجرى وام القرى فعلا

ما ٱجْمّل ٱن تْسَتيّقظ فيٌ الصَبّاح شّاگرٱ لِرّبگ مُعّترَفا بَفْضّلہ فتَقوڵ: { الـحـمد اللھٌ الذيٌ عَافانيْ في جَسّديْ ۈرد علي رۈحِّي ۈأذْنٌ ليْ بَذگرہٌ } صّباحَ جَميّل معّطر بذگر اللہ .. لا إلہ آلٱ اللہ محمد رسول الله

بارك الله فيكم جميعا ورفع شأنكم وزادكم علما وقبول.

تم معالجة الامر بالتعديل على الكود Option Explicit Private Sub ComboBox1_Change() fill_val_list If Sheets("Drop List").Range("b10") = vbNullString Then Exit Sub End If End Sub '=============================================== Sub fill_val_list() Dim my_rg As Range Dim i% Dim st$: st = Sheets("Drop List").[b8] Dim arr Application.EnableEvents = False Sheets("Drop List").Range("b10").Validation.Delete On Error GoTo No_Items Set my_rg = ActiveWorkbook.Names(st).RefersToRange ReDim arr(1 To my_rg.Cells.Count) With Sheets("Drop List").Range("b10").Validation For i = 1 To my_rg.Cells.Count arr(i) = my_rg.Cells(i) Next .Add 3, , , Join(arr, ",") End With Sheets("Drop List").Range("b10") = arr(1) Application.EnableEvents = True Exit Sub No_Items: Sheets("Drop List").Range("b10") = vbNullString Sheets("Drop List").Range("b8") = vbNullString Sheets("Drop List").Range("b10").Validation.Delete Application.EnableEvents = True End Sub '====================================== Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$B$10" And Target.Value = vbNullString Then MsgBox "Wrong range", 64 End If Application.EnableEvents = True End Sub الملف الجديد ComboBox With Drop List_new.xlsm

السلام عليكم تفضل هذا الكود يقوم بإنشاء المجلد إن لم يجده Dim curPath As String curPath = CurrentProject.Path & "\نتيجة البحث" If Len(Dir(curPath, vbDirectory)) = 0 Then MkDir (curPath) ' إنشاء مجلد بالمسار المحدد End If

دائمًا مبدع أستاذنا الفاضل / سليم ونحن نتعلم منك الكثير بارك الله فيك ولي سؤال ماذا لو تم تعديل الكود بإضافة Range("b10") = "" في بداية الكود ليتم مسح الخلية b10 قبل البدء بالعمل فيكون الكود Option Explicit Private Sub ComboBox1_Change() fill_val_list End Sub '=============================================== Sub fill_val_list() Range("b10") = "" Dim my_rg As Range Dim i% Dim st$: st = Sheets("Drop List").[b8] Dim arr Sheets("Drop List").Range("b10").Validation.Delete On Error GoTo No_Items Set my_rg = ActiveWorkbook.Names(st).RefersToRange ReDim arr(1 To my_rg.Cells.Count) With Sheets("Drop List").Range("b10").Validation For i = 1 To my_rg.Cells.Count arr(i) = my_rg.Cells(i) Next .Add 3, , , Join(arr, ",") End With Exit Sub No_Items: ' MsgBox "Wrong range", 64 End Sub '======================================

ممكن يكون الرابط يفيدك

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

السلام عليكم ورحمة الله وبركاتة اعتذر عن التعديل الشامل الذى صار للقاعدة اولا برجاء عدم الاستخدام الحروف العربية لتسمية الجداول او الحقول مع الاخذ فى الاعتبار عدم استخدام المسافة للفصل بين الكلمات كذلك وذلك لسهولة التعامل مع الأكواد اترككم للاستمتاع بالقاعدة الجديدة اتمنى ان شاؤ الله ان تجدوا ضالتكم تقييم الطالبات 2003( الطى والتوسيع).mdb

إليك الملف غير مضغوط دوائر الشهادات1.xls

السلام عليكم أو ربما كان هذا المطلوب لكن باستعمال أعمدة مساعدة (فصل أوقات البصمات في خلايا منفصلة)... بن علية حاجي المثال.xls

السلام عليكم معادلة أخي الكريم سليم مختصرة في الملف المرفق... يمكن استعمال الدالة SUMPRODUCT بدلا من الدالة SUM (وفي هذه الحالة غير ضروري تأكيدها كمعادلة صفيف)... بن علية حاجي DAYS_CALCULATION_2.xlsx

جرب هذا الملف DAYS_CALCULATION.xlsx

جرب هذا الكود Option Explicit Sub creat_shett() Dim i%, t, m% Dim x%: x = Application.CountA(Sheets("Principal").Range("A:A")) + 1 For i = 3 To x t = Sheets("Principal").Range("a" & i) On Error Resume Next m = Len(Sheets(t).Name) On Error GoTo 0 If m = 0 Then '===========================================================' Sheets("Main").Copy After:=Sheets(Sheets.Count) With ActiveSheet .Name = Sheets("Principal").Range("a" & i) .Range("a1") = .Name End With '===========================================================' End If m = 0 Next Sheets("Principal").Select End Sub الملف مرفق مسحوبات.xlsm

جرب هذا الملف B2 اختر سماء من القائمة المنسدلة(المطاطة) في الخلية salim كشف بودرة.xlsm

انا آسف أخي حسين ، فا لاقتراح الوحيد المتبقى عندي هو ان تعمل تقرير جدولي مرة اخرى ، بحيث تستطيع ان ترى جميع الحقول فيه. جعفر

حياك الله أخوي حسين بس طلب لوسمحت تجرب وتخبرنا النتيجة: 1. مال مشاركتي الاخيرة اللي فيها Application.Echo False ، 2. وكذلك مال اخينا ابوعارف ، لأني اعرف اننا لا يمكن ان نعمل setfocus على حقل مخفي في نموذج ، فما ادري اذا ممكن نستخدم Docmd.SelectObject على تقرير مخفي جعفر