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

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

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

اخي الكريم يجب عليك تثبيت Framework 4.5 يرجى تجربة الملفات المرفقة Setup.rar Debug.rar

تم التعديل على الملف السابق كما تريد بالضبط .... وهذا حل اخر ان اردت يمكنك ذلك من خلال قائمة Data ثم تختار Subtotal إدراج صف تلقائى - 1.xlsm

بعد اذن اخي حسن مأمون بواسطة هذا الكود تستطيع اختصار 94 حلقة تكرارية (y=6 to 100) في كل دورة من الـــ X من 1 الى Lr اذن لوكان عدد الصفوف 100 صف فاننا نقوم بــ 94×100= 9400 حلقة تكرارية لا حاجه لها يمكن هنا استعمال الدالة Match او الدالة Find لتحديد العامود الذي نريد الصاق قيمة الخلية المطلوب ولا حاجة للدورة ثانية من الحلقات التكراية(y) كما لا ننسى تفريغ النطاق كله قبل مباشرة الكود بالعمل من خلال السطر السادس من الكود وبذلك نوفر الجهد و عدم حشو الذاكرة بشيء لاتستفيد منه اضافة الى تحجيم الملف هذا مثال عن الماكرو كما اتصوره هنا Sub MY_code() Dim x%, lr%, col%, Last_col% Dim Find_cel As Range Last_col = Cells(2, Columns.Count).End(1).Column lr = Cells(Rows.Count, "e").End(3).Row Range("F3").Resize(lr, Last_col - 5).Clear For x = 3 To lr Set Find_cel = Rows(2).Find(Cells(x, "e"), lookat:=1) If Not Find_cel Is Nothing Then col = Find_cel.Column Cells(x, col) = Cells(x, "D") End If Next With Range("F3").Resize(lr, Last_col - 5).SpecialCells(2) .Borders.LineStyle = 1 .Interior.ColorIndex = 6 .Font.Bold = True .HorizontalAlignment = 3 End With End Sub الملف مرفق My_value.xlsm

تفضل يمكنك وضع استخدام هذا الكود بحدث الصفحة , بحيث يقوم بإدراج صف فارغ بمجرد إدخال تاريخ مختلف Private Sub Worksheet_Change(ByVal Target As Range) Dim L& If Target.Address = Cells(Rows.Count, 5).End(xlUp).Address Then If IsDate(Target) And IsDate(Target(0)) Then If Target.Value2 <> Target(0).Value2 Then Application.EnableEvents = False Application.ScreenUpdating = False Target.EntireRow.Insert If IsEmpty(Target(-2)) Then L = Target(-1).Row Else L = Application.Max(6, Target(-1).End(xlUp).Row) With Target(0).EntireRow .Interior.ColorIndex = 4 .Interior.Pattern = xlSolid .Columns("B:C").Formula = "=SUM(B" & L & ":B" & Target(-1).Row & ")" .Cells(4).Value2 = "إجمالى اليوم " End With Application.ScreenUpdating = True Application.EnableEvents = True End If End If End If End Sub إدراج صف تلقائى - 1.xlsm

تفضل 2021 IN المشتريات.xlsx

عملت طريقة Tag ونجح Dim ctl As Control For Each ctl In Me.Controls If ctl.ControlType = acTextBox Or ctl.ControlType = acComboBox Then If ctl.Tag = 1 Then ctl.Value = Null End If End If Next ctl الطريقة : تذهب لخصائص الحقل تبويب| غير ذلك | علامة | ضع رقم 1 في الحقول التي تريد تفريغها مع استثناء الترقيم التلقائي . تفريغ الحقول.mdb

