AbuuAhmed

بدل Right إلى Mid في هذا السطر: With Forms(Left(frmCtl, sPos - 1)).Controls(Right(frmCtl, sPos + 1)) ليصبح كالتالي: With Forms(Left(frmCtl, sPos - 1)).Controls(Mid(frmCtl, sPos + 1))

#If Vba7 Then Private Declare PtrSafe Sub ChooseColor Lib "msaccess.exe" Alias "#53" (ByVal hwnd As Long, rgb As Long) #Else Private Declare Sub ChooseColor Lib "msaccess.exe" Alias "#53" (ByVal hWnd As Long, rgb As Long) #End If Function DialogColor(rgb As Long) As Long Call ChooseColor(Application.hWndAccessApp, rgb) DialogColor = rgb End Function كلامك صحيح، تم التصحيح.

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

تم الوصول إلى جواب لسؤالي عن طريق هذا الرد: https://stackoverflow.com/questions/55523926/font-limitation-in-msaccess-richtext-edit-tool#:~:text=What you can do is to set the,11 in the format toolbar for regular text. وقد قمت بتصميم دالة لحل هذه المشكلة: Function RichTextFontSize(FontSize As Double) As Byte Dim fs As Byte If FontSize <= 8 Then fs = 1 ElseIf Between(FontSize, 9, 10) Then: fs = 2 ElseIf Between(FontSize, 11, 12) Then: fs = 3 ElseIf Between(FontSize, 13, 16) Then: fs = 4 ElseIf Between(FontSize, 17, 22) Then: fs = 5 ElseIf Between(FontSize, 23, 30) Then: fs = 6 Else: fs = 7 End If RichTextFontSize = fs End Function هذا آخرر إصدرا بعد حل باقي المشكلات العالقة: RichTextHighlight_04.accdb

تم إضافة التصفية واستخدام حدث عند التغيير يتبقى البحث عن تحويل حجم الخط بشكل علمي صحيح. RichTextHighlight_03.accdb

مثال 2 DateConverter_02.mdb

- القاعدة تقول "مايمكن الحصول عليه بالمعالجة/الحساب لا داعي لتخزينه" وإذا اضطررنا لتخزينه فلنقم بتخيزينه بأصغر مساحة ممكنة ثم نظهره بالشكل المطلوب بالمعالجة. - أنا ضد تخزين تاريخين لتقويمين مختلفين، فأما: * عند استخدام تقويم النظام ميلادي يتم تخزين الميلادي كتاريخ أو الهجري كنص بأقصر طول ممكن، وأنا أفضل وبقوة التخزين بالميلادي. * عند استخدام تقويم النظام هجري يتم تخزين الهجري كتاريخ. - يتم "إظهار التاريخ المقارن/المقابل بالمعالجة عن طريق الاستعلام. - في المثال السابق كان تركيزي على فكرة التحويل بين التقويمين الميلادي والهجري فقط، وكان في انطباعي أن السائل مبتدئ ولا يمكن الدخول معه في هذه التفاصيل حاليا. شكرا للجميع.

حياك الله يا بلال - لم يكن طلبك واضح بشكل كاف في موضوعك السابق وحتى في هذا الموضوع. - يفترض أن تكتب ملاحظتك هذه في نفس موضوع السابق. - إذا أنت فقط تريد تاريخ اليوم مثال أخينا @TQTHAMI يناسب طلبك مع بعض الملاحظات البسيطة على طريقة تبديل تقويم النظام في الكود. - أما إذا أردت أن تعين مصدر بيانات للنموذج فالطريقة السابقة هي الأصح حيث يفترض عدم تبديل البيانات إلا بقرار من المستخدم. موفقين جميعا.

تم إضافة أزرار خصائص الخط وخلفية صندوق مفتاح البحث. RichTextHighlight_02.accdb

حياك الله أستاذ أنا كانت حاجتي التحويل من الرقم الطويل إلى هيكس. وكنت قد صممت نفس الدالتين وأعتقد كان في منتدى الاكسل ولكن من الصعب أن أبحث عنهما، فأنا لا أحتفظ بأعمالي. عموما وجدت في النت بديلا عن دوالي: 'Author : Mike Wolfe Function ConvertColorToRgb(ColorValue As Long) As String Dim Red As Long, Green As Long, Blue As Long Red = ColorValue Mod 256 Green = ((ColorValue - Red) / 256) Mod 256 Blue = ((ColorValue - Red - (Green * 256)) / 256 / 256) Mod 256 ConvertColorToRgb = "RGB(" & _ Red & ", " & _ Green & ", " & _ Blue & ")" End Function ومنها نستطيع استخدام الدالة التي جلبتها أنت RGBToHex وشكرا لأساتذة تشريفهم موضوعي.

