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

السلام عليكم ورحمة الله وبركاته الموضوع ترفيهي نوعا ما : حنين الى الماضي بصراحة كنت احب هذه اللعبة جدا جدا جدا وانا صغير راودتني فكرة تصميم اللعبة من خلال الاكسس وهذه تجربتي اتمني ان تنال رضاكم PuzzleGame.zip

وعليكم السلام 🙂 اما انا فلم افلح مع الذكاء الصناعي !! ما ادري ، يمكن اسألتي صعبة 😁 الخطأ يقول: اول قيمة في الدالة ، نوع المتغير studentID في الدالة IsTeacherAssigned هو Integer . بينما بدلا عن تدخل قيمة Integer ، انت ادخلت قيمة من نوع: . الخطأ في السطر: . سهله 🙂 جعفر

هدا ملف مغاير اخي الكريم على العموم تفضل هده الاكواد الخاصة بك بعد تعديلها Private Sub CommandButton2_Click() 'بحث Dim WS As Worksheet, F As Worksheet, J As Long Dim rng As Range, LastRow As Long, Clé As String Set WS = Sheets("Sheet1"): Set F = Sheets("Sheet2"): Clé = WS.[E3] Application.ScreenUpdating = False If Clé = Empty Then: MsgBox "برجاء إدخال اسم للبحث عن بياناته", vbCritical, "فلاح": Exit Sub LastRow = F.Cells(F.Rows.Count, "B").End(xlUp).Row Set rng = F.Range("B3:B" & LastRow).Find(Clé, LookIn:=xlValues, _ lookat:=xlWhole, SearchDirection:=xlPrevious) If rng Is Nothing Then MsgBox " الاسم غير موجود", vbExclamation, Clé Else J = rng.Row WS.[D5].Value = F.Cells(J, 2).Value: WS.[D7].Value = F.Cells(J, 3).Value WS.[D9].Value = F.Cells(J, 4).Value: WS.[D11].Value = F.Cells(J, 5).Value WS.[D13].Value = F.Cells(J, 6).Value: WS.[D15].Value = F.Cells(J, 7).Value WS.[D17].Value = F.Cells(J, 8).Value: WS.[D19].Value = F.Cells(J, 9).Value WS.[D21].Value = F.Cells(J, 10).Value: WS.[D23].Value = F.Cells(J, 11).Value WS.[G7].Value = F.Cells(J, 12).Value: WS.[G9].Value = F.Cells(J, 13).Value WS.[G11].Value = F.Cells(J, 14).Value: WS.[G13].Value = F.Cells(J, 15).Value WS.[G15].Value = F.Cells(J, 16).Value: WS.[G17].Value = F.Cells(J, 17).Value WS.[G19].Value = F.Cells(J, 18).Value: WS.[G21].Value = F.Cells(J, 19).Value WS.[G23].Value = F.Cells(J, 20).Value Application.ScreenUpdating = True End If End Sub اما بالنسبة لكود التعديل يمكنك اتمامه بنفس الطريقة Private Sub CommandButton5_Click() 'تعديل Dim WS As Worksheet, WS2 As Worksheet Dim LastRow As Long, i As Long Set WS = Sheets("Sheet2"): Set WS2 = Sheets("Sheet1") LastRow = WS.Cells(WS.Rows.Count, 2).End(xlUp).Row For i = 3 To LastRow If WS.Range("B" & i).Value = WS2.[E3] Then WS.Range("B" & i) = WS2.Range("D5") WS.Range("C" & i) = WS2.Range("D7") WS.Range("D" & i) = WS2.Range("D9") WS.Range("E" & i) = WS2.Range("D11") WS.Range("F" & i) = WS2.Range("D13") 'اتمم الكود '''''''''''''''''''' '''''''''''''''''''' MsgBox "تم تعديل البيانات بنجاح" End If Next i Application.ScreenUpdating = True End Sub 123.xlsm