تمت معالجة الامر Option Explicit Sub MY_Data_New() Application.ScreenUpdating = False Dim SH_from As Worksheet Dim T As Worksheet Dim rg_to_Patse As Range Dim Rt%, MY_max%, ro%: ro = 4 Set T = Sheets("Total") Set rg_to_Patse = T.Range("A3").CurrentRegion Rt = rg_to_Patse.Rows.Count If Rt > 1 Then Set rg_to_Patse = rg_to_Patse.Offset(1).Resize(Rt - 1) Else Set rg_to_Patse = T.Range("B4").Resize(, 5) End If rg_to_Patse.Clear For Each SH_from In Sheets If SH_from.Name <> T.Name Then MY_max = Application.Max(SH_from.Range("A:A")) SH_from.Cells(3, 1).Resize(MY_max, 6).Copy With T.Cells(ro, 1) .PasteSpecial (xlPasteValues) .PasteSpecial (xlPasteFormats) End With ro = ro + MY_max End If Next SH_from With T.Range("A3").Resize(ro - 4, 6) .Sort key1:=Range("b3"), Header:=1 End With Application.ScreenUpdating = True arraNge_all End Sub '+++++++++++++++++++++++++++++++++++ Sub arraNge_all() Application.ScreenUpdating = False Dim nro% Dim MM% nro = Cells(Rows.Count, 1).End(3).Row Dim color_rg As Range For MM = 4 To nro If Range("B" & MM).Interior.ColorIndex = 2 Or _ Range("B" & MM).Interior.ColorIndex = -4142 Then GoTo Next_MM If color_rg Is Nothing Then Set color_rg = Range("B" & MM).Resize(, 5) Else Set color_rg = Union(color_rg, Range("B" & MM).Resize(, 5)) End If Next_MM: Next If color_rg Is Nothing Then GoTo Contenu color_rg.Copy Range("B" & nro + 1) color_rg.EntireRow.Delete Contenu: Range("B4", Range("B3").End(4)).Offset(, -1).Formula = _ "=IF(B4="""","""",MAX($A$3:A3)+1)" With Range("A3").CurrentRegion .Value = .Value .Borders.LineStyle = 1 End With Range("A4").Select Set color_rg = Nothing create_borders Application.ScreenUpdating = True End Sub '+++++++++++++++++++++++++++++++++++ Sub create_borders() Dim My_sh As Worksheet, r For Each My_sh In Sheets If My_sh.Name <> "Total" Then r = My_sh.Cells(Rows.Count, 2).End(3).Row My_sh.Cells.Borders.LineStyle = xlNone My_sh.Range("a2").Resize(r - 1, 6).Borders.LineStyle = 1 End If Next End Sub الملف الأخير Laste_flie.xlsm

تفضل لك اكثر مما طلبت نظاما - 1.xlsm

