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

إضافة زر يتم من ادراج زر من أدوات التحكم عند تحديد اليوزر فورم بعد ذلك يتم كتابة الكود فيه طلبك بخصوص طباعة جميع الصفحات على ما يبدو توجد صفحة واحدة فقط في ورقة عمل طباعة فكيف يمكن طباعة جميع الصفحات. على العموم قمت بعمل زر يطلب منك تحديد صفحات الطباعة بيان حالة للتسويات 2.xlsm

يجب إضافة المرجع Microsoft Office 16.0 Object Library كما بالصور أدناه من قائمة Tools إختر References انزل إلى أن تصل للمرجع Microsoft Office 16.0 Object Library (القائمة مرتبة أبجديا وسيكون الوصول للمرجع سهل) قم بتحديده واتقر OK تحياتي

مثال الاخ @Foksh النموذج Eye1 رائع خصوصا بعد تعديل الأخت @hanan_ms حيث أصبحت حركة العين أكثر سلاسة عند تحريك الماوس أما النموذج الخاص بالأخت @hanan_ms الذي بإسم Eye2 كلما احرك الماوس عليه تظهر لي رسالة الخطأ الموضحة بالصورة فهل تظهر الرسالة عند البقية أم أنها مشكلة خاصة بي فقط تحياتي

سبقتني في الإستكمال ، وهي لك لأني كنت على وشك ارفاق الصورة التالية أيضاً أخي @Barna 😅

وعليكم السلام ورحمة الله وبركاته .. من جهة قد يكون الأمر صعباً . لكن من خلال خدمات Google Cloud Console ، وتوظيف الـ API بشكل جيد يمكن الحصول على النتيجة القريبة من الطلب الذي تريده . كنت قد توجهت الى استخدام خدمات Google API في عدة مشاريع، قد تجد منها متوفراً في توقيعي نهاية هذه المشاركة ..

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

ممكن يكون من إعدادت اللغة فتح: لوحة التحكم > المنطقة (Region) > الإدارة (Administrative) اضغط: تغيير الإعدادات المحلية للنظام (Change system locale...) اختر: العربية (Egypt) أو العربية (Saudi Arabia) حسب منطقتك. أعد تشغيل الجهاز.

بشارك محاوله لاستاذ @ابو جودي ❤️🌹☕ لعبت بكود @Foksh تحميل المرفق https://www.mediafire.com/file/ljc1tzl04v3dcch/Eye+Ms_hanan.rar/file

اشارة الى الموضوع وكذلك الموضوع التالى وبناء على طلب احد الاخوة الافاضل بعمل التعديل على قاعدة بيانات الخاصة بالمعلمين لطريقة برايل واشارة سريعة للطريقة للتعريف بالقاعدة وبالطريقة المعلم المبصر هو من سوف يستخدم هذا التطبيق فى التعليم وهو من سوف ينقر ازرار الحروف والمتلقون للعلم هم من سوف يستمع لحركة كل حرف ترجمة الحرف هذه هى طريقة برايل تعتمد الطريقة على ان كل الحروف تتكون من خلية من ست نقاط وعدد النقاط بترتيب معين داخل الخلية يدل على كل حرف وهذا شكل الخلية وتتم قراءة النقاط البارزة/المحفورة من خلال معرفة رقم موضعها طبقا للخلية الاتية من خلال التحسس باللمس من إخواننا الغير مبصرين وجدول برايل اجمالا يعنى عندما يتحسس غير المبصر ويجد النقطة البارزة/المحفورة طبقا للترتيب فى الخلية الاتية رقم 1 اى ان هذا حرف الاف وهندما يتحثث النقاط البارزة/المحفورة ويجدها حسب موضعها 2 ، 3 ، 4 ، 5 فهذا حرف التاء كان الملطلوب منى تعديل النموذج ليمثل محاكاة حقيقية لشكل الخلية ومواضع الحروف عليها عند النقر على كل حرف وبحمد الله وبفضله تم عمل ذلك وهذه صورة من داخل النموذج Braille V.3.zip

وانا داخل ادور ورا @Moosak , @Foksh لا تعليق .... eye.accdb

في معظم نسخ ويندوز الحديثة وخاصة 64 بت + الوفيس باللغة العربية نعم vbMsgBoxRtlReading غالبا يفرض تلقائيا المحاذاة لليمين بشكل تلقائي لكن في بعض النسخ (خاصة الإنجليزية 32 بت أو البيئات غير المهيأة للعربية) قد لا يفرض تلقائيا المحاذاة لليمين بشكل تلقائي بل يظهر النص محاذى لليسار رغم أن اتجاهه RTL تمام يا برنس الجيل خليك انت ماشى ورا شات جى بى تى بتاعك ده وربنا دا غبى وفى الاحر انت هتزعل وتجيب ناس معاك تزعل بسببه ---------------------------- انا مش مقدم شرح لكود ولو جزئية من فكرة أنا قدمت قاعدة متكاملة تعمل كما هى ... فمشمشطلتى بقه انك عاوز تلعب ولكن حاضر قلت لك هبهرك ---------------------------- والله انا ماليش دعوة بنظام الصوت ولا انا اللى مسجله هو جالى كده من اول مشاركة اشارت ليها مش عاجبك نظام الصوت يا عسل ؟ اشترى لك مايك وسجل بنفسك وبصوتك وعلى هواك اعمل النظام اللى يعجبك أو روح لاخوك @Moosak يسجل لك بصوتة الكروان ---------------------------- فى أول اصدار صممته كنت اعتمد عليه بس فى التحديث الاخير ولا له لازمة بس انا نسيت ازالة التاجات من الازرار زهايمر بئه بعيد عنك انتظر وسترى العجب العجاب

