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

لا تحفظ الملف بصيغة ( xlsx ) بل احفظ الملف بأحد هذين الصيغ xlsm or xlsb

وعليكم السلام-فقط عليك استخدام هذه المعادلة =SUMIF($A:$A,$D2,$B:$B) اجمالي كمية بنفس التاريخ1.xlsx

حرب هذا الماكرو Option Explicit Sub get_my_studiants() Application.ScreenUpdating = False Dim A As Worksheet Dim B As Worksheet Set A = Sheets("ALL_STD") Set B = Sheets("B") Dim col%, r, x, LB LB = B.Cells(Rows.Count, "B").End(3).Row If LB < 5 Then LB = 5 B.Range("a5").Resize(LB - 4, 6).Clear Dim my_clas$: my_clas = B.Range("e2") Dim my_mad$: my_mad = B.Range("K2").Value If my_clas = "" Or my_mad = "" Then GoTo Exit_Sub col = A.Rows(1).Find(my_clas, lookat:=1).Column r = A.Columns(1).Find(my_mad, lookat:=1).Row x = Application.CountIf(A.Columns(1), my_mad) B.Range("b5").Resize(x).Value = _ A.Cells(r, 2).Resize(x).Value B.Range("c5").Resize(x, 3).Value = _ A.Cells(r, col).Resize(x, 3).Value With B.Range("A5").Resize(LB - 4, 6) .Columns(1).Formula = "=if(B5="""","""",max($A$4:a4)+1)" .Columns(1).Interior.ColorIndex = 6 .Borders.LineStyle = 1 .Columns(6).Formula = "=RANK(E5,$E$5:$E$29,0)+COUNTIF($E5:E$5,E5)" .Value = .Value .Font.Size = 26 .Font.Bold = True .InsertIndent 1 End With Exit_Sub: Application.ScreenUpdating = True End Sub الملف مرفق My_students.xlsm

أ.عماد محمد عبد العزيز جرب المرفق عسى أن يكون المطلوب مع مراعاة أن 2020 ستتغير كل عام .. أم أنك تريدها ثابته التوريد.accdb معذرة أخى Shivan Rekany لم أنتبه لردك

هذه ملف لشرح الطباعه معاينة الطباعه.xlsm

نعم ممكن ولكن في حالة كثرة السجلات مثل مثالك يحتاج وقت وايضا كفاءة جهاز الكمبيوتر ..... انظر المرفق هذا ما تريد تم تعديل المرفق .... Desktop1.rar

وعليكم السلام اهلا بك في منتداك اتفضل اليك هذا استعلام الجدولي TRANSFORM Min([111].[الحالة]) AS MinOfالحالة SELECT [111].[رقم] FROM 111 GROUP BY [111].[رقم] PIVOT [111].[السنة]; مع المرفق ask access.rar تقبل تحياتنا

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

اتفضل القي نظرتا الى هذا تم استخدام هذا الكود مع اضافة حقل id باستخدام دالة dmax + 1 If IsNull(Me.Purchase__Order__No) = True Then Me.id = Nz(DMax("[id]", "Order"), 0) + 1 Me.Purchase__Order__No = Nz(DMax("id", "Order"), 0) + 1 & "/" & 2020 DoCmd.RunCommand acCmdSaveRecord Me.id.DefaultValue = Nz(DMax("[id]", "Order"), 0) + 1 End If التوريد-.mdb

