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

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

مشاركة مع معلمنا العزيز جعفر جزاه الله كل خير واحسن الله اليه كما يحسن لطلاب العلم غير الكود الى Private Sub MODELS_BeforeUpdate(Cancel As Integer) If DCount("MODELS", "MARKA", "[MODELS]= " & Trim(Me.MODELS.Column(0))) > 0 Then MsgBox "åÐå ÇáãÇÑßÉ ãÓÌá ãÓÈÞÇð", vbCritical + vbDefaultButton1 + 1572864 Cancel = True Me.Undo End If End Sub بالتوفيق

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

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

من الامور الجميلة في اكسس والتي لايعلمها بعض المبتدئين يمكن التصريح باسم الكائن ويمكن وضع قيمته بدون التصريح سبق الاشارة لها مع استاذنا الفاضل @jjafferr يمكن التصريح بالبارامترات ويمكن تجاوزها باستخدام ( , ) ايضا سبق الاشارة لها مع استاذنا جعفر يمكن كتابة الامر بشكل تام او وضع قيمته لاختصار الكود مثال 👇 DoCmd.RunCommand acCmdDatabaseSplitter = DoCmd.RunCommand 520 ----------------- DoCmd.RunCommand acCmdDeleteRecord = DoCmd.RunCommand 223 ------------------ DoCmd.RunCommand acCmdExportExcel = DoCmd.RunCommand 556 وهكذا لكل امر RunCommand قيمة رقمية محددة الامر ان كتابة الامر بشكل كامل اكثر وضوحا ولكن هذه المشاركة من باب اثراء الموضوع

الكود المطلوب Private Sub TextBox27_Change() Dim bol As Boolean If TextBox27.Value <> "" Then ListBox1.Visible = True Else ListBox1.Visible = False End If Dim x As Worksheet Dim c As Range ListBox1.Clear k = 0 For i = 1 To 26 Controls("TextBox" & i).Text = "" Next i If TextBox27 = "" Then Exit Sub bol = Me.OptionButton1 = True If bol Then For Each x In ThisWorkbook.Worksheets SS = x.Cells(Rows.Count, 2).End(xlUp).Row For Each c In x.Range("B2:B" & SS) If Trim(c) Like TextBox27 & "*" Then ListBox1.AddItem ListBox1.List(k, 0) = x.Cells(c.Row, 2) ListBox1.List(k, 1) = c.Worksheet.Name ListBox1.List(k, 2) = c.Row ListBox1.List(k, 3) = x.Name k = k + 1 End If Next c Next x Else For Each x In ThisWorkbook.Worksheets SS = x.Cells(Rows.Count, 2).End(xlUp).Row For Each c In x.Range("B2:B" & SS) If Trim(c) Like "*" & TextBox27 & "*" Then ListBox1.AddItem ListBox1.List(k, 0) = x.Cells(c.Row, 2) ListBox1.List(k, 1) = c.Worksheet.Name ListBox1.List(k, 2) = c.Row ListBox1.List(k, 3) = x.Name k = k + 1 End If Next c Next x End If End Sub الملف مرفق Allaq_User.xlsm

ربما تقصد هذا البحث في بداية الاسم.xlsm

وعليكم السلام-بالطبع هذا أمر طبيعى وبديهى ان لا يعمل الملف على اكسل اونلاين او قوقل شييت وذلك لإحتواء الملف على أكواد VBA ... وشكراً

في الواقع انا طول عمري اعملها يدويا (من شب على شيء، شاب عليه 🙂 ) : اعمل نسخة من البرنامج ، واعطيه اسم البرنامج منتهيا بـ BE ، مثل: Abc_BE.accdb ، ثم احذف جميع كائناته ما عدا الجداول ، واحفظه في الشبكة في مسار تراه جميع الكمبيوترات ، والنسخة الاصل اعطيه اسم البرنامج منتهيا بـ FE ، مثل: Abc_FE.accdb ، ثم احذف جميع جداوله ، ثم من خلال قائمة البيانات الخارجية، اختار الـ BE واختار ربط ، واختار الجداول التي اريدها من BE ، ثم اضع على كمبيوتر كل مستخدم نسخة من هذا الملف 🙂 جعفر طبعا اخوي ابوخليل ، انت تدري ، مو انت المقصود من هذا الشرح 🙂

في اصدار 2019 في تبويب ادوات قاعدة البيانات اعتقد 2010 نفس الامر