ما هوا نا مكتش عامل أزرار أخرى اساسا بس من عيونى الاتنين يا عمو فؤش والله لأبهرك .... انتظر

مشاركة مع الأستاذ @Barna ، من خلال استعلام التحديث التالي :- UPDATE data_dor2 SET N_Arb = IIF(Val(Nz([Dor_Arb], 0)) = -1, -1, IIF(IsNumeric([Dor_Arb]), IIF(Val(Nz([Dor_Arb], 0)) >= 50, Val([Dor_Arb]), IIF(IsNull([TDor_Arb]) OR Val(Nz([TDor_Arb], -1)) = -1, 0, IIF(Val([TDor_Arb]) >= 50, 50, Val([TDor_Arb])) ) ), 0) ), N_Math = IIF(Val(Nz([Dor_Math], 0)) = -1, -1, IIF(IsNumeric([Dor_Math]), IIF(Val(Nz([Dor_Math], 0)) >= 50, Val([Dor_Math]), IIF(IsNull([TDor_Math]) OR Val(Nz([TDor_Math], -1)) = -1, 0, IIF(Val([TDor_Math]) >= 50, 50, Val([TDor_Math])) ) ), 0) ), N_Drast = IIF(Val(Nz([Dor_Drast], 0)) = -1, -1, IIF(IsNumeric([Dor_Drast]), IIF(Val(Nz([Dor_Drast], 0)) >= 50, Val([Dor_Drast]), IIF(IsNull([TDor_Drast]) OR Val(Nz([TDor_Drast], -1)) = -1, 0, IIF(Val([TDor_Drast]) >= 50, 50, Val([TDor_Drast])) ) ), 0) ), N_Since = IIF(Val(Nz([Dor_Since], 0)) = -1, -1, IIF(IsNumeric([Dor_Since]), IIF(Val(Nz([Dor_Since], 0)) >= 50, Val([Dor_Since]), IIF(IsNull([TDor_Since]) OR Val(Nz([TDor_Since], -1)) = -1, 0, IIF(Val([TDor_Since]) >= 50, 50, Val([TDor_Since])) ) ), 0) ), N_Eng = IIF(Val(Nz([Dor_Eng], 0)) = -1, -1, IIF(IsNumeric([Dor_Eng]), IIF(Val(Nz([Dor_Eng], 0)) >= 50, Val([Dor_Eng]), IIF(IsNull([TDor_Eng]) OR Val(Nz([TDor_Eng], -1)) = -1, 0, IIF(Val([TDor_Eng]) >= 50, 50, Val([TDor_Eng])) ) ), 0) ), N_Comp = IIF(Val(Nz([Dor_comp], 0)) = -1, -1, IIF(IsNumeric([Dor_comp]), IIF(Val(Nz([Dor_comp], 0)) >= 50, Val([Dor_comp]), IIF(IsNull([TDor_Comp]) OR Val(Nz([TDor_Comp], -1)) = -1, 0, IIF(Val([TDor_Comp]) >= 50, 50, Val([TDor_Comp])) ) ), 0) ), N_Skills = IIF(Val(Nz([Dor_skills], 0)) = -1, -1, IIF(IsNumeric([Dor_skills]), IIF(Val(Nz([Dor_skills], 0)) >= 50, Val([Dor_skills]), IIF(IsNull([TDor_Skills]) OR Val(Nz([TDor_Skills], -1)) = -1, 0, IIF(Val([TDor_Skills]) >= 50, 50, Val([TDor_Skills])) ) ), 0) ), N_Den = IIF(Val(Nz([Dor_Den], 0)) = -1, -1, IIF(IsNumeric([Dor_Den]), IIF(Val(Nz([Dor_Den], 0)) >= 50, Val([Dor_Den]), IIF(IsNull([TDor_Den]) OR Val(Nz([TDor_Den], -1)) = -1, 0, IIF(Val([TDor_Den]) >= 50, 50, Val([TDor_Den])) ) ), 0) ) WHERE name_student <> "IsNull";

يا أهلا وسهلا بالأفكار الجميلة وصاحبها .. جميل جداً جداً لي تعليق على :- لا حاجة لاستخدام vbMsgBoxRtlReading مع vbMsgBoxRight . فهذا يكفي لجعل اتجاه النص RTL ( حتى بدون vbMsgBoxRight، لأن vbMsgBoxRtlReading يتضمن عادةً محاذاة لليمين تلقائية ) . لاحظت انه في حال تم استخدام أزرار أخرى في النموذج ذات علاقة مختلفة مثل اغلاق النموذج من خلال الحدث Docmd.Close وكانت التسمية للزر الجديد = "إغلاق" فإن الدالة ستحاول قراءة التسمية للزر على أنها أحد الحروف ، مما ينتج رسالة الخطأ :- ثم ثم وفي النهاية لن يتم اغلاق النموذج نظام الصوت في بعض الحروف قد يكون غير واضح مثل الحرف ـا "الألف المد" ... ما وظيفة الـ Tag للأزرار الخاصة بالأحرف ؟؟؟؟؟

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

