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

أ.عبدالعزيز محمد جرب المرفق عسى أن يكون ما طلبت .. عذرا إن كانت الطريقة قديمة شويتين .. ولكن الجودة بالموجوده 😃 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 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 الاول لكن لسه مش متظبطه معايا ربنا ييسرها والحمدلله ربنا بيسرها اجد ما اريد من اكود بسيطه توضح وتفتح لى الابواب جزاكم الله خيرا اساتذتى تقبلوا تحياتى وتمنياتى لكم وللجميع بالتوفيق

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

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

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

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

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

Dim ctl As Control For Each ctl In Me.Controls If ctl.ControlType = acTextBox Or ctl.ControlType = acComboBox Then If ctl.Value <> "" Then ctl.Value = "" End If End If Next ctl جرب هذا الكود

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

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

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

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

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

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

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

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

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

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

قم بانشاء شيت جديد باسم Salim ونفذ هذا الكود Option Explicit Sub Del_Exta_Rows() Dim S_sh As Worksheet 'source sheet Dim T_sh As Worksheet 'target sheet Dim Lrs% 'laste row in source sheet Dim Cols% 'laste column in source sheet Set S_sh = Sheets("Recovered_Sheet1") Set T_sh = Sheets("Salim") T_sh.Cells.Clear Lrs = S_sh.Cells(Rows.Count, 1).End(3).Row Cols = S_sh.Cells(1, Columns.Count).End(1).Column S_sh.Cells(1, 1).Resize(Lrs, Cols). _ SpecialCells(xlCellTypeConstants).Copy T_sh.Cells(1, 1).PasteSpecial (xlPasteAll) Application.CutCopyMode = False With T_sh.Range("a1").CurrentRegion .Columns.AutoFit .Borders.LineStyle = 1 .Cells(1).Select End With End Sub الملف مرفق ( شيت Salim ) DEL_ROWS.xlsm

اكثر من رائع صديقي العزيز يسر الله امورك كما يسرت لي بشرحك الوافي جزاك الله خيرا اخي

اهلا وسهلا استاذي ابو بسملة الحقيقة الطريقة التي استخدمها تختلف قليلا عن هذه الطريق وان كانت تشترك معها في استخدام اكواد او وسوم xml الطريقة متعبة وتحتاج الى معرفة بهذة الوسوم او على الاقل المعرفة بلغة ترميز النصوص المتشعبة html الخاصة ببناء صفحات الانترنت لوجود تشابه بينهما طريقتي باختصار كتابة الوسوم ووضع id لكل امر اما طريقة تنفيذ الامر فعن طريق وحدة نمطية مع ان النتيجة رائعة الا ان الطريقة متعبة جدا وسوف احاول بعون الله ان اضع موضوع يشرح الطريقة واعتذر اذاكان الرد غير مفيد واستعير عبارة جميلة لاخي واستاذي الفاضل @essam rabea "انا راجل عجوز" فانا فعلا رجل عحوز والشروحات مرهقة جدا

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

الحلقة الثانية: أكواد الطباعة و الخصائص و... سوف نتطرق في هذه الحلقة إلى الأكواد التي تمكننا من طباعة صفحة الويب و حفظها و عرض خصائص الصفحة و غيرها... 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

تفضل لك ما طلبت هذه الأكواد فى مديول عادى Sub hide_menu() Application.ExecuteExcel4Macro "show.toolbar(""Ribbon"",False)" End Sub Sub show_menu() Application.ExecuteExcel4Macro "show.toolbar(""Ribbon"",True)" End Sub وهذا الكود فى حدث ThisWorkBook Private Sub Workbook_Open() hide_menu End Sub وذلك كما بالملف Hide.xlsm

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

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

استاذي الصورة اللي وضعتها فقط للخطأ هذا هو الكود اللي وضعته بالكامل ويطلع الخطأ 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

تفضل في هذا الاستعلام ، اذا الحقلين 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