تفضل وذلك بوضع هذا الكود فى حدث ThisWorkBook Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) 'Define your variables. Dim ws As Worksheet, EvalRange As Range 'Set the range where you want to prevent duplicate entries. Set EvalRange = Range("A1:a10000") 'If the cell where value was entered is not in the defined range, if the value pasted is larger than a single cell, 'or if no value was entered in the cell, then exit the macro. If Intersect(Target, EvalRange) Is Nothing Or Target.Cells.Count > 1 Then Exit Sub If IsEmpty(Target) Then Exit Sub 'If the value entered already exists in the defined range on the current worksheet, throw an 'error message and undo the entry. If WorksheetFunction.CountIf(EvalRange, Target.Value) > 1 Then MsgBox Target.Value & " already exists on this sheet." Application.EnableEvents = False Application.Undo Application.EnableEvents = True End If 'Check the other worksheets in the workbook. For Each ws In Worksheets With ws If .Name <> Target.Parent.Name Then 'If the value entered already exists in the defined range on the current worksheet, throw an 'error message and undo the entry. If WorksheetFunction.CountIf(Sheets(.Name).Range("A1:a10000"), Target.Value) > 0 Then MsgBox Target.Value & " already exists on the sheet named " & .Name & ".", _ 16, "No duplicates allowed in " & EvalRange.Address(0, 0) & "." Application.EnableEvents = False Application.Undo Application.EnableEvents = True Exit For End If End If End With Next ws End Sub عدم تكرار المدخلات - 1.xlsm

السلام عليكم ورحمة الله وبركاته 🙂 عندما يكون برنامج الاكسس يعمل ، وفجأة بدأ بإعطاء رسائل خطأ وبدون اي تعديل في البرنامج ، او عند عمل تعديل على البرنامج يُغلق الاكسس: . طريقة العمل: سيفتح البرنامج ، ويجب عليك غلقه ، الى ان لا يفتح تلقائيا مرة اخرى. ولكن ، يجب دائما اخذ الاحتياط وعمل نسخة من البرنامج قبل عمل هذه الخطوات. اقدم لكم شرح بسيط عن الموضوع: في الكثير من الاوقات ، لما نعمل الكود ، نقوم بتعديل وتغيير وتضبيط الكود عدة مرات ، ولكن الاكسس في بعض الاحيان يبقى محتفظ بالكود القديم في ذاكرته !! لذلك : 1. اثناء البرمجة ، وبشكل يومي اقوم بتشغيل هذا الملف المرفق ، 2. وقبل تسليم البرنامج الى الزبون ، اقوم بتشغيل الملف للمرة الاخيرة ، واجهز البرنامج لتسليمه الى الزبون وهذا هو الكود المعدل عن النسخة السابقة: Private Sub cmd_Decompile_Click() Dim MSAccPath As String Dim RegKey As String Dim WSHShell 'As Object Dim waitOnReturn As Boolean: waitOnReturn = True ' Get MSACCESS.exe directory from the Registry RegKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\" & _ "CurrentVersion\App Paths\MSACCESS.EXE\Path" Set WSHShell = CreateObject("WScript.Shell") ' Get parent directory MSAccPath = WSHShell.RegRead(RegKey) ' Decompile WSHShell.Run Chr(34) & MSAccPath & "MSACCESS.EXE" & Chr(34) & " " & Chr(34) & Me.str_File_Single & Chr(34) & " /decompile", , waitOnReturn ' compact WSHShell.Run Chr(34) & MSAccPath & "MSACCESS.EXE" & Chr(34) & " " & Chr(34) & Me.str_File_Single & Chr(34) & " /compact", , waitOnReturn ' cmd compile WSHShell.Run Chr(34) & MSAccPath & "MSACCESS.EXE" & Chr(34) & " " & Chr(34) & Me.str_File_Single & Chr(34) & " /cmd compile", , waitOnReturn ' compact WSHShell.Run Chr(34) & MSAccPath & "MSACCESS.EXE" & Chr(34) & " " & Chr(34) & Me.str_File_Single & Chr(34) & " /compact", , waitOnReturn ' Clear shell var Set WSHShell = Nothing End Sub جعفر Decompile_2.zip

اسف جدا كثرة الملفات علي .... انظر المرفق الجديد ..... تم تعديل المرفق .....اسف مرة أخرى QR_code_-name.mdb

انت فك التقرير بتاعك وشوف ......

جرب هاذا الكود معاينة طباعة مع امكانية الطباعه.rar