وعليكم السلام ورحمة الله وبركاته .. مشكلتك اذا ما خاب ظني ، هي في عدم اضافة المكتبة الموضحة في الصورة التالية :- طبعاً مع اختلاف الرقم 16.0 حسب الإصدار لديك . وإن شاء الله تشتغل معك .

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

بمناسبة موضوع الارتعاش والاهتزاز اللى @hanan_ms دائم الكلام عنه كل شويه اللى بيعتمد على خاصية Double Buffering أو Buffering لتقليل الوميض باستخدام WS_EX_COMPOSITED غير فعال وبيعفرت التطبيق هذا للتنويه فقط من الاخـــــــــر اكسس ليس مصمم ليكون بيئة رسوميات عالية الأداء نماذج اكسس ليست مهيأة لتحديثات واجهة المستخدم السريعة مثل Windows Forms لذلك سوف تبقى هذه مشكلة أزلية الوميض (Flickering) والارتعاش (Shaking or Jittering) والاكسس اصدقاء لن يتخلى احدهم عن الاخر

نسيت ارفاق الملف cont.zip

استخدم هذه الشيفرة في زر التحديث مع اللاحقة له ...... Private Sub أمر309_Click() Dim rst As DAO.Recordset Dim db As DAO.Database Dim ctl As Control Dim controlsList As New Collection Dim dorAwalField As String, dorThanField As String, finalField As String Dim dorAwalVal As Variant, dorThanVal As Variant, finalVal As Variant Dim i As Integer Dim excludedNames As Variant Set db = CurrentDb() Set rst = Me.RecordsetClone ' نسخة من مصدر بيانات النموذج ' أسماء الحقول التي نريد استثناؤها (اسم الطالب، رقم الجلوس) excludedNames = Array("name_student", "num_Glos") ' جمع الحقول الثلاثية فقط حسب الترتيب For Each ctl In Me.Controls If ctl.ControlType = acTextBox Then If IsExcluded(ctl.Name, excludedNames) = False Then If ctl.ControlSource <> "" Then ' مرتبط بحقل فعلي controlsList.Add ctl.ControlSource End If End If End If Next ctl ' المرور على كل سجل في النموذج If Not rst.EOF Then rst.MoveFirst Do While Not rst.EOF rst.Edit For i = 1 To controlsList.Count Step 3 If i + 2 <= controlsList.Count Then dorAwalField = controlsList(i) dorThanField = controlsList(i + 1) finalField = controlsList(i + 2) dorAwalVal = Nz(rst(dorAwalField), 0) dorThanVal = Nz(rst(dorThanField), -1) If dorThanVal <> -1 Then If dorThanVal >= 50 Then finalVal = 50 Else finalVal = dorThanVal End If Else finalVal = dorAwalVal End If rst(finalField) = finalVal End If Next i rst.Update rst.MoveNext Loop rst.Close Set rst = Nothing Set db = Nothing Me.Requery ' لتحديث العرض في النموذج MsgBox "تم تحديث جميع الدرجات النهائية بنجاح.", vbInformation End Sub Private Function IsExcluded(fieldName As String, excludedList As Variant) As Boolean Dim item As Variant For Each item In excludedList If LCase(fieldName) = LCase(item) Then IsExcluded = True Exit Function End If Next item IsExcluded = False End Function وهذا ملفك بعد التعديل ............... cont.accdb

هذا الاستعلام الذي خرجت به كما في الصورة السابقة نتيجته :- SELECT name_student, National_ID, CLASS_CLASS, num_Glos, n_lgna_dor2, sery_dor2, Dor_Arb, Dor_Math, Dor_Drast, Dor_Since, Dor_Eng, Dor_comp, Dor_skills, Dor_Den, TDor_Arb, TDor_Math, TDor_Drast, TDor_Since, TDor_Eng, TDor_Comp, TDor_Skills, TDor_Den, IIF(IsNumeric([Dor_Arb]), IIF(Val(Nz([Dor_Arb],0))>=50, Val([Dor_Arb]), IIF(IsNull([TDor_Arb]) OR Val(Nz([TDor_Arb],-1))=-1, 0, IIF(Val([TDor_Arb])>=50, 50, Val([TDor_Arb])) ) ), 0) AS N_Arb, IIF(IsNumeric([Dor_Math]), IIF(Val(Nz([Dor_Math],0))>=50, Val([Dor_Math]), IIF(IsNull([TDor_Math]) OR Val(Nz([TDor_Math],-1))=-1, 0, IIF(Val([TDor_Math])>=50, 50, Val([TDor_Math])) ) ), 0) AS N_Math, IIF(IsNumeric([Dor_Drast]), IIF(Val(Nz([Dor_Drast],0))>=50, Val([Dor_Drast]), IIF(IsNull([TDor_Drast]) OR Val(Nz([TDor_Drast],-1))=-1, 0, IIF(Val([TDor_Drast])>=50, 50, Val([TDor_Drast])) ) ), 0) AS N_Drast, IIF(IsNumeric([Dor_Since]), IIF(Val(Nz([Dor_Since],0))>=50, Val([Dor_Since]), IIF(IsNull([TDor_Since]) OR Val(Nz([TDor_Since],-1))=-1, 0, IIF(Val([TDor_Since])>=50, 50, Val([TDor_Since])) ) ), 0) AS N_Since, IIF(IsNumeric([Dor_Eng]), IIF(Val(Nz([Dor_Eng],0))>=50, Val([Dor_Eng]), IIF(IsNull([TDor_Eng]) OR Val(Nz([TDor_Eng],-1))=-1, 0, IIF(Val([TDor_Eng])>=50, 50, Val([TDor_Eng])) ) ), 0) AS N_Eng, IIF(IsNumeric([Dor_comp]), IIF(Val(Nz([Dor_comp],0))>=50, Val([Dor_comp]), IIF(IsNull([TDor_Comp]) OR Val(Nz([TDor_Comp],-1))=-1, 0, IIF(Val([TDor_Comp])>=50, 50, Val([TDor_Comp])) ) ), 0) AS N_Comp, IIF(IsNumeric([Dor_skills]), IIF(Val(Nz([Dor_skills],0))>=50, Val([Dor_skills]), IIF(IsNull([TDor_Skills]) OR Val(Nz([TDor_Skills],-1))=-1, 0, IIF(Val([TDor_Skills])>=50, 50, Val([TDor_Skills])) ) ), 0) AS N_Skills, IIF(IsNumeric([Dor_Den]), IIF(Val(Nz([Dor_Den],0))>=50, Val([Dor_Den]), IIF(IsNull([TDor_Den]) OR Val(Nz([TDor_Den],-1))=-1, 0, IIF(Val([TDor_Den])>=50, 50, Val([TDor_Den])) ) ), 0) AS N_Den FROM data_dor2 WHERE (((data_dor2.[name_student])<>"IsNull"));