تفضل التعديل IT_V2.zip

نتاج التعلم والاستفادة من اساتذة المنتدى الافاضل ( جامعة أوفيسنا ) والذين يستحقون مقاعد التدريس بأكبر الجامعات يسعدني إصدار تحديث لبرنامج مكافأة امتحانات النقل طبقا لآخر تعليمات صدرت من الوزارة للمديريات ويتميز هذا الإصدار إمكانية ادخال البيانات يدويا باللصق والقوائم المنسدلة أو عن طريق شاشة ادخال البرنامج بإمكانية التعديل في المستقطعات ونسب خصمها وذلك في صفحة نسب المستقطع أو ايقاف خصمها بوضع رقم (0) في خانة النسبة وكذلك يقوم البرنامج بحساب عدد الايام المستحقة للمحالين للمعاشات أو الوفاة بادخال تاريخ انتهاء الخدمة بعد تحديد ذلك من خلال قائمة منسدلة تحوى (قانون 155 ـ قانون 81 ـ معاشات ) حساب المكافاة لحظة ادخال بيانات الموظف ويمكن الاستعلام عن اى اسم من خلال صفحة الاستعلام مخرجات البرنامج كشوف مكافأة الموظفين ـ كشف اجمالى ـ مرايا التجمي ـ مسيرات المستقطع بالنسبة لخصم مستشفى المعلمين المطبق بمحافظة المنيا فقط يمكن ايقاف خصمه في باقى المحافظات عن طريق اختيار (لا تخصم ) من القائمة المنسدلة سواء كان الادخال يدويا أو بشاشة الادخال وكذلك يمكن عن طريق وضع (0) في صفحة نسب المستقطع أمام خصم المستشفى أسم المستخدم محمد فتحى كلمة المرور 1970 وكلمة محرر الاكواد 6101970 أرجو مراجعة البرنامج من اساتذتى الافاضل والعاملين بالتربية والتعليم بمصر 1578014707_2021.xlsb

رابط التحميل اسفل الفيديو لطفا ضع متابعة وفعل الجرس ليصلكم جديدنا

السلام عليكم و رحمة الله تعالى و بركاته إخوتي الكرام حياكم الله و تقبل الله منا و منكم الصيامكم و القيام أضع بين أيديكم طريقة إنشاء نسخة تجريبية و حمايتها و قابلية تفعيلها و كل هذا بتوظيف الرجستري. خصائص البرنامج: 1- يكتشف إرجاع التاريخ 2- حتى لونزلت نسخة ثانية بعد إنتهاء التفعيل أو إنتهاء النسخة التجريبية فلن تعمل لأن الحماية مخزنة بالرجستري 3- رقم التفعيل يتغير من يوم إلى آخر حسب التاريخ 4- تستطيع تفعيل البرنامج بعد إنتهاء التفعيل بنفس النسخة 5- يحذف البرنامج الجدول الذي به رقم النسخة و كود الحماية مباشرة بعد أول تشغيل 6- يعطيك في أول تشغيل فترة تجريبية تحددها انت كما تشاء 7- رقم التفعيل مخبأة في مكان بالرجستري لا يمكن الحصول عليه هذا هو المرفق و أتمنى من الأعضاء أن يقوموا بتجربة المرفق و إعطائنا النتائج و من بعدها نقوم بشرح أكواد البرنامج: فترة تجريبية1.rar

حاضر بكره احمل الملف جزاك الله خيرا

طبعا يا والدي الحبيب وأستاذي الجليل ومعلمي القدير الأستاذ @jjafferr ، انت تدري ، مو انت المقصود من هذا التوضيح

السلام عليكم الاخ سليم حاصبيا اشكرك على المجهود الرائع

استعمل هذا الكود البسيط Private Sub UserForm_Initialize() Me.OptionButton1 = False Me.OptionButton2 = False End Sub

تحيه الك اخي الكريم ماشاء الله عليك تسلم