اخي الفاضل احمد يوسف سلمه الله الشكر والفضل والمنه لله سبحانه ولا اريد سوى دعوه في ظهر الغيب قَالَ رَسُولُ اللَّهِ صَلَّى اللَّهُ عَلَيْهِ وَسَلَّمَ : ( مَنْ صُنِعَ إِلَيْهِ مَعْرُوفٌ فَقَالَ لِفَاعِلِهِ : جَزَاكَ اللَّهُ خَيْرًا فَقَدْ أَبْلَغَ فِي الثَّنَاءِ ) تقبل تحياتي وتقديري لشخصك الكريم

أستاذ Gamor أين الضغط على الإعجاب على هذه الإجابة الممتازة وهذا اقل ما يقدم لصاحب الفضل بعد ربنا فى حل مشكلتك ؟! 💙

جرب المرفق HCT Permit To Work System V.02 - Update _Normal + Red Zon - Copy.rar

كان عليك لزاما استخدام خاصية البحث فى المنتدى فبه العديد من الموضوعات التى تحول المعادلات الى اكواد ومنها : تحويل معادلة الى كود

اجعله نموذج منقسم وأضف زر الأمر الذي تريد كما في المرفق . 1.accdb

الازرار حسب ما اعرفه لا يمكن , لكن تقدر تعمل حذف ريكورد مثلا عند ضغط دبل كليلك مثلا على احد الحقول

بعد أذن اخونا سليم حاصبيا اخ ابو العلاء ما هو الحد الأقصي لعدد الأكواد

وعليكم السلام-فقط عليك استخدام هذه المعادلة =IF($E3=$F$2:$AK$2,$D3,"") توجيه المبلغ1.xlsx

الاخ khairi ali علي الله توكلت سأبدأ العمل ولكني لا احيذ المفاجأت في الطلبات بعد بدء العمل علي الموضوع فهل هناك اي طلبات او تعليمات اخري الله المستعان لقد تم عمل اللازم بنجاح ولكنك دخلت المنتدي ولم تكلف نفسك بالرد شكرا لك تفضل اخي شاهد المرفق Test_1.xls

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

بارك الله فيك وبالتوفيق ان شاء الله وفى انتظار الإصدار الجديد

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

وعليكم السلام اخى الفاضل ارفق لك نسخه اعمل بها لعلك تنتفع منها مقابل دعوه من القلب لى ولجميع من تعلمت واتعلم منهم جزاهم الله خيرا على قد حالى فهى تجميع لما تعلمته من هنا وهناك وبه اكود من جميع الاخوه والاخوات جزاهم الله عنى كل خير اضغط على مفتاح الشفت قبل الدخول ليفتح لك قاعده البيانات وتتفحصها وان شاء الله تنتفع منها تقبل تحياتى ومرورى وتمنياتى لك وللجميع بالتوفيق ZUPS-NCustomers_2020.mdb

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

1- من الجهة اليسار حتحدد مكان الفولدر اللي انت حتعمل منه مصغرات و حتضغط على زر Add ________________________ 2- اذا تحب تغير تنسيق الصور حتضغط على الخيار هذا و تختار التنسيق اللي تحبه ________________________ 3- من الخيار هذا حتحدد فولدر جديد للمصغرات ________________________ 4- حتعلم بعلامة صح للخيار هذا عشان يفتح لك زر بجنبه اليمين و حتضغط عليه و حيفتح معاك نافذة زي اللي في الصورة الجاية 5 حتعلم على المربع Resize وحيفتح لك خيارات : اختار الخيار رقم 6 و روح للمربع رقم 7 و اختار الحجم اللي يعجبك ثم أوكي عند رقم 8 و حترجع للشاشة الأولى و اختار من الزاوية اليمين السفلية Convert عشان يبدأ التصغير ________________________ و حنرجع للسؤال الأهم / وين راح تستخدم المصغرات بالضبط ؟؟ أتمنى الشرح يكون مفهوم و بسيط و أي استفسار ثاني انا حاضر