السلام عليكم 🙂 هناك الكثير من الميزات/الاوامر التي يعطينا برنامج الاكسس ، والتي يمكن ان نعمل لها بديل ، ولكن يكون هناك فرق في سرعة تنفيذ كودنا مقارنة مع الكود الاصل من الاكسس !! مثل القائمة المختصرة التي تظهر لنا بالنقر على زر الفأرة الايمن ، والتي بها يمكننا ان نستغني عن الكثير الاوامر ، مثل الفرز والتصفية بأنواعه ، ولكن وللأسف الشديد ، فأنا ارى ان 99.99% من البرامج ، يتم حذف هذه القائمة وعدم تفعيلها ، والسبب ان المستخدم يستطيع ان يدخل في تصميم النموذج من خلال هذه الاوامر(في الدائرة الحمراء) : و . ويضطر المبرمج ان يعوض بقية الاوامر في القائمة ، بمجموعة من الازرار ، او بطرق مختلفة !! ----------------------------------------------------------------------------------------------- الاكسس يسمح لنا ان نعمل قوائم مختصرة Shortcut Menu والتابعة لمجموعة CommandBars ، حسب احتياجنا ، ونختار ما نضعه فيها 🙂 هناك 3 انواع من هذه القوائم : الثابته ، والمؤقته ، والمؤقته التي تحتاج الى كود. الثابته: وهي التي عندما نعملها ، تصبح مستقله عن الكود ، وتُحفظ وتبقى في قاعدة البيانات بعد إغلاقها ، ويمكننا ان نستوردها في قاعدة بيانات اخرى عندما نستورد احد/جميع كائنات قاعدة البيانات الآخرى ، بإستخدام : . ونختارها في النموذج : . او التقرير : . هذا مثال لعمل الكود الاساس لعمل قائمة قطع/نسخ/لصق : Option Compare Database Option Explicit Dim cmb As Object Dim cmbCtrl As Object Dim cmbName As String ' ' ' to use: ' Dim cbr As Commandbar ' Dim cbrButton as CommandbarControl ' ' we have to select in the References: ' Microsoft Office xx.x Object Library ' Public Function SCM_Copy(Optional DeleteMe As Boolean = False) On Error Resume Next 'If menu with same name exists delete cmbName = "cmb_Copy" CommandBars(cmbName).Delete If DeleteMe = True Then Exit Function If Err.Number <> 0 Then Err.Clear Set cmb = CommandBars.Add(cmbName, msoBarPopup, False, False) With cmb .Controls.Add msoControlButton, 21, , , False ' Cut .Controls.Add msoControlButton, 19, , , False ' Copy .Controls.Add msoControlButton, 22, , , False ' Paste End With Set cmb = Nothing End Function . وشرح الكود : 1. اسم القائمة المختصرة ، والتي سوف نختارها في النموذج او التقرير ، 2. هذه المجموعة الاساس منبثقة Popup ، 3. بينما هذه المجموعات عبارة عن ازرار Buttons ، وقد تكون قائمة منسدلة Combobox ، او نص Edit نُدخل فيه قيمة معينة للتصفية مثلا ، 4. هل هذه القائمة مؤقته ؟ False معناها ثابته وتُحفظ في قاعدة البيانات ، بينما True معناها انها مؤقته وتعمل لما ننادي الوحدة النمطية/الكود ، 5. هذه ارقام كل امر ، وملف الاكسل المرفق من مايكروسوفت فيه جدول يضم جميع ارقام الاوامر للاكسس 2010 () ، 6. اذا اردنا ان نحذف هذه القائمة ، فننادي الوحدة النمطية بضم True في امر المناداة المؤقته: ونستعمل True في مكان الرقم 4 اعلاه. وهي التي عندما نعملها ، لا تصبح مستقله عن الكود ، ولا تبقى في قاعدة البيانات بعد إغلاقها ، ولا يمكننا ان نستوردها في قاعدة بيانات اخرى عندما نستورد احد/جميع كائنات قاعدة البيانات الآخرى (كما هو الحال مع القائمة الثابته) ، ويجب ان نستخدم "حدث فتح" النموذج/التقرير لعملها واستخدامها في النموذج/التقرير ، و "حدث اغلاق" النموذج/التقرير لحذفها ، طيب ، خلونا نعمل هذه القائمة : Public Function SCM_Copy_Sort(Optional DeleteMe As Boolean = False) On Error Resume Next 'If menu with same name exists delete cmbName = "cmb_Copy_Sort" CommandBars(cmbName).Delete If Err.Number <> 0 Then Err.Clear Set cmb = CommandBars.Add(cmbName, msoBarPopup, False, False) With cmb Set cmbCtrl = .Controls.Add(msoControlButton, 21, , , False) ' Cut cmbCtrl.Caption = "Cut..." cmbCtrl.FaceId = 21 Set cmbCtrl = .Controls.Add(msoControlButton, 19, , , False) ' Copy cmbCtrl.Caption = "Copy..." cmbCtrl.FaceId = 19 Set cmbCtrl = .Controls.Add(msoControlButton, 22, , , False) ' Paste cmbCtrl.Caption = "Paste..." cmbCtrl.FaceId = 22 Set cmbCtrl = .Controls.Add(msoControlButton, 210, , , False) 'Sort Ascending cmbCtrl.BeginGroup = True cmbCtrl.Caption = "فرز تصاعدي..." cmbCtrl.FaceId = 210 Set cmbCtrl = .Controls.Add(msoControlButton, 211, , , False) 'Sort Decending cmbCtrl.Caption = "فرز تنازلي..." cmbCtrl.FaceId = 211 End With Set cmb = Nothing End Function . وشرح الكود: احنا توسعنا في الكود الاساسي ، واضفنا له : 1. تسمية اختيارية غير الافتراضية ، لاحظ في الصورة اعلاه اني استعملت الانجليزي والعربي ، 3. وهو لعمل خط فاصل في الصورة بين مجموعة قطع/نسخ/لصق ومجموعة فرز تصاعدي/تنازلي ، . 2. ممكن ان نبدل الصورة الافتراضية التي تيجي مع الرقم ، بتبديل هذا الرقم (لاحظ صورة الاسهم للتصاعدي/التنازلي) : . ومرفق ارقام جميع الصور الموجودة في الاكسس : . . . . . . . . . . . في قاعدة البيانات المرفقة myRight_Click.mdb ، بالاضافة الى القوائم الثابته اعلاه ، تم اضافة هذه القائمة ايضا : . والتقرير يحتوي على القائمة المؤقته التالية : . - ملف الاكسل myList.xlsx ، اخترت فيه اهم القوائم في وجهة نظري ، - ملف الاكسل AccessControls_2010.xlsx ، من مايكروسوفت ، يحتوي على جميع الاوامر 🙂 جعفر المصادر: http://dev-soln.com/access-shortcut-right-click-tool/ https://www.experts-exchange.com/articles/12904/Understanding-and-using-CommandBars-Part-II-Creating-your-own.html https://filedb.experts-exchange.com/incoming/2014/02_w06/833359/CommandBars-II.mdb https://www.experts-exchange.com/articles/18341/CommandBars-Part-III-Using-Built-in-Shortcut-Menus.html http://www.skrol29.com/us/vtools.php AccessControls_2010.xlsx myList.xlsx myRight_Click.zip