جرب هل هدا ما تقصده Sub TEST() Dim WS As Worksheet: Dim F As Worksheet Set WS = Sheets("ورقة2"): Set F = Sheets("ورقة3") Application.ScreenUpdating = False F.Range("B" & F.Rows.Count).End(xlUp).Offset(1).Resize(, _ 26).Value = Application.Index(WS.Range _ ("D5,C7,C9,C11,D13,E15,D17,D19,D21,J7,J9,J11,J13,J15,J17,I19,K19,J21,O7,O9,O11,N13,N15,N17,O19,O21"), _ 1, 1, Array(2, 3, 1, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, _ 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26)) With F.Range("A4:A" & F.Cells(Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-3") End With Application.ScreenUpdating = True MsgBox "تم ترحيل البيانات بنجاح" End Sub New ورقة عمل Microsoft Excel 2.xlsm

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

لديك اخطاء في تحديد اسماء الخلايا كما في الصورة المرفقة تم تعديل الكود ليسهل التعامل معه Private Sub CommandButton2_Click() 'بحث Dim WS As Worksheet, F As Worksheet Dim Irow As Long, Clé As String, i As Long Set WS = Sheets("Sheet2"): Set F = Sheets("Sheet1"): Clé = F.[E3] Application.ScreenUpdating = False If Clé = Empty Then: MsgBox "برجاء إدخال اسم للبحث عن بياناته", vbCritical, "فلاح": Exit Sub Irow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row Set rng = WS.Range("B3:B" & Irow).Find(Clé, LookIn:=xlValues, _ lookat:=xlWhole, SearchDirection:=xlPrevious) If rng Is Nothing Then: MsgBox " الاسم غير موجود", vbExclamation, Clé: Exit Sub For i = 3 To Irow If WS.Cells(i, 2) = Clé Then ' Colmun (D) F.[D5] = WS.Cells(i, "B") F.[D7] = WS.Cells(i, "C"): F.[D9] = WS.Cells(i, "D"): F.[D11] = WS.Cells(i, "E") F.[D13] = WS.Cells(i, "F"): F.[D15] = WS.Cells(i, "G"): F.[D17] = WS.Cells(i, "H") F.[D19] = WS.Cells(i, "I"): F.[D21] = WS.Cells(i, "J"): F.[D23] = WS.Cells(i, "K") ' Colmun (G) F.[G7] = WS.Cells(i, "L"): F.[G9] = WS.Cells(i, "M"): F.[G11] = WS.Cells(i, "N") F.[G13] = WS.Cells(i, "O"): F.[G15] = WS.Cells(i, "P"): F.[G17] = WS.Cells(i, "Q") F.[G19] = WS.Cells(i, "R"): F.[G21] = WS.Cells(i, "S"): F.[G23] = WS.Cells(i, "T") ' Colmun (J) F.[J7] = WS.Cells(i, "U") F.[J9] = WS.Cells(i, "V"): F.[J11] = WS.Cells(i, "W") F.[J13] = WS.Cells(i, "X"): F.[J15] = WS.Cells(i, "Y") End If Next Application.ScreenUpdating = True End Sub مع تعديل كود الترحيل بالشكل التالي Private Sub CommandButton1_Click() ' اظافة Dim WS As Worksheet: Dim F As Worksheet Set WS = Sheets("Sheet1"): Set F = Sheets("Sheet2") Application.ScreenUpdating = False F.Range("B" & F.Rows.Count).End(xlUp).Offset(1).Resize(, _ 24).Value = Application.Index(WS.Range _ ("D5,D7,D9,D11,D13,D15,D17,D19,D21,D23,G7,G9,G11,G13,G15,G17,G19,G21,G23,J7,J9,J11,J13,J15"), _ 1, 1, Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, _ 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26)) With F.Range("A3:A" & F.Cells(Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-2") End With Lr = F.Range("A65500").End(xlUp).Row b = F.Cells(2, F.Columns.Count).End(xlToLeft).Column F.Range(F.Cells(3, 1), F.Cells(Lr, b)).Borders.Weight = xlThin ' افراغ CommandButton4_Click Application.ScreenUpdating = True MsgBox "تم اضافة البيانات بنجاح" End Sub 123 (1).xlsm

اولا: . ثم يفتح لك هذا النموذج ، 1. اكتب اسم الحقل (الكلمة التي تريد البحث عنها) الذي تريد ان تبحث عنه في جميع كائنات البرنامج ، حسب ما تم التأشير عليه من جداول واستعلامات وتقارير ونماذج وكود ، 4. انقر البحث ، فيعطيك قائمة بكل كائن فيه هذه الكلمة (تنقر مرتين فيفتح لك الكائن ، وتقدر تغير الكلمة يدويا) ، وبعد ان تطمئن انه لا يوجد خلط وكل شيء واضح ، يمكنك النقر على رقم 2 وتكتب كلمة التغيير/الاستبدال التلقائي لهذه الكلمة في جميع الكائنات.

وعليكم السلام 🙂 احد البرامج اللي ما اقدر استغني عنها في كل كمبيوتر اساسي ابرمج عليه ، هو هذا البرنامج :https://www.skrol29.com/us/vtools.php وفيه بحث/استبدال في قاعدة البيانات كاملة 🙂 وهنا بعض البرامج الاخرى اللي تعمل نفس الشئ: جعفر

اسم الجدول خليه (tbl_From) واسم الكومبوبكس خليه (Cob_From) واسم الحقل لاتغيير . وارسل التعديل وانا بطبق عليه ..

هو غباء وليس ذكاء مطلقا انا عن نفسى كانت تجربتى معه سيئة جدا جدا جدا

وعليكم السلام 🙂 هذه طريقتي في تفكيك الكود الى اسطر ، كما انه مافي داعي لتكرار اسم الجدول لكل حقل ، إلا اذا كان هناك ربط بين اكثر من جدول ، وهناك اسماء حقول متشابهه ، حينها يجب استعمال اسم الجدول واسم الحقل معا : Dim mySQL as string mySQL="SELECT ID, tdate, code, age, hgb, hgb_s, rbc, rbc_s, hct, hct_s," mySQL=mySQL & " hgbp, mcv, mcv_s, mch, mch_s, mchc, mchc_s, rdwcv, rdwcv_s," mySQL=mySQL & " rdwsd, rdwsd_s, plt, plt_s, pct, pct_s, pdw, pdw_s, mpv, mpv_s," mySQL=mySQL & " wbc, wbc_s, netp, netp_s, lymp, lymp_s, monp, monp_s, eosp, eosp_s," mySQL=mySQL & " basp, basp_s, net, net_s, lym, lym_s, mon, mon_s, eos, eos_s, bas, bas_s," mySQL=mySQL & " MIDp, MIDp_s, Mid, MID_s, comment, segmp, segmp_s, bandp, bandp_s, segm, segm_s," mySQL=mySQL & " [band], band_s, WBC_HISTOGRAM, RBC_HISTOGRAM, PLT_HISTOGRAM" mySQL=mySQL & " FROM CBC_tbl" mySQL=mySQL & " WHERE ID=" & [Forms]![visit_frm]![ID] Me.RecordSource = mySQL . . لما يكون عندك استعلام ، الاكسس يعمل له Compile ، ويعمل له شيء اسمه Query plan (خطة عمل الاستعلام) ، فيكون اسرع لان الاكسس عمل طريقه تنفيذيه للاستعلام حسب المعايير والفرز (يعني يقوم بعمل اي معبار قبل الآخر ، ووهل يعمل الفرز قبل تطبيق المعيار وفهرسة الحقول لها دور كبير في عمل هذه الخطة) ، (ويمكنك انزال برنامج تستطيع من خلاله رؤية هذه الخطة وطريقة عملها ، وحتى عمل التغيير عليها ، هنا https://isladogs.co.uk/jet-showplan-manager/index.html ، وللعلم ، فانا اعرف عن خطة عمل الاستعلام اكثر من عقدين ولكني لم اتدخل في عملها الى الآن 🙂)، بينما لما نعمل الاستعلام عن طريق الكود (وهذا يحدث في كل مرة يقرأ بها الاكسس الكود) ، فيقوم الاكسس بعمل خطة عمل ، ومن ثم تنفيذ الاستعلام. ولكن وبعد ان اصبحت الكمبيوترات سريعة ، ففارق الوقت في الفترة التي يأخذها الاكسس في تنفيذ كِلا الاستعلامين ، تُعتبر شبه لا شيء ، ولكن الافضل (ولعدة اسباب ، وخصوصا عند عمل التغيير) والاسرع ، هو عمل الاستعلام شخصيا 🙂 القاعدة الذهبية في فهرسة حقول الاكسس هي: كل حقل تعمل معيار او فرز (سواء في الاستعلام او الكود او فلترة في النموذج او التقرير). ومن هذه القاعدة ، يجب ان يكون حقل ID في جدولك ، مفهرس 🙂 . طريقة فلترة (استعمال المعيار في الاستعلام) ، هي افضل وبأقل كود من استعمال التصفية/الفلترة في النموذج (Me.Filter والذي نحتاج الى عدة اسطر كود للتصفية وتشغيله وحذفه ، وفي عدة احداث) ، اما طريقة عمل التصفية في الاستعلام ، حسب المتغير الذي في النموذج: في الاستعلام ، في الحقل الذي نريد وضع المعيار عليه ، نكتب مسار متغير المعيار كاملا ، مثل Forms!visit_frm!ID ، او اذا كان في نموذج فرعي Forms!visit_frm!SubForm_Name!ID ، ويكون الاستعلام اعلاه مصدر بيانات النموذج visit_frm ، وفي النموذج يكون عندنا سواء مربع نص او مربع سرد او مربع قائمة ، وعلى حدث "بعد التحدبث" للحقل بعد كتابة القيمة فيه او اختيار القيمة ، نكتب me.Requery ، العيب في هذه الطريقة هو ، لا يمكنك استعمال هذا الاستعلام إلا بهذا النموذج ، فلو اردنا استعمال الاستعلام اعلاه مع المسار التالي Forms!myfrm!ID ، فلن يعمل ونظطر لعمل استعلام آخر له. والطريقة التي اتعامل معها في برامجي هي نفس الطريقة اعلاه ، ولكن : في برامجي ، هناك دائما نموذج اساسي لا يتم اغلاقه (frm_1 مثلا) ، واعمل فيه حقول نص مخفية ، مثل ID ، وفي الاستعلام اعلاه ، اعمل المعيار بهذا المسار: Forms!frm_1!ID ، ثم في النموذج visit_frm او myfrm ، وفي حدث "بعد التحديث" للحقل ، اكتب قيمة ID الى النموذج frm_1 ، ثم اشغل الاستعلام ، هكذا: Forms!frm_1!ID = Me.ID Me.Requery بهذه الطريقة يصبح الاستعلام مرن ويمكن استعمال معياره لاكثر من نموذج 🙂 جعفر

استاذ @Zooro1 انت مستخدم اسم الجدول (From) واسم الحقل (From) واسم الكومبوبكس (From) أنا عدلت حسب أصول البرمجة ياريت في مشاركة جديدة وطلبك مجاب انشاء الله .

وعليكم السلام ورحمة الله وبركاته Private Sub Form_Load() Me.Recordset.MoveFirst Do While Not Me.Recordset.EOF Call YourIfCondition(Me![YourTextBox]) Me.Recordset.MoveNext Loop Me.Recordset.MoveFirst End Sub Private Sub YourIfCondition(txtBox As TextBox) If txtBox.Value = "شرط جملة اف" Then MsgBox "قم بتطبيق شرط اف" End If End Sub ضع جملة الشرط الخاصة بك :IIF في sub ثم قم باستدعائها في حدث عند التحميل قم باستدعائها في حلقة تكرارية كما هو موضح في المثال

وعليكم السلام ورحمة الله وبركاته على حسب ما فهت تفضل هذا مثال1.xlsx

"اللهم لا تجعل في قلوبنا غلاً للذين أمنوا" . "خيركم من تعلم العلم وعلمه" . طبعاً أنت فاهم قصدي !!!!!!!!!!!!!!! تفضل استاذ @Zooro1 طلبك ويارب مايكون فيه كود خطأ . تفضل المرفق بطلبك . ووافني بالرد. Combo-1.rar

@Zooro1 بوضح لك شغله .Fields() الصف او السجل غير مطلوب جدول الفولدر -1 جدول الصور 2- جدول اليوم حسب التواريخ -3 جلبهم من سجل (واحد) صفين مختلفين بصفوف بجدولين للعرض وكان المفترض وقت الساعة منظم فستبدلة ب Sleep للسهولة والاختصار ============================== اما للشبكة انترنت في عدة طرق سهلة من غير تكاليف او اشتراك جرب تضبط 3 1- تنصيب قوقل ادرايف للاجهزة الخمسة للاتصال بالقاعدة والفصل وعند الاغلاق اتصال وفصل يعمل بالانترنت بمسار ملف 2- اسهل يوجد نموذج من اكسس للويب اجعلة (تسجيل الدخول) او تحديث لسجل واحد لكل جهاز 3- اسهل واسهل اشبك الكمبيوترات شبك محلية لجهاز واحد عن طريق برنامج ريموت ديسكتوب من قوقل او من سبلاش والاتصال من اي تلفون او كمبيوتر تشوف من الي شبك باللحظة😂وكافة الرعود حسب كفائة الاتصال ومعمارية الجهاز كون هذاك السحاب وعرض تقارير حسب طلبك

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا =IFS(A1="","",A1=0,"لا توجد بضاعة",A1<=999,99,"المخزون على وشك النفاد",A1>=1000,"المخزون متوفر") 'OR =IF(A1=0,"لا توجد بضاعة",IF(A1<=999,99,"المخزون على وشك النفاد",IF(A1>=1000,"المخزون متوفر"))) example.xlsx

في هده الحالة سيتم الاستغناء عن عناصر label وتعويضها بالصور ضع الكود التالي في Module Option Explicit Public IM() As New Classe1 Sub USF() Dim c As Control, n% With UserForm7 For Each c In .Controls If TypeName(c) = "Image" Then ReDim Preserve IM(n) Set IM(n).IM = c n = n + 1 End If Next End With End Sub وفي Classe Module Option Explicit Public WithEvents IM As MSForms.Image Private Sub IM_Click() Dim c As Control For Each c In IM.Parent.Parent.Controls If TypeName(c) = "Frame" Then c.BackColor = RGB(255, 255, 255) Next 'Yellow IM.Parent.BackColor = RGB(255, 255, 0) 'Red..........= RGB(255,0,0) End Sub مع تعديل الاكواد التالية بعد حدف عناصر label Private Sub UserForm_Initialize() For c = 1 To 4 Me("Image" & c).Visible = False Next End Sub '*********************** Private Sub UserForm_Activate() Call USF With Me .startUpPosition = 3 .Width = Application.Width .Height = Application.Height .Left = 0 .Top = 0 End With End Sub ملاحظة Private Sub Workbook_Open() 'تم تعطيل الكود ليتمكن الجميع من الاستفادة Application.DisplayAlerts = False Application.Visible = False 'If Date >= DateValue("15/06/2024") Or Sheets("names").Range("zz1") = "eta" Then 'Sheets("names").Range("zz1") = "eta" 'MsgBox "call me 00201113135517" 'ThisWorkbook.Save 'Application.Quit 'Else UserForm7.Show 'End If End Sub 2.xlsb

السلام عليكم ورحمة الله وبركاته وبها نبدأ تفضل ورقة عمل Microsoft Excel جديد.xlsx

محاولتي حسب فهمي التشغيل من الكود نفسه. الارقام والنصوص_02.xlsm

ولك بالمثل اخي لقد لاحظت ان الاعمدة الاخيرة تتضمن روابط المقاطع على اليوتيوب والفايس اليك تحديث الكود لتتمكن من نسخ Hyperlinks المواقع والانتقال اليها عبر الوورد Public Property Get n() As Worksheet: Set n = Worksheets("WordCopy") End Property Sub Copy_Transfer_WORD1() Dim arr() As String: Dim cnt() As String Dim lastRow As Long: Dim rngA As Variant: Dim rngB As Variant Dim OneRng As Range: Dim tmp As Range: Dim Ary As Variant Dim i As Long: Dim r As Integer: Dim x As Long: Dim j As Range Application.DisplayAlerts = False Application.ScreenUpdating = False Set WS = Worksheets("Sheet1") n.Visible = xlSheetVisible: n.Cells.UnMerge n.Range("A1:J" & n.Rows.Count).Clear lige = 7 lastRow = WS.Range("A" & WS.Rows.Count).End(xlUp).Row cnt() = Split("I-H,J-I", ",") rngA = Array(1, 3, 4, 5, 6, 7, 8) rngB = Array(1, 2, 3, 4, 5, 6, 7) For i = 0 To UBound(rngA) With WS Set OneRng = .Range(.Cells(lige, _ rngA(i)), .Cells(lastRow, rngA(i))).SpecialCells(xlCellTypeVisible) OneRng.Copy n.Cells(1, _ rngB(i)).PasteSpecial Paste:=xlPasteValuesAndNumberFormats End With Next i For r = 0 To UBound(cnt): arr = Split(cnt(r), "-") WS.Range(arr(0) & "8:" & arr(0) & lastRow).Copy Destination:=n.Cells(2, arr(1)) Next r lr = n.Cells(n.Rows.Count, "A").End(xlUp).Row Set tmp = n.Range("A1:J" & n.Rows.Count) Set a = n.Rows(1): Set b = n.Rows(2): Set d = n.[A1:I1]: Set E = n.Range("A3:I" & lr) a.RowHeight = 75: a.Font.Bold = True: b.RowHeight = 40: b.Font.Bold = True: b.Font.Size = 14: d.Font.Size = 24 d.Merge: d.Interior.Color = RGB(192, 192, 192): n.[A2:I2].Interior.Color = RGB(215, 238, 247) With E .Font.Name = "AdvertisingBold": .Font.Size = 13 .WrapText = True: .MergeCells = False End With F = n.Cells(2, n.Columns.Count).End(xlToLeft).Column n.Range(n.Cells(2, 1), n.Cells(lr, F)).Borders.Weight = xlThin Ary = Array(5, 15, 38, 38, 38, 15, 15, 15, 15) For x = 0 To UBound(Ary) n.Columns(x + 1).ColumnWidth = Ary(x) Next x Set Irow = n.Range("A3", n.Cells(n.Rows.Count, "A").End(xlUp)) For Each j In Irow.Rows If j.RowHeight < 20 Then: j.RowHeight = 35: Else j.EntireRow.AutoFit Next With tmp .EntireColumn.HorizontalAlignment = xlCenter .EntireColumn.VerticalAlignment = xlCenter End With With n.Range("A3:A" & n.Cells(Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-2") End With WS.Activate: ExcelToWordSheet1 n.Visible = xlSheetVeryHidden Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub 2024 final V3.xlsm

السلام عليكم ورحمة الله تعالى وبركاته انا بصدد تصميم قاعدة بيانات فى عملى وتباعا ان شاء الله اضع بين اياديكم خلاصة مجهود وتعليم سنوات اولا تسجيل الاخطاء ومعالجتها اولا موديول باسم : basErrorHandling Public strProcessName As String ' The name of the table where errors are logged Public Const TABLE_ERROR_LOG_NAME As String = "tblErrorLog" ' Subroutine to log errors in the error log table Sub ErrorLog(ByVal intErrorNumber As Integer, ByVal strErrorDescription As String, ByVal strErrorProcessName As String) On Error GoTo Err_ErrorLog Dim strErrorMsg As String strErrorMsg = "Error " & intErrorNumber & ": " & strErrorDescription ' Show a message to the user MsgBox strErrorMsg, vbQuestion, strErrorProcessName ' Log error details in the error log table With CurrentDb.OpenRecordset(TABLE_ERROR_LOG_NAME) .AddNew ![ErrorNumber] = intErrorNumber ![ErrorDescription] = Left$(strErrorDescription, 255) ![ErrorProcessName] = strErrorProcessName ![ErrorDate] = Now() ![userName] = GetLoggedUserName() .Update .Close End With Exit_ErrorLog: Exit Sub Err_ErrorLog: ' Error message in case of an unexpected issue strErrorMsg = "An unexpected situation arose in your program." & vbNewLine strErrorMsg = strErrorMsg & "Please write down the following details:" & vbNewLine & vbNewLine strErrorMsg = strErrorMsg & "Calling Proc: " & strErrorProcessName & vbNewLine strErrorMsg = strErrorMsg & "Error Number " & intErrorNumber & vbNewLine & strErrorDescription & vbNewLine & vbNewLine strErrorMsg = strErrorMsg & "Unable to record because Error " & Err.Number & vbNewLine & Err.Description & vbNewLine strErrorMsg = strErrorMsg & "Occurred at Line: " & Erl MsgBox strErrorMsg, vbCritical, "ErrorLog()" Resume Exit_ErrorLog End Sub ' Subroutine to handle and log errors ' This subroutine checks for errors and logs them using the ErrorLog function. ' It clears the error after logging it. ' Parameters: ' - strProcName: The name of the procedure where the error occurred. Public Sub HandleAndLogError(ByVal strProcName As String) ' Check for errors If Err.Number <> 0 Then ' Handle the error and log it Call ErrorLog(Err.Number, Err.Description, strProcName) ' Clear the error Err.Clear End If End Sub ' Function to get the logged username, or return "N/A" if not available Function GetLoggedUserName() As String On Error Resume Next Dim userName As String userName = Environ("USERNAME") If Err.Number <> 0 Then userName = "N/A" Err.Clear End If On Error GoTo 0 GetLoggedUserName = userName End Function ---------------------------------------------------------------------- ثانيا مويدول باسم : basInitialization ' The name of the table where errors are logged Public Const TABLE_ERROR_LOG_NAME As String = "tblErrorLog" ' Subroutine to initialize the application Sub InitializeApplication() ' Initialize the error log table if it doesn't exist If Not IsErrorLogTableInitialized() Then CreateErrorLogTable End Sub ' Check if the error log table exists and is initialized Function IsErrorLogTableInitialized() As Boolean Dim db As DAO.Database Dim rs As DAO.Recordset ' Use error handling to check if the error log table exists On Error Resume Next Set db = CurrentDb Set rs = db.OpenRecordset(TABLE_ERROR_LOG_NAME) On Error GoTo 0 ' Check if the error log table is initialized (contains necessary fields) If Not rs Is Nothing Then On Error Resume Next rs.MoveFirst IsErrorLogTableInitialized = (Err.Number = 0) And (rs.Fields.Count >= 6) On Error GoTo 0 rs.Close End If Set rs = Nothing Set db = Nothing End Function ' Subroutine to create the error log table Sub CreateErrorLogTable() On Error Resume Next Dim db As DAO.Database Set db = CurrentDb ' Check if the table already exists If Not IsTableExists(TABLE_ERROR_LOG_NAME, db) Then ' Define the SQL code to create the table Dim strSQL As String strSQL = "CREATE TABLE " & TABLE_ERROR_LOG_NAME & " (" & _ "ID AUTOINCREMENT PRIMARY KEY, " & _ "ErrorProcessName TEXT(255), " & _ "ErrorNumber LONG, " & _ "ErrorDescription MEMO, " & _ "ErrorDate DATETIME, " & _ "UserName TEXT(255));" ' Execute the SQL command to create the table directly DoCmd.RunSQL strSQL End If Set db = Nothing On Error GoTo 0 End Sub ' Function to check if a table exists in the database Function IsTableExists(tableName As String, Optional db As DAO.Database) As Boolean ' Use DLookup to check for the existence of the table in MSysObjects On Error Resume Next Set db = IIf(db Is Nothing, CurrentDb, db) IsTableExists = Not IsNull(DLookup("Name", "MSysObjects", "Name='" & tableName & "'")) On Error GoTo 0 End Function وظيفة الموديول هو تهئة ما اريد لقاعدة البيانات البدء به ومن خلاله ---------------------------------------------------------------------- 3- نموذج البداية وليكن الان باسم frmInitialization وفى حدث عند التحميل نضع الكود الاتى Private Sub Form_Load() strProcessName = "Form Load : frmIntialization" On Error Resume Next ' Initialize the application when the startup form is loaded. InitializeApplication ' Add calls to the initialized special functions through which you want the database to be booted ' Or add specify the codes through which you would like to process the data later according to the requirements of your design ' Set the current procedure name (you can adjust the procedure name as needed) If Err.Number <> 0 Then ' Handle the error (display a message) Call ErrorLog(Err, Error$, strProcessName) ' Clear the error Err.Clear End If End Sub النتيجة المرغوب فى الخصول عليها : عند تشغيل القاعدة فى المرة الأولى تنشئ جدول تسجيل الأخطاء من تلقاء نفسها باسم الروتين او الحدث ورقم الخطاء والوصف المتطلبات عند اعداد الاكواد تباعا نمرر اسم الروتين من خلال المتغير strProcessName كما فعلت فى الحدث السابق للنموذج: strProcessName = "Form Load : frmIntialization" لو حدث اى خطأ مستقبلا سوف يتم تسجيله حتى يستطيع مطور النظم او القائم على اعمال صيانة قواعد البيانات او المصمم معرفة مكان حدوث الخطأ الشق الثانى نقوم بعمل الايقاف للاخطا ليستكمل الكود عمله حتى لو وجودت اى اخطاء من خلال : On Error Resume Next بعد كتابة الكود كما نريد وبعد ان ننتهى منه نضع الشرط التالى : If Err.Number <> 0 Then بذلك نضع شرط عند الدوران على الكود لتنفيذه فى حالة وجود خطأ اولا اظهر رسالة الخطأ حتى يعلم المستخدم سبب المشكلة ثم استدعى الدالة لتسجيل هذا الخطأ ويتم ذلك من خلال Call ErrorLog(Err, Error$, strProcessName) الان هذه بداية احترافية وعلى اسس صحيحة ومفيدة للمستقبل ..... يتبع HandleAndLogError.accdb

السلام عليكم تم تحويل المعادلات كلها الى اكواد الكود يتعامل حتى الصف 5000 officena 2.xlsm

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

هذه قائمة منسدلة متعددة المستويات اضافة لما تفضل به علينا استاذنا الكبير ابو ثامر اعاده الله الينا سالما معافى ان شاء الله ظ‚ط§ط¦ظ…ط© ظ…طھط¹ط¯ط¯ط© ط§ظ„ظ…ط³طھظˆظٹط§طھ.rar