اذهب الي المحتوي
أوفيسنا

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

  1. محمد هشام.

    محمد هشام.

    الخبراء


    • نقاط

      6

    • Posts

      1,366


  2. kkhalifa1960

    kkhalifa1960

    الخبراء


    • نقاط

      4

    • Posts

      1,688


  3. Foksh

    Foksh

    الخبراء


    • نقاط

      2

    • Posts

      2,155


  4. at_aziz

    at_aziz

    03 عضو مميز


    • نقاط

      2

    • Posts

      425


Popular Content

Showing content with the highest reputation on 04 يون, 2024 in all areas

  1. ولك بالمثل اخي @أبو قاسم يسعدنا اننا استطعنا مساعدتك
    2 points
  2. تفض أخي الكريم ملف رائع من أحد أساتذة المنتدى الأستاذ عبدالفتاح كيره الديناميكى التام لاستعراض السجل وحفظ التغييرات مع الفريم1kemas.xls تفضل ملف آخر للعلامه خبور فورم ادخال و تعديل مرن.xlsm
    2 points
  3. حياك الله وبياك استاذي المراجع اللي ارفقتها اليوم ماكان عندي وقت اقراها لكن ان شاءالله غدا او اللي بعده لعل يتيسر لنا الوقت ونقرأها بتمعن ونسأل الله الاعانه لنا ولكم ولكل الأعضاء الكرام
    1 point
  4. وعليكم السلام انتبه من فضلك ان لا تقوم برفع أى مشاركة قبل محاولة البحث أولاً بالمنتدى عن طلبك -تفضل https://www.youtube.com/watch?v=LMx8rwUiYDQ
    1 point
  5. تفضل أخي الكريم تم تعديل الوظائف بالشروط الجديدة يمكنك تجربتها كما انه قد خطرت لي فكرة ستساعد بإذن الله في تسريع عمل الكود Public Function nssjWipeNumbers(ByVal fullText As String) As String Dim regex As Object Set regex = CreateObject("VBScript.RegExp") With regex .Global = True .MultiLine = True .IgnoreCase = False .Pattern = "(\d+\s*-\s*\()(\d+)(\))" End With nssjWipeNumbers = regex.Replace(fullText, "$1$3") If Not regex Is Nothing Then Set regex = Nothing End Function Public Function nssjWipeCondition(ByVal fullText As String) As String Dim regex As Object Set regex = CreateObject("VBScript.RegExp") With regex .Global = True .MultiLine = True .IgnoreCase = False .Pattern = "(\d+\s*-\s*\()([\d-/_,\\]+)(\))" End With nssjWipeCondition = regex.Replace(fullText, "$1$3") If Not regex Is Nothing Then Set regex = Nothing End Function Public Function nssjWipeAny(ByVal fullText As String) As String Dim regex As Object Set regex = CreateObject("VBScript.RegExp") With regex .Global = True .MultiLine = True .IgnoreCase = False .Pattern = "(\d+\s*-\s*\()([^)]*)(\))" End With nssjWipeAny = regex.Replace(fullText, "$1$3") If Not regex Is Nothing Then Set regex = Nothing End Function
    1 point
  6. الله يعطيك العافيه اخي ابو ابراهيم اتمنى الهدو وضبط الاعصاب وكلنا في قارب واحد وباذن الله الامور تتيسر وزي ماقال الاخ ابو متعب راح نعمل الجداول ونرفقها وفقكم الله
    1 point
  7. ابشر ابا ابراهيم نحن معكم وان شاءالله نزودكم بمثال فيه الجداول
    1 point
  8. نعم يا أبا متعب! ولكن نريدك أن تغبر يديك وتنقب معنا، لأنك من أصحاب المشاركة، ومعني بالدرجة الأولى..
    1 point
  9. الحمد لله والشكر لله بالتوفيق أخي الكريم هذه الدالة (wipeValueFormString) لا تعمل هكذا فهي بحاجه الي رقم بعينة حتي تبحث عن وتطابقه ثم تحذفه وبالتالي لن تعمل بشكل عام فتستخدم هكذا wipeValueFormString([nass],"25") ولكن قد قمت بفضل الله بعمل ثلاث دوال أخرى تطابق الشروط التالية تبحث عن - متبوعة بأي عدد من المسافات ثم ( وبعد ذلك يوجد محتوي كل دالة تتعامل مع المحتوي بشكل مختلف ثم ) مثال علي أحد الدوال وفرصة لعرض إمكانية Regex في التحقق من نمط بداخل نص وانا لم أتعمق كثيراً في استخدامتها ولكن أحتجتها قريباً وبدأت اقراء عنها وغالباً ما اعتمد فالبحث وأدوات الذكاء مؤخراً حتي أصل للنمط المناسب حتي وانا أبحث هذه المرة تعرفت علي معلومة جديد Public Function wipeNumbersInCondition(ByVal fullText As String) As String Dim regex As Object Set regex = CreateObject("VBScript.RegExp") With regex .Global = True .MultiLine = True .IgnoreCase = False .Pattern = "(-\s*\()(\d+)(\))" End With wipeNumbersInCondition = regex.Replace(fullText, "$1$3") If Not regex Is Nothing Then Set regex = Nothing End Function Public Function wipeAllInCondition(ByVal fullText As String) As String Dim regex As Object Set regex = CreateObject("VBScript.RegExp") With regex .Global = True .MultiLine = True .IgnoreCase = False .Pattern = "(-\s*\()([\d/-]+)(\))" End With wipeAllInCondition = regex.Replace(fullText, "$1$3") If Not regex Is Nothing Then Set regex = Nothing End Function Public Function wipeAnyInCondition(ByVal fullText As String) As String Dim regex As Object Set regex = CreateObject("VBScript.RegExp") With regex .Global = True .MultiLine = True .IgnoreCase = False .Pattern = "(-\s*\()([^)]*)(\))" End With wipeAnyInCondition = regex.Replace(fullText, "$1$3") If Not regex Is Nothing Then Set regex = Nothing End Function فالأكواد الثلاثة كلها تتبع نفس النمط وفق ما ذكرت سابق ولكن تختلف كل واحدة في تميز المحتوي 1- wipeNumbersInCondition تحذف المحتوي إذا كان ارقام فقط 2- wipeAllInCondition تحذف المحتوي إذا ارقام / ارقام 3- wipeAnyInCondition تحذف المحتوي مهما كان مثال إذا أردت التعديل علي النمط حتي لا يبحث عن عدد لا نهائي من المسافات بين الـ - والـ ( اريدة فقط ان يبحث عن مسافة واحدة او بدون مسافات كل ما علي فعله هو أستبدال \s* بـ \s? في النمط "(-\s*\()(\d+)(\))" حيث ان ؟ تعني بدون مسافة او مسافة واحد والمعلومة الجديدة التي تعلمتها هي هنا تتم عملية الاستبدال للنمط المطابق regex.Replace(fullText, "$1$3") ومن الممكن ان يتم الاستبدال هكذا regex.Replace(fullText, "-()") ولكن $1 يشير إلي أول جزء في النمط و $3 تشير الي الجزء الثالث في النمط وبتالي ستيم الاستبدال بالقبم الملتقطة فلن يتغير اي شي علي النص فقط المحتوي ما بين الـ () يمكنك استخدام أي واحدة من الدوال الثلاثة بالطريقة التي ذكرتها كما يمكنك أختيار واحدة منهم لأضعها فالكود المستخدم بدلاً من تحديد رقم بعينة إذا أردت ذلك ------------------- بالنسبة للكود الذي سيعمل بإذن الله علي اسم الكتاب الأخر كنت أفضل لو تشارك نموذج به مثال حتي أتمكن من معاينة النتيجة وأيضاً حتي يوافق الكود التكوين الخاص بك والاسماء اما إذا أردت ان أضيف عمود وأم انا بالتسمية و ،،، فسوف أعمل عليه إن شاء الله بانتظار إجابتك
    1 point
  10. اكيد هيكون افضل وخصوصا لو حبيتي تعملي اكتر من صب ريبورت زي مكنتي بتقولي او لو هتغيري مثلا اكتر من صب فورم أو هتعملي داله معينه بعد كده يعني تقوليلها في حاله تحليل CBC يظهر تقرير كذا أو فى حاله pcr يظهر كذا تحت امرك في اي وقت كلنا هنا بنحاول نساعد بعض ميهمكيش
    1 point
  11. هذا الخطأ يحدث لان الشاشة الرئيسية مغلقة افتح الشاشة الرئيسية ثم افتح الاستعلام وستختفي
    1 point
  12. بعد تعليمات استاذنا @ابوخليل تفضل أستاذ @ahmed draz طلبك حسب مافهمت بالشرح والمرفق . 1-1.rar
    1 point
  13. عليكم السلام الفكرة ممكن تنفيذها بكل اريحية فقط المطلوب الانتقال من المصدر الافترضي الى المصدر الجديد
    1 point
  14. تفضل استاذ @2saad طلبك مستخدماً موديول الاستاذ @AlwaZeeR . بالنموذج والاستعلام DDTestSumModule.rar
    1 point
  15. لنفترض أنك تريد نقل ملف Excel يحتوي على ارتباطات تشعبية (مراجع إلى خلايا في ملف آخر) إلى مكان آخر. في هذه الحالة، يجب أن تأخذ في الاعتبار اثنين من الأمور: نقل الملف Excel نفسه: يمكنك ببساطة نسخ الملف ولصقه في المكان الجديد. تحديث الارتباطات التشعبية: عند نقل الملف، قد يكون عناوين الخلايا المرتبطة قد تغيرت بسبب التحول إلى مسار جديد. لذا، يجب تحديث هذه الارتباطات التشعبية. هناك بعض الطرق لتحديث الارتباطات التشعبية في ملف Excel: طريقة 1: استخدام "تغيير مصدر الارتباط" افتح الملف الجديد الذي تم نقله. انتقل إلى علامة التبويب "بيانات" (Data) في شريط الأوامر. اختر "تغيير مصدر الارتباط" (Edit Links). ستظهر نافذة تعرض جميع الارتباطات التشعبية في الملف. اختر الارتباط الذي تريد تحديثه واختر "تغيير مصدر" (Change Source). حدد الملف الجديد الذي تم نقله واختر "موافق" (OK). طريقة 2: استخدام برمجة VBA يمكنك أيضًا استخدام VBA لتحديث الارتباطات التشعبية بشكل تلقائي. هذا مفيد إذا كنت ترغب في تنفيذ هذا الإجراء بشكل تلقائي عند فتح الملف. Sub UpdateLinks() Dim links As Variant Dim i As Integer ' Get all links in the workbook links = ThisWorkbook.LinkSources ' If there are links, update them If Not IsEmpty(links) Then For i = 1 To UBound(links) ThisWorkbook.ChangeLink links(i), "C:\New\Path\To\Linked\File.xlsx", xlLinkTypeExcelLinks Next i End If End Sub
    1 point
  16. السلام عليكم مفيش الزرار اللي حضرتك بتقول عليه فالمرفق ولا يوجد كود او ماكرو في المرفق اللي حضرتك باعته فىه نفس المواصفات دي
    1 point
  17. لست متاكدا من طلبك لاكنك ادا كنت تقصد اظهار اسماء اوراق العمل كما في الصورة المدرجة والتنقل بينها جرب هدا يمكنك تعديله بما يناسيك test.xlsm
    1 point
  18. وعليكم السلام ورحمة الله وبركاته تفضل لعله المطلوب نقل المبلغ.xlsx
    1 point
  19. وعليكم السلام ورحمة الله تعالى وبركاته Option Compare Text Dim depart, Cnt, comment, f, ColSearch(), J Public Property Get WS() As Worksheet: Set WS = ActiveSheet End Property Private Sub UserForm_Initialize() Dim arr() comment = " تحديد ورقة العمل" Me.Label1.Width = 900 depart = Me.Label1.Left Message = " برنامج المخازن يرحب بكم . صل على محمد" Me.Label1.Caption = "**********" & Message & "**********" & Message & "************" Cnt = Len(Me.Label1.Caption): Me.ComboBox1 = comment ColSearch = Array(3, 2, 1) J = UBound(ColSearch) + 1 For i = 1 To 3: Me("head" & i).Visible = False: Next i k = 1 For Each sh In ActiveWorkbook.Sheets If sh.Cells(3, 3) <> Empty Then ReDim Preserve arr(1 To k) arr(k) = sh.Name k = k + 1 End If Next sh Me.ComboBox1.List = arr Me.ComboBox1.ListIndex = 0 Count.Caption = ListBox1.ListCount Me.ComboBox1 = comment End Sub '*************************************** Private Sub Textbox1_Change() r = "*" & Me.Textbox1 & "*" Dim Cpt(): n = 0 For i = 1 To UBound(f) If f(i, 1) Like r Then ' فلترة بالاسم عمود (1) n = n + 1: ReDim Preserve Cpt(1 To J, 1 To n) c = 0 For Each k In ColSearch c = c + 1: Cpt(c, n) = f(i, k) Next k End If Next i If n > 0 Then Me.ListBox1.Column = Cpt Else Me.ListBox1.Clear Count.Caption = ListBox1.ListCount End Sub '******************************* Private Sub ComboBox1_Change() On Error Resume Next Sheets(CStr(ComboBox1)).Activate f = WS.Range("A3:C" & WS.[a65000].End(xlUp).Row).Value If Me.ComboBox1 <> comment And WS.Cells(3, 3) <> "" Then For i = 1 To 3: Me("Hard" & i).Visible = True: Next i Set d = CreateObject("Scripting.Dictionary") For i = LBound(f) To UBound(f) If f(i, 1) <> "" Then d(i) = Array(f(i, 3), f(i, 2), f(i, 1)) Next i n = d.Count If n > 0 Then Dim Cpt: Cpt = Application.Transpose(d.items) ReDim Preserve Cpt(1 To 3, 1 To n + 1) Me.ListBox1.List = Application.Transpose(Cpt) Me.ListBox1.RemoveItem n For i = 1 To 3: Me("Hard" & i) = WS.Cells(2, i): Next i Count.Caption = ListBox1.ListCount End If End If End Sub يوزر فورم3.xlsb
    1 point
  20. اولا لا تعمل على القاعدة الاساسية خذ نسخة منها واشتغل عليها . اضفنا حقل بالجدول الاساسي (EmpReay) (yes/no) ... لو ذهبنا للنموذج واخترتا استقالة بيعلم (true) . الاستعلام (QJubCase) به الشرطان (استقالة) و (true) الذي نعمل به استعلام الاضافة (QAppenToEmpCan). الاستعلام (DltFromEmpData) استعلام الحذف بعد الاضافة . وبه الشرطان (استقالة) و (true). لعمل حذف المختار فقط . أعني كذلك أنك ممكن ترحل فرد فرد أو ترحل لمجموعة . بالاختيار المناسب لك . يارب أكون وضحت لك ماتريد .
    1 point
  21. تفضل استاذ @sm44ms محاواتي حسب مافهمت .ووافني بالرد . DDTestRelay.rar
    1 point
  22. وعليكم السلام ورحمة الله تعالى وبركاته اظن ان المشكلة لديك من المعادلات المستخدمة لجلب البيانات ادا كنت تستخدم نسخة 2021 او ما فوق يمكنك حدف جميع الصيغ الموجودة على اوراق العمل والاكتفاء بوضع الصيغة التالية في اول خلية لديك على عمود C فقط مع مراعات الفواصل المنقوطة على حسب النسخة لديك =FILTER('All Customers'!$C$4:$G$1000;'All Customers'!$E$4:$E$1000=REPLACE(CELL("filename";$A$4);1;FIND("]";CELL("filename";$A$4));"")) 'OR =FILTER('All Customers'!$C$4:$G$1000,'All Customers'!$E$4:$E$1000=REPLACE(CELL("filename",$A$4),1,FIND("]",CELL("filename",$A$4)),"")) ترحيل البيانات حسب اسم الشيت الاصل.xlsx
    1 point
  23. ايت المرفق . نظريا اعمل استعلامين الاول استعلام ضافة لنسخ القيم نت حقول الجدول الاول الى الجدول الثانى بعذ ذلك اعمل استعلام حذف للبيانات من الجدول الاول طبعا لازم يكون فى شرط والا راح تتنسخ كل البيانات وتنحذف كل البيانات انتبه
    1 point
  24. السلام عليكم ورحمة الله السادة الاخوة والخبراء واجهتني مشكلة اثنا الطباعة وهي طباعة الصفحات الفارغة فهل من الممكن طباعة الصفحات التي تحتوي على بيانات فقط ؟ مع توضيح الكود حتى اتعلم. ومرفق ملف المطلوب طباعة شيت (مينى). مع العلم انه يوجد مشاركة تناولت هذا الموضوع لم أفهم منها شياءً. ولكم جزيل الشكر مينى.xlsx
    1 point
  25. انا اعمل على اصدار 2016 نواة 64 ، ويعمل بكفاءة 20240520_180203.zip
    1 point
  26. السلام عليكم ورحمة الله وبركاته ، أتشرف بتلبية دعوتكم للمشاركة أخي @سلمان الشهراني . واسمحوا لي بالبدء بأول تفاعل بعد معلمي الفاضل @ابوخليل ، وبانتظار أساتذتي للدعم وتصحيح مفاهيمي إن كانت خاطئة . بداية أعتقد وجوب وجود المكتبة Microsoft Script Runtime ، هذا الكود الذي خلصت به ولا أعلم إن كانت النتيجة صحيحة كما تريدون أم لا ، إلا أنني قمت بالتجربة على الموقعين في الفيديو وكانت النتيجة مرضية ومطابقة ( الموقع الأول ، الموقع الثاني ) . فيما يلي ، الكود الأول لتحويل النص إلى SHA256 Hex Function TextToBase64(ByVal text As String) As String Dim sha As Object Dim utf8Bytes() As Byte Dim hash() As Byte Dim i As Integer Dim hashHex As String Set sha = CreateObject("System.Security.Cryptography.SHA256Managed") utf8Bytes = StrConv(text, vbFromUnicode) hash = sha.ComputeHash_2(utf8Bytes) hashHex = "" For i = LBound(hash) To UBound(hash) hashHex = hashHex & Right("0" & Hex(hash(i)), 2) Next i TextToBase64 = Base64Encode(hashHex) Set sha = Nothing End Function Function Base64Encode(ByVal strData As String) As String Dim objXML As Object Set objXML = CreateObject("MSXML2.DOMDocument").createElement("b64") objXML.DataType = "bin.base64" objXML.nodeTypedValue = strData Base64Encode = objXML.text Set objXML = Nothing End Function والنتيجة يتكون في مربع النص ( الهدف الأول ) عن طريق زر الإستدعاء كما يلي :- Private Sub btnComputeHash_Click() If IsNull(Me.txtInput) Then MsgBox "يرجى إدخال قيمة ليتم تشفيرها", , "" Me.txtInput.SetFocus Exit Sub End If Dim myText As String myText = Me.txtInput Dim base64Hash As String base64Hash = TextToBase64(myText) Me.txtHashOutput = base64Hash End Sub ثم باستخدام هذا الكود وبعد عدة تجارب يتم تحويل الـ Hex إلى Base64 : Function HexToBase64(ByVal hexString As String) As String Dim bytes() As Byte Dim objXML As Object bytes = HexStringToBytes(hexString) Set objXML = CreateObject("MSXML2.DOMDocument").createElement("b64") objXML.DataType = "bin.base64" objXML.nodeTypedValue = bytes HexToBase64 = objXML.text Set objXML = Nothing End Function Function HexStringToBytes(ByVal hexString As String) As Byte() Dim bytes() As Byte Dim i As Integer ReDim bytes(Len(hexString) \ 2 - 1) For i = 1 To Len(hexString) Step 2 bytes((i + 1) \ 2 - 1) = Val("&H" & Mid(hexString, i, 2)) Next i HexStringToBytes = bytes End Function ويتم الاستدعاء في الزر كالآتي :- Private Sub Btn_Base64_Click() If IsNull(Me.txtHashOutput) Then MsgBox "لم يتم حساب قيمة Hex بعد.", , "" Exit Sub End If Dim base64Value As String base64Value = HexToBase64(Me.txtHashOutput) Me.Txt_Base64 = base64Value End Sub وفي النهاية أترك التجربة للحكم والتعديل . Hash Con.accdb
    1 point
  27. السلام عليكم 🙂 هناك الكثير من الميزات/الاوامر التي يعطينا برنامج الاكسس ، والتي يمكن ان نعمل لها بديل ، ولكن يكون هناك فرق في سرعة تنفيذ كودنا مقارنة مع الكود الاصل من الاكسس !! مثل القائمة المختصرة التي تظهر لنا بالنقر على زر الفأرة الايمن ، والتي بها يمكننا ان نستغني عن الكثير الاوامر ، مثل الفرز والتصفية بأنواعه ، ولكن وللأسف الشديد ، فأنا ارى ان 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 point
×
×
  • اضف...

Important Information