السلام عليكم ورحمة الله وبركاته اخواني الاعزاء في هذا المنتدي الكريم من اساتذتنا الكرام في المرفق كشف حضور وغياب لمركز تعليم له ايام محددة لكل شعبة مبينة في الشيت( المفتاح الاساسي) واسماء الطلاب لكل شعبة المطلوب فضلا منكم مايلي.. التنقل بين الشعب من خلال قائمة منسدلة -1 التنقل بين الشهور مع تظليل الايام التي ليس بها دوام لكل شعبة يمنع الكتابة بها -2 حساب نسبة الحضور لكل شعبة-3 في شيت التقرير حساب نسبة الحضور و الغياب لكل الشعب -4 اسال الله ان يكون في ميزان حسناتكم علما ينتفع بة كشف حضور التعليم.xlsx

حياك الله في الخدمة

الله يفتح عليك معلمنا الجليل / @kha9009lid

بعد اذن اخواني لكي تتعدد الخيارات اخي الكريم لكي يسهل عليك الامر استخدم الكود التالي Dim dbsNorthwind As DAO.Database Dim rstShippers As DAO.Recordset Set dbsNorthwind = CurrentDb Set rstShippers = dbsNorthwind.OpenRecordset("Table_Name") With rstShippers .AddNew !User_Name = [text1] !Password = [text2] .Update End With

اعجبتني هذه المقوله : قَالَ ابْنُ الْمُبَارَكِ: لَا يَزَالُ الْمَرْءُ عَالِمًا مَا طَلَبَ الْعِلْمَ، فَإِذَا ظَنَّ أَنَّهُ قَدْ عَلَمَ؛ فَقَدْ جَهِلَ

انا الذى عليه شكركم اخوانى واساتذتى بارك الله فيكم اضافه جميله باستخدام تاج الترقيم اخى صالح @ابوآمنة ولكن ايضا يضيف السجل الفارغ برقمه والكود التالى بدون استخدام التاجات خالص فالمشاركه السابقه لى Dim ctl As Control On Error Resume Next For Each ctl In Me.Controls If ctl.ControlType = acComboBox Or ctl.ControlType = acTextBox Then 'Add other control types here ctl.Value = "" End If Next ctl Set ctl = Nothing DoCmd.GoToRecord , , acNewRec فقمت باستخدام حذف السجل الفارغ المضاف واعاده الفهرسه هذا ما توصلت اليه حتى لا يكون هناك سجلات فارغه وجزاهم الله خيرا اساتذتنا ومعلمينا فى اول تعديل لظهور الخطأ وشغال تمام وملاحظتك لى عندما قلت لم يشتغل معى وارفقت مثالك اتضح لى الخطأ ما بين مثالى الذى اعمل عليه ومثالك المرفق وننتظر صاحب السؤال ليقول هل تم تجربه الاكواد ع قاعده البيانات الخاصه به وهل تم طلبه تمتعت واستفدت كثيرا من مشاركتكم معى وانتظر ايضا اخى على @Ali Sadiq للتعقيب وشرح كوده فضلا لا امرا وهل فعلا محتاج التاج كما اشتغل معى بوضع التاجات ام هناك شىء لم افهمه وارجو منكم قبول عذرى وجهلى فمازلت اتعلم واحاول ان افهم منكم اخوانى واساتذتى بارك الله فيكم وجزاكم الله كل خير تقبلوا تحياتى وتمنياتى لكم وللجميع بالتوفيق بالنجاح احبكم فالله