وعليكم السلام-تفضل New Microsoft Excel Worksheet1.xlsx

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

السلام عليكم هذا ملف فيه كود تنبيه TIMER يظهر لك وميض للتنبيه قبل 5 ايام وكذلك بعد 5 ايام من انتهاء المدة (ويمكن تغيير المدة حسب العمل)) ويمكن اظافة رسالة تنبيه له تحياتي test.rar

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

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

أحسنت وبارك الله فيك وزادك الله من فضله

وعليكم السلام-اهلا بك فى المنتدى كيف تقول هذا فكل هذه برامج من المنتدى بدون كلمة مرور شوف بنفسك برنامج_مخازن_جديد.xlsm برنامج مخازن شامل .xlsm

الاستاذ القدير خالد سيسكو قدم الاجابة الصحيحة ومن باب اثراء الموضوع لقيمة خطأ في الحقل احيانا يكون لدينا حقل في النموذج الرئيسي يستمد قيمتة من خلال قيمة حقل غير منظم في النموذج الفرعي مثلا اجمالي المبيعات لفترة زمنية اكيد توجد اكثر من طريقة لاخذ القيمة ولكن الطريقة الاسهل [q_tax].[Form]![txt23] ولكن عندما لاتكون لدينا سجلات للفترة تكون قيمة الحقل في الرئيسي تساوى خطأ وللتغلب على ذلك يمكن استخدام دالة IsError لتكون بالشكل التالي =IIf(IsError([q_tax].[Form]![txt23]);0;[q_tax].[Form]![txt23]) والنتيجة تكون صفر

في هذاه الحالة يلزم هذا الكود Option Explicit Private Sub Worksheet_Activate() Application.EnableEvents = False fil_data_val Application.EnableEvents = True End Sub Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$A$2" And Target.Count = 1 Then Call find_Please(Me, Range("a2")) End If Application.EnableEvents = True End Sub '++++++++++++++++++++++++++++ Sub find_Please(SH As Worksheet, Rg) Dim Principal As Worksheet Dim Ro% 'first found row Dim Ro_Atc% 'All Others found rows Dim m%: m = 4 Dim My_rg As Range 'find range with Criteria in cell(A2) SH.Range("A4:E" & Rows.Count).Clear Set Principal = Sheets("serch") For Each SH In Sheets If SH.Name <> Principal.Name Then Set My_rg = SH.Range("C:C").Find(Rg, lookat:=1) If My_rg Is Nothing Then GoTo Next_sh Ro = My_rg.Row: Ro_Atc = Ro Do Principal.Cells(m, 1).Resize(, 5).Value = _ SH.Cells(Ro_Atc, 1).Resize(, 5).Value m = m + 1 Set My_rg = SH.Range("C:C").FindNext(My_rg) Ro_Atc = My_rg.Row If Ro_Atc = Ro Then Exit Do Loop End If Next_sh: Next If m = 4 Then _ MsgBox "Current Account Not Found": Exit Sub With Principal.Range("A4:E" & m - 1) .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 24 .HorizontalAlignment = 2 .VerticalAlignment = 2 .Interior.ColorIndex = 24 .InsertIndent 1 End With End Sub '++++++++++++++++++++++++++++ Sub fil_data_val() Dim S As Worksheet, T As Worksheet Dim dic As Object Dim i% Set S = Sheets("serch") Set dic = CreateObject("Scripting.Dictionary") For Each T In Sheets If T.Name = S.Name Then GoTo Next_T i = 2 Do Until T.Range("c" & i) = vbNullString dic(T.Range("C" & i).Value) = vbNullString i = i + 1 Loop Next_T: Next T With S.Range("A2").Validation .Delete .Add 3, Formula1:=Application.Transpose(Join(dic.keys, ",")) End With dic.RemoveAll: Set dic = Nothing Set T = Nothing: Set S = Nothing End Sub الملف مرفق Search_Account _repetitions.xlsm