هو المطلوب بالضبط

هل الصورة الموجودة في النموذج بعد التحديث هو المطلوب

وعليكم السلام ورحمة الله وبركاته .. بدايةً وقبل الخوض في التجارب أكثر . جرب هذا الاستعلام الجزئي ، هل يفي بالغرض ؟ SELECT data_dor2.name_student, data_dor2.National_ID, data_dor2.CLASS_CLASS, data_dor2.num_Glos, data_dor2.n_lgna_dor2, data_dor2.sery_dor2, data_dor2.Dor_Arb, data_dor2.Dor_Math, data_dor2.Dor_Drast, data_dor2.Dor_Since, data_dor2.Dor_Eng, data_dor2.Dor_comp, data_dor2.Dor_skills, data_dor2.Dor_Den, data_dor2.TDor_Arb, data_dor2.TDor_Math, data_dor2.TDor_Drast, data_dor2.TDor_Since, data_dor2.TDor_Eng, data_dor2.TDor_Comp, data_dor2.TDor_Skills, data_dor2.TDor_Den, data_dor2.N_Arb, data_dor2.N_Math, data_dor2.N_Drast, data_dor2.N_Since, data_dor2.N_Eng, data_dor2.N_Comp, data_dor2.N_Skills, data_dor2.N_Den, IIf(data_dor2.N_Arb=0, IIf(data_dor2.TDor_Arb>=50, data_dor2.TDor_Arb, data_dor2.TDor_Arb), IIf(data_dor2.TDor_Arb<50, data_dor2.TDor_Arb, 50)) AS Final_Arb, IIf(data_dor2.N_Math=0, IIf(data_dor2.TDor_Math>=50, data_dor2.TDor_Math, data_dor2.TDor_Math), IIf(data_dor2.TDor_Math<50, data_dor2.TDor_Math, 50)) AS Final_Math, IIf(data_dor2.N_Drast=0, IIf(data_dor2.TDor_Drast>=50, data_dor2.TDor_Drast, data_dor2.TDor_Drast), IIf(data_dor2.TDor_Drast<50, data_dor2.TDor_Drast, 50)) AS Final_Drast, IIf(data_dor2.N_Since=0, IIf(data_dor2.TDor_Since>=50, data_dor2.TDor_Since, data_dor2.TDor_Since), IIf(data_dor2.TDor_Since<50, data_dor2.TDor_Since, 50)) AS Final_Since, IIf(data_dor2.N_Eng=0, IIf(data_dor2.TDor_Eng>=50, data_dor2.TDor_Eng, data_dor2.TDor_Eng), IIf(data_dor2.TDor_Eng<50, data_dor2.TDor_Eng, 50)) AS Final_Eng, IIf(data_dor2.N_Comp=0, IIf(data_dor2.TDor_Comp>=50, data_dor2.TDor_Comp, data_dor2.TDor_Comp), IIf(data_dor2.TDor_Comp<50, data_dor2.TDor_Comp, 50)) AS Final_Comp, IIf(data_dor2.N_Skills=0, IIf(data_dor2.TDor_Skills>=50, data_dor2.TDor_Skills, data_dor2.TDor_Skills), IIf(data_dor2.TDor_Skills<50, data_dor2.TDor_Skills, 50)) AS Final_Skills, IIf(data_dor2.N_Den=0, IIf(data_dor2.TDor_Den>=50, data_dor2.TDor_Den, data_dor2.TDor_Den), IIf(data_dor2.TDor_Den<50, data_dor2.TDor_Den, 50)) AS Final_Den FROM data_dor2 WHERE data_dor2.name_student Is Not Null; وبناءً عليه نستكمل باقي المطلوب ..

لما تكون زهقان ، شوف صاحبك بيعمل ايه Eye Foksh.accdb

أتفرج يا عم ع الزيادة دي : 😂 eye (Moosa).accdb