وعليكم السلام اخي الكريم راجع اعدادات اللغة العربية للنظام انشاء الله ستحل المشكلة

شكراً إضافة جميلة يا أخي أحمد وإعادة الفهرس من جديد أضفت تجربتي شاهد المرفق 'إضافة الحقول المستثناه ID.Tag = 2 For Each ctl In Me.Controls If ctl.ControlType = acComboBox Or ctl.ControlType = acTextBox Then If ctl.Tag <> 2 Then ctl.Value = Null End If End If Next ctl بدون إضافة التاج في خصائص الحقل يتم إضافته في الكود . تفريغ الحقول(2).mdb

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

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

توصل بالسلامه ان شاء الله اخى صالح جزاك الله خيرا فى ملحوظه مهمه : بان الكود يعمل لدى لان حقل الترقيم التلقائى بالكود وليس ترقيم تلقائى كما بمثالك اخى صالح جزاك الله خيرا اخى @kaser906 على مشاركتك لنا قد افرغ النص بالتاج اخى كاسر @kaser906 مع الابقاء على حقل الرقم بالفعل والكود التالى الذى توصلت اليه يقوم بنفس العمل يقوم بتفريغ النصوص ما عدا حقل الترقيم وكذلك من غير وضع التاجات فى حين هناك الكثير من مربعات النص ثم الذهاب لسجل جديد Dim ctl As Control On Error Resume Next For Each ctl In Me.Controls If ctl.ControlType = acComboBox Or ctl.ControlType = acTextBox Then 'Add other control types here ctl.Value = "" End If Next ctl Set ctl = Nothing DoCmd.GoToRecord , , acNewRec ولكن يفرغ الحقول وينشىء حقل فارغ واخر تعديل لى مع الترقيم التلقائى مع مثال اخى صالح @ابوآمنة Dim ctl As Control On Error Resume Next For Each ctl In Me.Controls If ctl.ControlType = acComboBox Or ctl.ControlType = acTextBox Then 'Add other control types here ctl.Value = "" End If Next ctl Set ctl = Nothing Me.RecordSource = "" DoCmd.SetWarnings False DoCmd.RunSQL "DELETE Temp3.f1, Temp3.f2, Temp3.F3, Temp3.ID FROM Temp3 WHERE (((Temp3.f1) Is Null)) OR (((Temp3.f2) Is Null)) OR (((Temp3.F3) Is Null));" DoCmd.RunSQL "DROP INDEX ID ON Temp3;" DoCmd.RunSQL "alter table Temp3 drop ID;" DoCmd.RunSQL "alter table Temp3 Add column ID autoincrement;" DoCmd.RunSQL "CREATE UNIQUE INDEX ID on Temp3(ID) ;" DoCmd.SetWarnings True Me.RecordSource = "Temp3" DoCmd.GoToRecord , , acNewRec وفى انتظار شروحاتكم مرفق المثال تقبلوا تحياتى وتمنياتى لكم وللجميع بالتوفيق تفريغ الحقول(1).mdb

السلام عليكم جربو هذا الكود فهو يفرغ مربعات النص والكمبو بوكس التي تحتوي على علامة الناج "En" مع اسثناء الحقول التي لا تحمل العلامة فالمفترض حقل الترقيم التلقائي لا يجب وضع علامة التاج اليه Dim ctl As Control For Each ctl In Me.Controls If ctl.Tag = "En" Then ctl = Null End If Next ::بالتوفيق::

بارك الله فيك استاذي سليم عمل رائع

انا ع طريق سفر فور وصولي بمشيئة الله سأطلع ع المثال

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

أضم صوتي للزميل في السؤال عن كيفية تشغيلك لبرنامجك على الأندرويد و جزاكم الله خيرا

استاذ / @أحمد الفلاحجى الله يفتح عليك فعلا قد اتضحت الصورة الآن بارك الله فيك وجعله في ميزان حسناتك الأن فى انتظار استاذنا / @kha9009lid