تسلم استاذ سليم الكود عملي - ومفيد جدا اطلب رجاء اضافة الى الكود جلب المكرر في حالة وجوده في الشيت اكون شاكر

تم معالجة الامر بالتعديل على الكود كما يلي Option Explicit Private Sub Worksheet_Activate() Application.EnableEvents = False fil_data_val Application.EnableEvents = True End Sub Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$A$2" And Target.Count = 1 Then Call find_Please(Me, Range("a2")) End If Application.EnableEvents = True End Sub '++++++++++++++++++++++++++++ Sub find_Please(SH As Worksheet, Rg) Dim Principal As Worksheet Dim Ro%, m%: m = 4 Dim My_rg As Range SH.Range("A4:E" & Rows.Count).Clear Set Principal = Sheets("serch") For Each SH In Sheets If SH.Name <> Principal.Name Then Set My_rg = SH.Range("c:c").Find(Rg, lookat:=1) If My_rg Is Nothing Then GoTo Next_sh Ro = My_rg.Row If Ro > 0 Then Principal.Cells(m, 1).Resize(, 5).Value = _ SH.Cells(Ro, 1).Resize(, 5).Value m = m + 1 End If End If Next_sh: Next If m = 4 Then _ MsgBox "Current Account Not Found": Exit Sub With Principal.Range("A4:E" & m - 1) .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 24 .HorizontalAlignment = 2 .VerticalAlignment = 2 .Interior.ColorIndex = 24 .InsertIndent 1 End With End Sub '++++++++++++++++++++++++++++ Sub fil_data_val() Dim S As Worksheet, T As Worksheet Dim dic As Object Dim i% Set S = Sheets("serch") Set dic = CreateObject("Scripting.Dictionary") For Each T In Sheets If T.Name = S.Name Then GoTo Next_T i = 2 Do Until T.Range("c" & i) = vbNullString dic(T.Range("C" & i).Value) = vbNullString i = i + 1 Loop Next_T: Next T With S.Range("A2").Validation .Delete .Add 3, Formula1:=Application.Transpose(Join(dic.keys, ",")) End With dic.RemoveAll: Set dic = Nothing Set T = Nothing: Set S = Nothing End Sub الملف من جديد Search_Account _new.xlsm

انا لم الاحظ اي شيء عشوائي

طباعة الشهادات بطريقة اختيار الفصل للاستاذ الكبير الصقر جزاه الله كل خير طباعة شهادات فصل.rar

اكواد مفيده خاصه بعمل واجهه ملف مثل الكنترول المدرسي إسم المستخدم :admin كلمة المرور:222 وهذه البيانات يمكنك تغيرها من صفحة واجهة الدخول اللهم ارزق هؤلاء الاساتذه العظام الجموعي والصفر وياسر خليل بعفوك ورحمتك واجزيهم خيرا واجهه كنترول مفيد للاستاذ الحسامي2.zip

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