فقط تغيير المعطيات Option Explicit '++++++++++++++++++++++++++++++ Dim Ra As Range, Rb As Range Dim a%, b%, i%, Bol As Boolean Dim m%, t% Dim Ky Dim S As Worksheet Dim Dic_Unique As Object Dim Dic As Object '++++++++++++++++++++++++++++++++++++++ Sub Item_Unique() Set S = Sheets("Salim") Set Dic = CreateObject("Scripting.Dictionary") Set Dic_Unique = CreateObject("Scripting.Dictionary") a = S.Cells(Rows.Count, 1).End(3).Row b = S.Cells(Rows.Count, 2).End(3).Row Set Ra = S.Range("A2:A" & a) Set Rb = Range("B2:B" & b) For i = 2 To b Dic_Unique(S.Cells(i, 2).Value) = "" Next End Sub '""""""""""""""""""""""""""""""""""""""""""" Sub ExtractB() Item_Unique S.Range("K2").CurrentRegion.Offset(1).ClearContents If Dic_Unique.Count Then For Each Ky In Dic_Unique.keys Bol = IsError(Application.Match(Ky, Ra, 0)) If Bol Then Dic(Ky) = 1 Else Dic(Ky) = Application.CountIf(Rb, Ky) - 1 End If Next Ky End If If Dic.Count Then m = 2 For Each Ky In Dic.keys If Dic(Ky) <> 0 Then S.Range("K" & m).Resize(Dic(Ky)) = Ky m = m + Dic(Ky) End If Next t = S.Range("k2").CurrentRegion.Rows.Count If t > 1 Then S.Range("L2") = t - 1 S.Range("J2").Resize(t - 1).Value = _ Evaluate("Row(1:" & t - 1 & ")") End If End If Set S = Nothing Set Ra = Nothing: Set Rb = Nothing Set Dic_Unique = Nothing Set Dic = Nothing End Sub الملف مرفق Alla_20_4.xlsm

<رب هذا الملف Sub each_row_to_Its_sheet() Dim lr, i, x Dim sh As Worksheet Sheets("jan").Range("a2").CurrentRegion.Offset(1).ClearContents Sheets("Feb").Range("a2").CurrentRegion.Offset(1).ClearContents Sheets("Mar").Range("a2").CurrentRegion.Offset(1).ClearContents With Sheets("Legal") lr = .Cells(Rows.Count, 1).End(3).Row For i = 3 To lr If Not IsDate(.Cells(i, 2)) Then GoTo next_i Select Case Month(.Cells(i, 2)) Case 1: Set sh = Sheets("jan") Case 2: Set sh = Sheets("Feb") Case 3: Set sh = Sheets("Mar") Case Else: GoTo next_i End Select x = sh.Cells(Rows.Count, 1).End(3).Row + 1 sh.Cells(x, 1).Resize(, 5).Value = _ .Cells(i, 1).Resize(, 5).Value next_i: Next i End With End Sub الملف مرفق Naser.xlsm

جرب المرفق لعله ماتريد .... DATA144 - kanory.mdb

الشكر لله استاذنا الغالي انا افضل التقسيم عن طريق المعالج ويمكن استدعاء المعالج عن طريق الامر DoCmd.RunCommand acCmdDatabaseSplitter

كود مختصر للتعديل من برمجتي () Private Sub CommandButton1_Click For j = 1 To 55 Sheets(ListBox1.List(i, 1)).Cells(r, j) = Controls("TextBox" & j).Text Next j End Sub

تفضل تجربة.xlsm

شكرا لك استاذي الكريم

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

تفضل هذا التعديل DATA200025.mdb.zip

مشاركة مع الاساتذة الكرام ربما هذا الموضوع يفيدك بدلا تصدير السجل الى pdf ثم ارساله عن طريق الايميل يمكنك عمل تقرير وارسالة للعميل او المورد مباشرة من اكسس بدون الحاجة الى تصديره مع الشكر لاخي @د.كاف يار 👇 مجرد فكره 😎

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

السلام عليكم ماشاء الله معلمنا العزيز @jjafferr جزاك الله خيرا واحسن الله لكم كما تحسنون لطلاب العلم 💐 لعل هذا ما تريد قاعده Data2 هى اللى عليها باسوورد 123456 افتحها واطلع عالجدول ستجده فارغ ادخل عالقاعد Data1 ستجد بها استعلام الحاق قم بتشغيله سيتم نقل بيانات الجدول للقاعده 2 INSERT INTO [C:\Users\Nada\Desktop\pwd\Data2.accdb;pwd=123456].tblData SELECT tblData.SName, tblData.SDate FROM tblData; بالتوفيق pwd.rar