الله يجزاكم بالخير حبايبي دعوه لكم من ظهر قلب

حياك أخي احمد للأسف حاولت الاستثناء لكن لم يفلح . لعل الأخوة الزملاء يفتح الله عليهم بطريقة استثناء حقل الترقيم التلقائي .

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

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

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

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

وعليكم السلام-تفضل لك ما طلبت Classeur4.xlsx

بعد تنفيذ الماكرو الق نظرة على الشيتات ترى كل شيء قد تم كما تريد

الحلقة الثانية: أكواد الطباعة و الخصائص و... سوف نتطرق في هذه الحلقة إلى الأكواد التي تمكننا من طباعة صفحة الويب و حفظها و عرض خصائص الصفحة و غيرها... 1- كود طباعة الصفحة: Me.WebBrowser3.ExecWB OLECMDID_PRINT, OLECMDEXECOPT_DODEFAULT 2- كود معاينة طباعة الصفحة: Me.WebBrowser3.ExecWB OLECMDID_PRINTPREVIEW, OLECMDEXECOPT_DODEFAULT 3- كود عرض خصائص الصفحة: Me.WebBrowser3.ExecWB OLECMDID_PROPERTIES, OLECMDEXECOPT_DODEFAULT 4- كود حفظ صفحة الويب: Me.WebBrowser3.ExecWB OLECMDID_SAVEAS, OLECMDEXECOPT_DODEFAULT 5- كود تنسيق الصفحة: Me.WebBrowser3.ExecWB OLECMDID_PAGESETUP, OLECMDEXECOPT_DODEFAULT 6- كود عنوان رابط الصفحة: MsgBox Me.WebBrowser3.LocationName 7- كود رابط الصفحة: MsgBox Me.WebBrowser3.LocationURL 8- كود فتح الصفحة الإفتراضية للمتصفح: Me.WebBrowser3.GoHome 9- كود فتح صفحة البحث: Me.WebBrowser3.GoSearch 10- كود فتح صندوق التصفح: هذا الكود يقوم بفتح صندوق لإدخال رابط صفحة ويب جديدة Me.WebBrowser3.ExecWB OLECMDID_OPEN, OLECMDEXECOPT_DODEFAULT 11- كود تخطي رسائل الأخطاء التي تظهر من الأداة عند التصفح: Me.WebBrowser3.Silent = True وهذا المرفق بعد الإضافات الجديدة webbroser.rar

بارك الله فيك أستاذنا الفاضل علي محمد علي وبعد إذنك أرى أن يتم أيضا الكود في حدث ThisWorkBook Private Sub Workbook_BeforeClose(Cancel As Boolean) show_menu End Sub حتى يعود الإكسيل للوضع الافتراضي بعد غلق هذا الملف فعندما يتم فتح ملف آخر لا يجد الشريط مخفى ويحدث هذا الأمر على الأكثر في إصدرات الأوفيس القديمة Hide.xlsm

السلام عليكم حبيت اعمل مشاركة بسيطة وياكم بعض اكواد VBA لكل من يبي يعمل واجهة نظامية تحياتي ADO.rar

تم معالجة الامر انظر الى الصفحة New_Sheet من هذا الملف الباسورد 500 Salim 2018 With_combo.xlsm

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

وعلشان اصطياد الخطأ يشتغل ، السطر الثاني يخبر الكود اين يذهب عندما يجد الخطأ: Private Sub أمر2_Click() On Error GoTo err_Report فهل عندك هذا السطر في الكود جعفر