دالة InStr من أهم وأقوى الدوال المستخدمة في التعامل مع السلاسل النصية تستخدم لتحديد موضع أول ظهور لسلسلة فرعية داخل سلسلة نصية أخرى يمكن الاعتماد عليها في التحقق من وجود رموز أو مقاطع نصية داخل محتوى مثل: التحقق من وجود امتداد ملف البحث عن كلمة في اسم ملف فحص تنسيقات أو كجزء من معالجة متقدمة للنصوص الشكل العام: InStr(Start, String1, String2 , Compare) شرح المعاملات: Start (اختياري): >>---> رقم الموضع الذي تبدأ منه عملية البحث في String1 (يبدأ من 1) String1: >>---> السلسلة الأساسية التي يتم البحث بداخلها String2: >>---> السلسلة الفرعية المطلوب العثور عليها Compare (اختياري): >>---> نوع المقارنة يمكن استخدام: vbBinaryCompare (افتراضي): مقارنة حساسة لحالة الأحرف vbTextCompare : مقارنة تتجاهل حالة الأحرف الناتج: ترجع الدالة رقم موضع أول تطابق (Starting from 1) أو 0 إذا لم يتم العثور على أي تطابق أمثلة توضيحية شاملة 1- اختبار حالات مختلفة للدالة InStr Dim strText As String Dim strSearch As String Dim intStart As Integer Dim intResult As Integer ' البحث عن أول ظهور للحرف "a" strText = "Mohesam" strSearch = "a" intStart = 1 intResult = InStr(intStart, strText, strSearch) 'M o h e s a m '1 2 3 4 5 6 7 Debug.Print "الحالة 1: InStr(" & intStart & ", """ & strText & """, """ & strSearch & """) = " & intResult ' البحث من موقع مختلف intStart = 4 intResult = InStr(intStart, strText, strSearch) Debug.Print "الحالة 2: InStr(" & intStart & ", """ & strText & """, """ & strSearch & """) = " & intResult ' البحث عن حرف غير موجود strSearch = "z" intStart = 1 intResult = InStr(intStart, strText, strSearch) Debug.Print "الحالة 3: InStr(" & intStart & ", """ & strText & """, """ & strSearch & """) = " & intResult ' البحث في نص فارغ strText = "" strSearch = "a" intResult = InStr(1, strText, strSearch) Debug.Print "الحالة 4: InStr(1, """ & strText & """, """ & strSearch & """) = " & intResult ' البحث عن كلمة داخل جملة strText = "Access VBA" strSearch = "VBA" intResult = InStr(1, strText, strSearch) Debug.Print "الحالة 5: InStr(1, """ & strText & """, """ & strSearch & """) = " & intResult ' البحث المتكرر لنفس الكلمة strText = "abcabcabc" strSearch = "abc" intResult = InStr(1, strText, strSearch) Debug.Print "الحالة 6: InStr(1, """ & strText & """, """ & strSearch & """) = " & intResult ' البحث من منتصف السلسلة intResult = InStr(5, strText, strSearch) Debug.Print "الحالة 7: InStr(5, """ & strText & """, """ & strSearch & """) = " & intResult ' البحث مع اختلاف حالة الأحرف strText = "TestCase" strSearch = "case" intResult = InStr(1, strText, strSearch) Debug.Print "الحالة 8: InStr(1, """ & strText & """, """ & strSearch & """) = " & intResult & " (Compare = Binary افتراضي)" ' استخدام vbTextCompare لتجاهل حالة الأحرف intResult = InStr(1, strText, strSearch, vbTextCompare) Debug.Print "الحالة 9: InStr(1, """ & strText & """, """ & strSearch & """, vbTextCompare) = " & intResult Public Sub TestInStrFunction() Dim strText As String Dim strSearch As String Dim intStart As Integer Dim intResult As Integer Debug.Print String(70, "=") Debug.Print "اختبار دالة InStr" Debug.Print String(70, "=") ' الحالة 1: البحث عن حرف موجود من البداية strText = "Mohesam" strSearch = "a" intStart = 1 intResult = InStr(intStart, strText, strSearch) Debug.Print "الحالة 1: InStr(" & intStart & ", """ & strText & """, """ & strSearch & """) = " & intResult ' الحالة 2: البحث بعد الموضع الابتدائي intStart = 4 intResult = InStr(intStart, strText, strSearch) Debug.Print "الحالة 2: InStr(" & intStart & ", """ & strText & """, """ & strSearch & """) = " & intResult ' الحالة 3: البحث عن حرف غير موجود strSearch = "z" intStart = 1 intResult = InStr(intStart, strText, strSearch) Debug.Print "الحالة 3: InStr(" & intStart & ", """ & strText & """, """ & strSearch & """) = " & intResult ' الحالة 4: سلسلة فارغة strText = "" strSearch = "a" intResult = InStr(1, strText, strSearch) Debug.Print "الحالة 4: InStr(1, """ & strText & """, """ & strSearch & """) = " & intResult ' الحالة 5: البحث عن كلمة كاملة strText = "Access VBA" strSearch = "VBA" intResult = InStr(1, strText, strSearch) Debug.Print "الحالة 5: InStr(1, """ & strText & """, """ & strSearch & """) = " & intResult ' الحالة 6: البحث عن نفس الكلمة مكررة strText = "abcabcabc" strSearch = "abc" intResult = InStr(1, strText, strSearch) Debug.Print "الحالة 6: InStr(1, """ & strText & """, """ & strSearch & """) = " & intResult ' الحالة 7: بدء البحث من منتصف النص intResult = InStr(5, strText, strSearch) Debug.Print "الحالة 7: InStr(5, """ & strText & """, """ & strSearch & """) = " & intResult ' الحالة 8: حساس لحالة الأحرف strText = "TestCase" strSearch = "case" intResult = InStr(1, strText, strSearch) Debug.Print "الحالة 8: InStr(1, """ & strText & """, """ & strSearch & """) = " & intResult & " (Compare = Binary افتراضي)" ' الحالة 9: تجاهل حالة الأحرف باستخدام vbTextCompare intResult = InStr(1, strText, strSearch, vbTextCompare) Debug.Print "الحالة 9: InStr(1, """ & strText & """, """ & strSearch & """, vbTextCompare) = " & intResult End Sub 2- ملخص سريع مباشر للحالات Public Sub TestInStrCases() Debug.Print "==================================================" Debug.Print "اختبار دالة InStr" Debug.Print "==================================================" Debug.Print "الحالة 1: InStr(1, ""Mohesam"", ""a"") = "; InStr(1, "Mohesam", "a") Debug.Print "الحالة 2: InStr(4, ""Mohesam"", ""a"") = "; InStr(4, "Mohesam", "a") Debug.Print "الحالة 3: InStr(1, ""Mohesam"", ""z"") = "; InStr(1, "Mohesam", "z") Debug.Print "الحالة 4: InStr(1, """", ""a"") = "; InStr(1, "", "a") Debug.Print "الحالة 5: InStr(1, ""Access VBA"", ""VBA"") = "; InStr(1, "Access VBA", "VBA") Debug.Print "الحالة 6: InStr(1, ""abcabcabc"", ""abc"") = "; InStr(1, "abcabcabc", "abc") Debug.Print "الحالة 7: InStr(5, ""abcabcabc"", ""abc"") = "; InStr(5, "abcabcabc", "abc") Debug.Print "الحالة 8: InStr(1, ""TestCase"", ""case"") = "; InStr(1, "TestCase", "case") Debug.Print "الحالة 9: InStr(1, ""TestCase"", ""case"", vbTextCompare) = "; InStr(1, "TestCase", "case", vbTextCompare) Debug.Print "==================================================" End Sub استخدام احترافي البحث عن رموز داخل نص دالة InStr يمكن توظيفها داخل دوال أكثر تقدما للبحث عن مجموعة من الرموز داخل نص معين Public Function GetSymbolsInText(ByVal strText As String, ByVal arrSymbols As Variant, ByRef arrFound() As String) As Boolean Dim varSymbol As Variant Dim colFound As Collection Set colFound = New Collection ' البحث عن كل رمز في النص For Each varSymbol In arrSymbols If InStr(strText, varSymbol) > 0 Then On Error Resume Next ' لتجنب تكرار العناصر في المجموعة colFound.Add varSymbol, CStr(varSymbol) On Error GoTo 0 End If Next ' تجهيز النتائج النهائية If colFound.Count > 0 Then ReDim arrFound(0 To colFound.Count - 1) Dim i As Long For i = 1 To colFound.Count arrFound(i - 1) = colFound(i) Next i GetSymbolsInText = True Else ReDim arrFound(-1 To -1) GetSymbolsInText = False End If End Function تجربة هذه الدالة Public Sub TestGetSymbolsInText() Dim arrSymbols As Variant Dim arrFound() As String Dim bolFound As Boolean Dim strTest As String arrSymbols = Array(",", ";", "|", "/", "\", "-", "_") strTest = "Mohesam-2025/Report_Aug" ' تنفيذ البحث bolFound = GetSymbolsInText(strTest, arrSymbols, arrFound) ' عرض النتائج If bolFound Then Debug.Print "تم العثور على الرموز التالية:" Dim i As Long For i = LBound(arrFound) To UBound(arrFound) Debug.Print arrFound(i) Next i Else Debug.Print "لا يوجد أي رمز" End If End Sub Sub TestTextCompareBehavior() Dim str1 As String Dim str2 As String str1 = "Access" str2 = "access" ' المقارنة الثنائية (تراعي حالة الأحرف) ' - لن تنجح Debug.Print "BinaryCompare: "; InStr(1, str1, str2, vbBinaryCompare) ' المقارنة النصية (تتجاهل حالة الأحرف) ' - ستنجح Debug.Print "TextCompare: "; InStr(1, str1, str2, vbTextCompare) End Sub الكود السابق يوضح الفرق بين نمطي المقارنة في دالة InStr vbBinaryCompare: يقارن مع مراعاة حالة الأحرف (case-sensitive) vbTextCompare: يقارن بدون مراعاة حالة الأحرف (case-insensitive) النتيجة 0 في المقارنة الثنائية تعني أن "access" لم يتم العثور عليها داخل "Access" بسبب اختلاف حالة الحروف أما في TextCompare فتم العثور على "access" في بداية "Access" لأن الحالة تم تجاهلها المعامل الرابع في InStr InStr(Start, String1, String2 , Compare) إذا لم يتم تحديد CompareMethod فإن Access يستخدم الإعداد الافتراضي (غالبا vbBinaryCompare) لذلك ينصح دائما بتحديد نوع المقارنة صراحة لتفادي النتائج غير المتوقعة خاصة عند تجاهل حالة الأحرف الخلاصــــــــــة InStr تعيد موضع أول ظهور لسلسلة داخل سلسلة أخرى (يبدأ من 1) تعيد 0 إذا لم يتم العثور على تطابق يمكن تخصيص نوع المقارنة باستخدام المعامل الرابع مفيدة لبناء دوال متقدمة لمعالجة النصوص والرموز لتجاهل حالة الأحرف استخدم vbTextCompare لا تعتمد على القيمة الافتراضية في Compare حددها دائما لتفادي النتائج غير المتوقعة هناك دالة مكملة لـ InStr تسمى InStrRev تقوم بالبحث من نهاية النص إلى بدايته قد تكون مفيدة جدا في بعض الحالات (مثل البحث عن آخر امتداد أو آخر فاصل) InStr(1, "file.name.txt", ".") ' 5 InStrRev("file.name.txt", ".") ' 10 بكده الشرح انتهى ولتحقيق اكبر قدر ممكن من الاستفادة وفيما يخص النقطة التالية: مفيدة لبناء دوال متقدمة لمعالجة النصوص والرموز دى فكرة كود داخل وحدة نمطية عامة فى الاعتماد على كل من InStr , InStrRev اتركها لكم للاستمتاع بها Option Compare Database Option Explicit Public Enum TextCase AsIs = 0 ' كما هو Lower = 1 ' أحرف صغيرة Upper = 2 ' أحرف كبيرة Proper = 3 ' أول حرف كبير End Enum ' تعريفات الأنواع Public Enum FilePartType FileNameWithExtension ' اسم الملف مع الامتداد FileNameOnly ' اسم الملف بدون الامتداد FileExtensionOnly ' الامتداد بدون النقطة FileExtensionWithDot ' الامتداد مع النقطة FullFolderPath ' المسار الكامل للمجلد ContainingFolderName ' اسم المجلد الحاوي فقط RootDrive ' الجذر (مثل C:\ أو اسم السيرفر) VersionOnly ' الإصدار فقط (مثل v1.2) DateOnly ' التاريخ فقط (مثل 2025-07-17) FullUNCPath ' المسار الكامل بصيغة UNC FileURL ' المسار بصيغة URL FileNameWithoutVersionOrDate ' اسم الملف بدون الإصدار أو التاريخ ServerAndShare ' السيرفر والمشاركة من مسار UNC End Enum ' كائنات على مستوى الوحدة لتحسين الأداء Private objFSO As Object Private objRegEx As Object ' الدالة الرئيسية لاستخراج أجزاء المسار Public Function ExtractFilePartPro( _ ByVal strPath As String, _ Optional ByVal enmPart As FilePartType = FileNameWithExtension, _ Optional ByVal enuTextCase As TextCase = AsIs, _ Optional ByRef strVersion As String = "", _ Optional ByRef strDate As String = "", _ Optional ByRef strError As String = "" _ ) As String Dim strResult As String Dim lngPos As Long Dim strFileName As String Dim strFolder As String Dim strExt As String Dim strParent As String Dim colMatches As Object Dim vMatch As Variant ' تهيئة رسالة الخطأ إلى فارغة strError = "" ' إنشاء الكائنات إذا لم تكن موجودة If objFSO Is Nothing Then Set objFSO = CreateObject("Scripting.FileSystemObject") If objRegEx Is Nothing Then Set objRegEx = CreateObject("VBScript.RegExp") With objRegEx .Global = True .IgnoreCase = True ' نمط محسن لدعم إصدارات مع أحرف وتواريخ بصيغ مختلفة .Pattern = "(v[\d\.]+[a-zA-Z-]*)|((?:19|20)\d{2}[-_/]?\d{2}[-_/]?\d{2}|\d{8})" End With End If On Error GoTo ErrHandler ' تنظيف المسار strPath = Trim(strPath) ' التحقق من المسار الفارغ If strPath = "" Then strError = "المسار فارغ" ExtractFilePartPro = "" Exit Function End If ' استخراج اسم الملف If objFSO.FileExists(strPath) Or InStrRev(strPath, "\") > 0 Then strFileName = Mid(strPath, InStrRev(strPath, "\") + 1) Else strFileName = strPath End If ' استخراج المسار الكامل للمجلد strFolder = Left(strPath, Len(strPath) - Len(strFileName)) ' استخراج الامتداد (يدعم الامتدادات المركبة مثل .tar.gz) If InStr(strFileName, ".") > 0 Then lngPos = InStrRev(strFileName, ".") strExt = Mid(strFileName, lngPos) If LCase(strExt) = ".gz" And InStrRev(strFileName, ".tar.gz") > 0 Then strExt = ".tar.gz" End If Else strExt = "" End If ' استخراج اسم المجلد الحاوي If Right(strFolder, 1) = "\" Then strFolder = Left(strFolder, Len(strFolder) - 1) If InStrRev(strFolder, "\") > 0 Then strParent = Mid(strFolder, InStrRev(strFolder, "\") + 1) Else strParent = "" End If ' استخراج الإصدار والتاريخ باستخدام RegExp If objRegEx.Test(strFileName) Then Set colMatches = objRegEx.Execute(strFileName) For Each vMatch In colMatches If Left(LCase(vMatch), 1) = "v" Then strVersion = vMatch Else strDate = vMatch End If Next End If ' اختيار الجزء المطلوب Select Case enmPart Case FileNameWithExtension strResult = strFileName Case FileNameOnly If strExt <> "" Then strResult = Left(strFileName, Len(strFileName) - Len(strExt)) Else strResult = strFileName End If Case FileExtensionOnly If strExt <> "" Then strResult = Mid(strExt, 2) Case FileExtensionWithDot strResult = strExt Case FullFolderPath strResult = strFolder Case ContainingFolderName strResult = strParent Case RootDrive If Left(strPath, 2) = "\\" Then strResult = Split(strPath, "\")(2) ' اسم السيرفر فقط Else strResult = Left(strPath, 3) End If Case VersionOnly strResult = strVersion Case DateOnly strResult = strDate Case FullUNCPath strResult = strPath Case FileURL If Left(strPath, 2) = "\\" Then strResult = "file://" & Replace(strPath, "\", "/") Else strResult = "file:///" & Replace(strPath, "\", "/") End If Case FileNameWithoutVersionOrDate strResult = objRegEx.Replace(strFileName, "") Case ServerAndShare If Left(strPath, 2) = "\\" Then Dim arrParts As Variant arrParts = Split(strPath, "\") If UBound(arrParts) >= 3 Then strResult = "\\" & arrParts(2) & "\" & arrParts(3) Else strResult = "" End If Else strResult = "" End If End Select ' تنسيق النص حسب الخيار المحدد Select Case enuTextCase Case Lower strResult = LCase(strResult) Case Upper strResult = UCase(strResult) Case Proper strResult = StrConv(strResult, vbProperCase) Case Else ' AsIs, لا تغيير End Select ExtractFilePartPro = strResult ExitHere: Set colMatches = Nothing Exit Function ErrHandler: strError = "خطأ: " & Err.Description ExtractFilePartPro = "" Resume ExitHere End Function ' روتين اختبار موسع Public Sub TestEnhanced() Dim strPath As String Dim strUNCPath As String Dim strResPath As String Dim strRes As String Dim strVer As String Dim strDat As String Dim strError As String ' تعيين مسارات الاختبار strPath = "C:\Test\MyDataBase\Officena.Accdb" strUNCPath = "\\Server\Myhiba\Officena.Accdb" strResPath = "C:\Test\MyFile_v3.4_2025-07-17.tar.gz" Debug.Print String(70, "=") Debug.Print "اختبارات استخراج أجزاء المسار" Debug.Print String(70, "=") ' اختبار الأجزاء الأساسية Debug.Print "اختبار الأجزاء الأساسية" Debug.Print String(70, "-") Debug.Print " الاسم مع الامتداد : " & ExtractFilePartPro(strPath, FileNameWithExtension) Debug.Print " الاسم فقط : " & ExtractFilePartPro(strPath, FileNameOnly) Debug.Print " الامتداد فقط : " & ExtractFilePartPro(strPath, FileExtensionOnly) Debug.Print " الامتداد مع النقطة : " & ExtractFilePartPro(strPath, FileExtensionWithDot) Debug.Print " اسم المجلد الحاوي : " & ExtractFilePartPro(strPath, ContainingFolderName) Debug.Print " المسار بدون اسم الملف : " & ExtractFilePartPro(strPath, FullFolderPath) Debug.Print " الجذر : " & ExtractFilePartPro(strPath, RootDrive) Debug.Print " المسار بصيغة UNC : " & ExtractFilePartPro(strUNCPath, FullUNCPath) Debug.Print " المسار بصيغة URL : " & ExtractFilePartPro(strUNCPath, FileURL) Debug.Print String(70, "-") ' اختبار استخراج الإصدار والتاريخ strRes = ExtractFilePartPro(strResPath, FileNameOnly, AsIs, strVer, strDat) Debug.Print "اختبار استخراج الإصدار والتاريخ" Debug.Print " الاسم : " & strRes Debug.Print " الإصدار : " & strVer Debug.Print " التاريخ : " & strDat ' اختبار الخيارات الجديدة Debug.Print " FileNameWithoutVersionOrDate: " & ExtractFilePartPro(strResPath, FileNameWithoutVersionOrDate) Debug.Print " ServerAndShare : " & ExtractFilePartPro(strUNCPath, ServerAndShare) ' اختبار معالجة الأخطاء strRes = ExtractFilePartPro("", FileNameWithExtension, AsIs, , , strError) Debug.Print " Empty path result : " & strRes & ", Error: " & strError strRes = ExtractFilePartPro("C:\Invalid\Path", FileNameWithExtension, AsIs, , , strError) Debug.Print " Invalid path result : " & strRes & ", Error: " & strError ' اختبار تنسيق الحروف Debug.Print " Upper case : " & ExtractFilePartPro(strPath, FileNameWithExtension, Upper) Debug.Print "======================================================" End Sub

اعرض الملف إمنح تطبيقك المظهر الإحترافي بإستخدام مربع حوار المهام بديل لـ MsgBox {سلسلة الأدوات المساعدة المخصصة} أرفق لك إحدى الأدوات الرائعة التي يمكن أن تغنيك عن الكثير من النماذج وتجعل رسائل التنبيه تشبه رسائل ويندوز حاولت قد الإمكان تبسيط طريقة الإستخدام وتوضيحها في التعليقات أرجو أن تنال إعجابكم مع تحياتي صاحب الملف منتصر الانسي تمت الاضافه 07/05/25 الاقسام قسم الأكسيس