ملاحظاتي: - أتعبني تحويل رقم اللون الطويل إلى هيكس Hex أرقام سداسية إن صح التعبير واضطررت لعمل دالة لمعالجة مخرجات الدالة الأصل. - لم أصل إلى نوع مقاس الخط لأتمكن من حويلة بشكل دقيق فاضطررت لاستخدام رقم تقريبي بتقسيمه على 3.5 . - استخدمت كل خصائص الخط في صندوق كلمة/نص البحث ما عدا اسم الخط. - حاليا تبديل خصائص الخط في صندوق البحث يدويا (في طور التصميم) ويمكنكم إضافة تعديله بواسط الأزرار والخيارات في طور التشغيل. - مسموح للجميع التطوير فيه مباشرة وبدون إذن. - الدالة مصممة ليستفاد منها في الاستعلامات وفي الجداول لحقول المذكرة. Option Compare Database Option Explicit Function myHex(Color As Long) As String Dim hexStr As String hexStr = Hex(Color) If Len(hexStr) = 6 Then hexStr = Right(hexStr, 2) & Mid(hexStr, 3, 2) & Left(hexStr, 2) Else hexStr = Left(Right(hexStr, 2) & Left(hexStr, Len(hexStr) - 2) & "000000", 6) End If myHex = "#" & hexStr End Function Function RichText(ByVal sText As Variant, frmCtl As String) As String Dim sWord As String Dim lStr As String Dim rStr As String Dim sPos As Integer Dim fSize As Double sPos = InStr(1, frmCtl, ",") With Forms(Left(frmCtl, sPos - 1)).Controls(Right(frmCtl, sPos + 1)) sText = PlainText(Nz(sText, "")) sWord = PlainText(Nz(.Value, "")) rStr = "</font>" lStr = "<font color=""" & myHex(.ForeColor) & """>" sText = Replace(sText, sWord, lStr & sWord & rStr, 1) 'sText = Replace(Replace(sText, rStr & " " & lStr, " ", 1), rStr & "" & lStr, "", 1) lStr = "<font style='BACKGROUND-COLOR:" & myHex(.BackColor) & "'>" sText = Replace(sText, sWord, lStr & sWord & rStr, 1) fSize = .FontSize / 3.5 'تحويل تقريبي lStr = "<font size=" & fSize & "pt>" sText = Replace(sText, sWord, lStr & sWord & rStr, 1) If .FontBold Then lStr = "<b>": rStr = "</b>" sText = Replace(sText, sWord, lStr & sWord & rStr, 1) End If If .FontItalic Then lStr = "<i>": rStr = "</i>" sText = Replace(sText, sWord, lStr & sWord & rStr, 1) End If If .FontUnderline Then lStr = "<u>": rStr = "</u>" sText = Replace(sText, sWord, lStr & sWord & rStr, 1) End If End With RichText = sText End Function RichTextHighlight_01.accdb

وهذه الدالة بعد تقليل أسطرها وتبديل التكرار باستخدام دالة replace Function RichText(ByVal sText As Variant, ByVal sWord As Variant) As String Dim lStr As String Dim rStr As String sText = Nz(sText, "") sWord = Nz(sWord, "") lStr = "<font color=red>" rStr = "</font>" sText = Replace(Replace(sText, lStr, "", 1), rStr, "") sText = Replace(sText, sWord, lStr & sWord & rStr, 1) sText = Replace(Replace(sText, rStr & " " & lStr, " ", 1), rStr & "" & lStr, "", 1) RichText = sText End Function

عزيزي أحيانا اللي جالسين في المدرجات يرون ما لا يراه اللاعبون. وأكيد مرت عليك أن تقوم بتعديل أكوادك أكثر من مرة وأحيانا تضحك من عملك وتتساءل كيف غفلت وارتكبت تلك الهفوات. على كل أرجو الانتباه أن أستخدم الدالة للاستعلام ولحقل مذكرة وهنا ستغير من رأيك السابق مع مزيد من التأمل. وهنا الكود الطويل القصير مع شرح مبسط لغير الخبراء: Function RichText(ByVal sText As Variant, ByVal sWord As Variant) As String Dim lStr As String Dim rStr As String Dim sPos As Integer 'للتخلص من القيمة null sText = Nz(sText, "") sWord = Nz(sWord, "") 'لتكرار استخدام عبارتي حصر اللون وضعناهما في متغيرين lStr = "<font color=red>" rStr = "</font>" 'لإزالة التنسيق القديم من حقل المذكرة sText = Replace(sText, lStr, "", 1) sText = Replace(sText, rStr, "", 1) 'تكرار لتلوين جمعيع الكلمات في الحقل الواحد sPos = InStr(1, sText, sWord) Do While sPos > 0 sText = Left(sText, sPos - 1) & _ lStr & sWord & rStr & _ Mid(sText, sPos + Len(sWord)) sPos = InStr(sPos + Len(sWord & lStr), sText, sWord) Loop 'لاحتصار النص وخصوصا لحقل المذكرة بإزالة تكرار عبارات الحصر للون sText = Replace(sText, rStr & " " & lStr, " ", 1) sText = Replace(sText, rStr & "" & lStr, "", 1) RichText = sText End Function أما بالنسبة للاختصار فيمكن التالي: من سطرين إلى سطر لأزالة التنسيق القديم وهذ مطلوب لحقل مذكرة وغير مطلوب للاستعلام. ما تفضلت به بتبديل التكرار بدالة replace وسأقوم بتجربتها مع أني استخدمت وظيفتها بدلا منها واستخدمتها في الدالة 4 مرات. من سطرين إلى سطر لإزالة تكرار عبارات حصر اللون وهو مهم أكثر في حقل المذكرة لأننا نقوم بتخزين النص والتنسيق معا.

الأفكار تتدافع للاستفادة من الفكرة الجديدة، الآن الدلة تلون أكثر من كلمة في الحقل الواحد. الفكرة التالية هي زيادة خصائص الكلمة كنوع الخط ولون الخلفية وحجم الخط والخط المائل وخط أسفل الكلمة. ما أريده هو تمرير الأداة للدالة عند استخدام الاستعلام. هل أحد جرب هذه الحيثية؟ Function RichText(ByVal sText As Variant, ByVal sWord As Variant) As String Dim lStr As String Dim rStr As String Dim sPos As Integer sText = Nz(sText, "") sWord = Nz(sWord, "") lStr = "<font color=red>" rStr = "</font>" sText = Replace(sText, lStr, "", 1) sText = Replace(sText, rStr, "", 1) sPos = InStr(1, sText, sWord) Do While sPos > 0 sText = Left(sText, sPos - 1) & _ lStr & sWord & rStr & _ Mid(sText, sPos + Len(sWord)) sPos = InStr(sPos + Len(sWord & lStr), sText, sWord) Loop sText = Replace(sText, rStr & " " & lStr, " ", 1) sText = Replace(sText, rStr & "" & lStr, "", 1) RichText = sText End Function SearchSel_04.accdb

لم يأني في خلدي فكرة عمل الصندوق مع الاستعلام. فكرة جميلة جدا، مثال تعلمت منه الجديد المفيد اليوم. المثال بعد تطبيق الفكرة الجديدة. SearchSel_03.accdb

شكرا عزيزي The database you are trying to open requires a newer version of Microsoft Access لا زلت لا أستطيع فتح قاعدة البيانات.

التحويل حسب تاريخ الفي بي أيه DateConverter_01.mdb

هل ترغب في تاريخ الهجري للنظام أم تقويم أم القرى؟

هل تستطيع تحويل المرفق إلى إصدار 2003؟ مع تصوري أنه لن يضيف شيئ على ما سبق عرضه في هذا الموضوع.

أساسا مثالك الأصل هو تنسيق شرطي وعيبه أنك لا تستطيع تلوين أكثر من كلمة ضمن الحقل. ثم عملت لك فكرة التظليل وعيبه أنك لا تستطيع تظليل الكلمة في كل السجلات دفعة واحدة. ثم عملت لك فكرة التلوين وعيبه أنك لا بد لك أن تستخدم حقل مذكرة في الجدول. هذا كل ما يستطيع أن يوفره الأكسس وفقا لخبرتي القديمة مع نسخ الأكسس القديمة، هل هناك جديد مع النسخ الجديدة؟ أنتم أعلم مني، ننتظر مشاركة الزملاء. وكل عام وأنت بخير.

جرب الآن طبعا بالتلوين يمكن عمل التالي: - تكرار للبحث عن الكلمة المراد تلوينها في السجل الواحد. - تكرار للبحث عن الكلمة في جميع السجلات. SearchSel_02.accdb

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

تطبيق الفكرة SearchSel_01.accdb

أعتقد (غير متأكد) ولكن على السجل الحالي فقط ولكلمة واحدة فقط أيضا، بمعنى لو حقل الاسم يحتوي على اسم أحمد مرتين سيظلل الاسم الأول فقط. لم أحاول ولا أستطيع فتح قاعدة بياناتك لآن نسختك أحدث من نسخة الأكسس عندي. يمكن الزملاء التجارب مع هذه الخصائص: SelText SelStart SelLength

أنا قدمت لك كود ورفعت لك نفس المثال بعد تطبيق الدالة عليه وبه النتائج ظاهرة واضحة!! لك كل الحق أن تختار ما يناسبك أخي، أما الكود لا يعمل .. غريب "شويتين". موفق أخي. نسيت أنبهك أن تحول ملفك الأصل من xlsx إلى xlsm