استاذي الصورة اللي وضعتها فقط للخطأ هذا هو الكود اللي وضعته بالكامل ويطلع الخطأ Dim rst As DAO.Recordset mySQL = "SELECT Tbl_Month.exchange, Tbl_Month.Monthly, Tbl_Month.Yaree" mySQL = mySQL & " FROM Tbl_Month_exchange INNER JOIN Tbl_Month ON (Tbl_Month_exchange.Yaree = Tbl_Month.Yaree) AND (Tbl_Month_exchange.Monthly = Tbl_Month.Monthly)" mySQL = mySQL & " WHERE (((Tbl_Month.Monthly)=" & Forms!frm_3!Monthly & ") And ((Tbl_Month.Yaree)=" & Forms!frm_3!Yaree & "))" Set rst = CurrentDb.OpenRecordset(mySQL) rst.MoveLast: rst.MoveFirst RC = rst.RecordCount If rst!exchange > 0 Then MsgBox "Exchange field value is Greater than Zero" Else MsgBox "Not Greater than Zero" End If Exit_Report: rst.Close: Set rst = Nothing Exit Sub err_Report: If Err.Number = 3021 Then MsgBox "لا يوجد تشابه بين الجدولين" Resume Exit_Report Else MsgBox Err.Number & vbCrLf & Err.Description End If

كل اللي اقدر اقوله: الله يسامحك ، نسخت جزء من الكود ، وجزء تركته شوف رقم الخطأ اللي ظهر لك: 3021 ، وشوف الكود حقي كيف يصطاد هذا الرقم If Err.Number = 3021 Then MsgBox "لا يوجد تشابه بين الجدولين" Resume Exit_Report Else جعفر

عندما وضعت الكود في برنامجي ظهر عندي هذا الخطأ عندما وجد شرط ينطبق اي هناك سجل في في الجدول Tbl_month وكان قيمة القل exchange اكبر من صفر ولم يجد سجل في الجدول Tbl_Month_exchange

بدل هذا السطر MsgBox "Exchange field value is " & rst!Exchange استعمل if rst!Exchange >0 then MsgBox "Exchange field value is Greater than Zero" else msgbox "Not Greater than Zero" endif

الله يعطيك العافية استاذي نسيت تضيف شرط ان تكون قيمة الحقل exchange اكبر من صفر

تفضل في هذا الاستعلام ، اذا الحقلين Monthly و Yaree كانوا متساوين في الجدولين ، سنحصل على سجلات ، واذا لا ، فلن نحصل على سجلات ، وبالزر اليمين في الاستعلام ، طلبنا رؤية الاستعلام بطريقة SQL ، فعملت نسخه منه ووضعته في الكود: Private Sub أمر2_Click() On Error GoTo err_Report 'If DCount("[coodkind]", "Tbl_Month", "[exchange]>0 And [Yaree] = Forms![frm_3]![Yaree] and Monthly = Forms![frm_3]![Monthly]") > 0 Then 'msg " اكمل السجلات بالجدول " Dim rst As DAO.Recordset mySQL = "SELECT Tbl_Month.exchange, Tbl_Month.Monthly, Tbl_Month.Yaree" mySQL = mySQL & " FROM Tbl_Month_exchange INNER JOIN Tbl_Month ON (Tbl_Month_exchange.Yaree = Tbl_Month.Yaree) AND (Tbl_Month_exchange.Monthly = Tbl_Month.Monthly)" mySQL = mySQL & " WHERE (((Tbl_Month.Monthly)=" & Forms!frm_3!Monthly & ") And ((Tbl_Month.Yaree)=" & Forms!frm_3!Yaree & "))" Set rst = CurrentDb.OpenRecordset(mySQL) rst.MoveLast: rst.MoveFirst RC = rst.RecordCount MsgBox "Exchange field value is " & rst!Exchange Exit_Report: rst.Close: Set rst = Nothing Exit Sub err_Report: If Err.Number = 3021 Then MsgBox "لا يوجد تشابه بين الجدولين" Resume Exit_Report Else MsgBox Err.Number & vbCrLf & Err.Description End If End Sub جعفر 592.countmy.accdb.zip

ان شاء الله تكون الصورة هذي توضح المطلوب

المثال الثاني مثل السابق مع الحماية باستخدام كلمة سر و هي 1234 لأن الحالة السابقة يمكن فك الحماية من القوائم مباشرة Sub Pr1() ActiveSheet.Protect Password:=1234, DrawingObjects:=True, Contents:=True, Scenarios:=True End Sub Sub Pr2() x = InputBox("please enter PAssword '1234'", "Password", 123) If x <> 1234 Then MsgBox "Sorry You are not Allowed !!! " Exit Sub End If ActiveSheet.Protect Password:=1234, DrawingObjects:=False, Contents:=False, Scenarios:=False End Sub UnprotectSheetPass.xls