انا عملت نسخ ولصق للكود الذي وضعته ، وكان فيه شيء خطأ ، وفيه خطأ من جانبي كذلك ، وتم تصحيحهم 🙂 فجرب هذا : If DCount("MODELS", "MARKA", "[MODELS]= '" & Trim(Me.MODELS) & "'") > 0 Then MsgBox "هذه الماركة مسجل مسبقاً", vbCritical + vbDefaultButton1 + 1572864 cancel=true Me.Undo End If جعفر

جرب هذا الملف الكود Option Explicit Function Elctric(Sm, n1, n2, n3, n4, n5, n6, n7) Dim x# If Sm <= 0 Then Elctric = 9 Exit Function End If Select Case Sm Case Is < 50: x = (50 - Sm) * n1 Case Is < 100: x = 50 * n1 + (Sm - 50) * n2 Case Is < 200: x = 50 * n1 + 50 * n2 + (Sm - 100) * n3 Case Is < 350: x = 50 * n1 + 50 * n2 + 100 * n3 + _ (Sm - 200) * n4 Case Is < 650: x = 50 * n1 + 50 * n2 + 100 * n3 + _ 200 * n4 + (Sm - 350) * n5 Case Is < 1000: x = 50 * n1 + 50 * n2 + 100 * n3 + _ 200 * n4 + 350 * n5 + (Sm - 650) * n6 Case Else: x = 50 * n1 + 50 * n2 + 100 * n3 + _ 200 * n4 + 350 * n5 + 650 * n6 + (Sm - 1000) * n7 End Select Elctric = x End Function الملف مرفق Electric.xlsm

اليك الملفات مفتوحة شكرا finance-equations-calculates-ratios-irr-npv-unprotected.xls investment_valuation-unprotected.xls

جرب هذا الملف 1-القائمة المنسدلة في الخلية K4 دينامبكية اي انها تدرج كل الاسماء من D7 الى D50 دون تكرار 2- المعادلات محمية لعدم الكتابة عليها عن طريق الحطأ Sasa fathi.xlsx

تفضل هذا التعديل سيتم حذف المكرر سيتم الاحتفاظ بالاسم الذي لا يحمل رقم dub_names.accdb

السلام عليكم لهذه يجب معرفة "كثافة المادة" (لكل مادة كثافة معينة وهي تحسب بـ كلغ/متر مكعب)... مثلا الرمل كثافته بين 1400 و 1700 كلغ/متر مكعب وهكذا... وللتحويل من كلغ إلى متر مكعب يكفي أن تقسم الكمية بالكلغ على كثافة هذه المادة.... والله أعلم..