كود التنقل لأعمده معينه للاستاذ الكبير ين عليه جزاه الله خيرا Sub hben() Application.ScreenUpdating = False Range("IT11").Select Range("5:5").EntireRow.Hidden = True If ActiveCell = 1 Then Columns("A:DJ").EntireColumn.Hidden = False If ActiveCell = 2 Then Columns("C").EntireColumn.Hidden = False If ActiveCell = 3 Then Columns("C").EntireColumn.Hidden = True If ActiveCell = 4 Then Columns("R:DJ").EntireColumn.Hidden = False If ActiveCell = 5 Then Columns("R:DJ").EntireColumn.Hidden = True If ActiveCell = 6 Then Columns("C:DJ").EntireColumn.Hidden = False: _ Range("B:D,F:P,AA:DJ").EntireColumn.Hidden = True If ActiveCell = 7 Then Columns("C:DJ").EntireColumn.Hidden = False: _ Range("B:D,F:P,R:Z,AJ:DJ").EntireColumn.Hidden = True If ActiveCell = 8 Then Columns("C:DJ").EntireColumn.Hidden = False: _ Range("B:D,F:P,R:AI,AS:DJ").EntireColumn.Hidden = True If ActiveCell = 9 Then Columns("C:DJ").EntireColumn.Hidden = False: _ Range("B:D,F:P,R:AR,BB:DJ").EntireColumn.Hidden = True If ActiveCell = 10 Then Columns("C:DJ").EntireColumn.Hidden = False: _ Range("B:D,F:P,R:BA,BM:DJ").EntireColumn.Hidden = True If ActiveCell = 11 Then Columns("C:DJ").EntireColumn.Hidden = False: _ Range("B:D,F:P,R:BN,BR:DJ").EntireColumn.Hidden = True If ActiveCell = 12 Then Columns("C:DJ").EntireColumn.Hidden = False: _ Range("B:D,F:P,R:BQ,BU:DJ").EntireColumn.Hidden = True If ActiveCell = 13 Then Columns("C:DJ").EntireColumn.Hidden = False: _ Range("B:D,F:P,R:BU,CE:DJ").EntireColumn.Hidden = True If ActiveCell = 14 Then Columns("C:DJ").EntireColumn.Hidden = False: _ Range("B:D,F:P,R:CD,CN:DJ").EntireColumn.Hidden = True If ActiveCell = 15 Then Columns("C:DJ").EntireColumn.Hidden = False: _ Range("B:D,F:P,R:CM,CW:DJ").EntireColumn.Hidden = True If ActiveCell = 16 Then Columns("C:DJ").EntireColumn.Hidden = False: _ Range("B:D,F:P,R:CV,DG:DJ").EntireColumn.Hidden = True Range("A5").Select Application.ScreenUpdating = True End Sub كود التنقل لأعمده معينه.rar

اخي المحترم العالم العلامة عبد الله باقشير جعل الله هذا العمل في ميزان حسناتك وحسناتنا آمين يارب العالمين

أخي / محمدي عبد السميع بارك الله فيك وجزاك الله خير أكواد جميلة وروعة جزاكم الله خيرا

أخي العزيز هذه أول مشاركاتي في الموقع وهو كود استخدمه في برامجي وأنا مستعد للتعاون مع أي أخ لدية مشكلة Private Sub Form_Current() Dim myfile, chpass myfile = Dir("c:\windows\filename.txt") If myfile <> "" Then Else chpass = MsgBox("نسخة غير مرخصة") DoCmd.Quit End If End Sub

هذا المثال يوضح كيفية منع ادخال قيمة أكبر من صفر فى حقل رقمي اسمه App1 و ذلك فى حال كون هناك قيمة أكبر من صفر سبق تسجيلها فى هذا الحقل و ذلك لنفس التاريخ و الذي يتم تسجيله فى حقل mdate فيتم اختبار القيم فى الجدول التي لها نفس التاريخ و اذا كان هناك سجل لنفس التاريخ لديه قيمة أكبر من صفر لنفس الحقل فنمنع التسجيل - , و هذا يتم باستخدام الدالة Dcount كما نمنع تسجيل أي قيمة أكبر من صفر للحقل فى حال عدم تسجيل التاريخ فى حقل التاريخ اولا ا ChechOtherFields.rar

مرفق مثال فتح النموذج و التقرير بكل سجلاته أو مع عمل تصفية علي السجل المختار من النموذج فقط اختار موظف ثم اضغط علي زر فتح النموذج أو التقرير للموظف المحدد أيضا يوجد مثال علي عمل تجميع للتقرير للدورات التي حصل عليها كل موظف علي حدة خاصية Sorting and grouping من وضع تصميم التقرير و استخدام الدالة count لعد دورات كل موظف و ايضا عمل مسلسل للتقرير عن طريق وضع =1 فى مصدر البيانات لمربع نص و اختيار خاصية Runnig Sum - Overall مرفق المثال OpenSpecific.rar