شرح البرنامج: 1- يتعامل البرنامج مع الرجستري في حماية النسخة ( الريجستري عباره عن قاعدة بيانات في نظام التشغيل Windows .و يحتوي على معلومات أجهزة النظام و البرامج المثبتة والإعدادات، و بيانات حسابات المستخدمين على الكمبيوتر. و أي عملية تقوم بها على الجهاز تخزن بالريجستري . ) 2- عند أول تشغيل للبرنامج يقوم بحفظ تاريخ أول يوم للاستخدام و عدد أيام النسخة التجريبية و خوارزمية التفعيل كلها في الرجستري و يحذف الجدول الذي يحمل جميع البيانات بعد نقلها و حفظها بالرجستري. 3- للإطلاع على الجدول tbl الذي يشتمل المعلومات المهمة يجب عليك فتح البرنامج في وضع التصميم دون تشغيله لأنه عند أي تشغيل للبرنامج سوف يحذف الجدول و في حال لم تجد الجدول حمل نسخة أخرى من البرنامج. 4- اسم الحقل الذي يحدد مدة الفترة التجريبية هو nemberday 5- كل مرة تقوم بتشغيل البرنامج يقوم بحفظ التاريخ و الوقت الحاليين في الرجستري لمنع التلاعب بالتاريخ. 6- لحفظ قيمة بالرجستري نستخدم الكود التالي: SaveSetting AppName , Section, Key ,Setting appName اسم المجلد الرئيسي Section القسم KEY المفتاح Setting القيمة المراد تخزينها 7- لاستعادة القيمة من الرجستري نستخدم الكود التالي: dim X X = GetSetting(AppName , Section, Key) X هو الذي سوف يأخذ القيمة التي سوف نستدعيها 8- لحذف القيمة من الرجستري نستعمل الكود التالي: DeleteSetting AppName , Section, Key 9- و هذه هي الوحدة النمطية التي إستعملتها في البرنامج: Function salah(frm1 As String, frm2 As String, frm3 As String) 'On Error Resume Next Dim firstdate As Date Dim lastdate As Date Dim lasttime As Date Dim expdate As Date Dim nameschool As String Dim numschool As Double Dim khawarezmia As String Dim nember_days As Integer '-------------------------------------------------------------------- firstdate = GetSetting("aa", "bb", "firstdate", Nz(firstdate)) If firstdate = Empty Then SaveSetting "aa", "bb", "firstdate", Date End If firstdate = GetSetting("aa", "bb", "firstdate", Nz(firstdate)) '--------------------------------------------------------------------- lastdate = GetSetting("ss", "tt", "lastdate", Nz(lastdate)) If lastdate = Empty Then SaveSetting "cc", "dd", "lastdate", Date End If lastdate = GetSetting("ss", "tt", "lastdate", Nz(lastdate)) '--------------------------------------------------------------------- lasttime = GetSetting("zz", "hh", "lasttime", Nz(lasttime)) If lasttime = Empty Then SaveSetting "ee", "ff", "lasttime", Now End If lasttime = GetSetting("zz", "hh", "lasttime", Nz(lasttime)) '--------------------------------------------------------------------- nember_days = GetSetting("mm", "nn", "nember_days", Nz(nember_days)) If nember_days = Empty Then nember_days = 1 End If expdate = DateAdd("d", nember_days, firstdate) '--------------------------------------------------------------------- khawarezmia = GetSetting("gg", "pp", "khawarezmia", Nz(khawarezmia)) If khawarezmia = Empty Then numschool = DLookup("numscho", "tbl") SaveSetting "ii", "jj", "numschool", numschool khawarezmia = DLookup("khawr", "tbl") khawarezmia = Replace(khawarezmia, "numschool", numschool) SaveSetting "gg", "pp", "khawarezmia", khawarezmia nameschool = DLookup("namescho", "tbl") SaveSetting "kk", "ll", "nameschool", nameschool nember_days = DLookup("nemberday", "tbl") SaveSetting "mm", "nn", "nember_days", nember_days End If For Each ttable In CurrentData.AllTables If ttable.Name = "tbl" Then DoCmd.DeleteObject acTable, ttable.Name End If Next If Date < lastdate Then MsgBox "تاريخ الجهاز خاطئ" DoCmd.Quit Else If Date = lastdate And lasttime > Now Then MsgBox "ساعة الجهاز خاطئة" DoCmd.Quit End If If Date >= expdate Then MsgBox "إنتهاء مدة التفعيل عليك الإتصال بالمبرمج " SaveSetting "mm", "nn", "nember_days", 1 DoCmd.OpenForm frm3 DoCmd.Close acForm, frm1 Else SaveSetting "zz", "hh", "lasttime", Now SaveSetting "ss", "tt", "lastdate", Date nt = DateDiff("d", Date, expdate) MsgBox "بقي لك " & nt & " يوم على إنتهاء التفعيل" DoCmd.OpenForm frm2 DoCmd.Close acForm, frm1 End If End If End Function 10- و هذا الكود الخاص بإعادة التفعيل: numschool = GetSetting("ii", "jj", "numschool", Nz(numschool)) '--------------------------------------------------------------------- khawarezmia = GetSetting("gg", "pp", "khawarezmia", Nz(khawarezmia)) '--------------------------------------------------------------------- nameschool = GetSetting("kk", "ll", "nameschool", Nz(nameschool)) '--------------------------------------------------------------------- nember_days = GetSetting("mm", "nn", "nember_days", Nz(nember_days)) '--------------------------------------------------------------------- If Me.numero_act = Eval(khawarezmia) Then SaveSetting "mm", "nn", "nember_days", 140 nember_days = GetSetting("mm", "nn", "nember_days", Nz(nember_days)) DeleteSetting "aa", "bb", "firstdate" DeleteSetting "ss", "tt", "lastdate" DeleteSetting "zz", "hh", "lasttime" MsgBox "لقد تم تفعيل برنامجك لمدة" & nember_days & " يوما" salah Me.Name, "drm", "نموذج1" Else MsgBox "رقم التفعيل خاطئ" End If و هذا هو البرنامج مفتوح المصدر بصيغة 2010 و 2003 فترة تجريبية.rar فترة تجريبية2003.rar