دوال برمجية تظليل كلمات البحث في النص الغني Rich Text

[AbuuAhmed]

ملاحظاتي:
- أتعبني تحويل رقم اللون الطويل إلى هيكس 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

تم تعديل يوليو 2, 2023 بواسطه AbuuAhmed

[jjafferr]

شكرا جزيلا اخوي ابو احمد 🙂

[Moosak]

2 ساعات مضت, AbuuAhmed said:

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

سلمت يمناك أبو أحمد 🙂 

استوقفتني هذه الجملة وقد مررت سابقا بموقف مشابه ، والآن مع وجود الذكاء الاصطناعي سألته يعطيني دالتين للتحويل بين أكواد ال RGB وال Hex  فما قصر وأعطاني التالي ( بدون تجربة ) 🙂 : 

'=================== (To convert RGB to Hex:)

Function RGBToHex(ByVal red As Integer, ByVal green As Integer, ByVal blue As Integer) As String
    RGBToHex = "#" & Right("0" & Hex(red), 2) & Right("0" & Hex(green), 2) & Right("0" & Hex(blue), 2)
End Function

'=================== (To convert Hex to RGB:)

Function HexToRGB(ByVal hexCode As String) As Variant
    Dim red As Integer, green As Integer, blue As Integer
    
    If Left(hexCode, 1) = "#" Then
        hexCode = Right(hexCode, Len(hexCode) - 1)
    End If
    
    red = Val("&H" & Mid(hexCode, 1, 2))
    green = Val("&H" & Mid(hexCode, 3, 2))
    blue = Val("&H" & Mid(hexCode, 5, 2))
    
    HexToRGB = Array(red, green, blue)
End Function

'=================== (Here's an example of how you can use these functions:)

Sub TestColorConversion()
    Dim red As Integer, green As Integer, blue As Integer
    Dim hexCode As String
    Dim rgbResult As Variant
    
    ' Convert RGB to Hex
    red = 255
    green = 0
    blue = 128
    hexCode = RGBToHex(red, green, blue)
    Debug.Print "Hex Code: " & hexCode
    
    ' Convert Hex to RGB
    hexCode = "#00FF00"
    rgbResult = HexToRGB(hexCode)
    red = rgbResult(0)
    green = rgbResult(1)
    blue = rgbResult(2)
    Debug.Print "RGB: (" & red & ", " & green & ", " & blue & ")"
End Sub

 

[AbuuAhmed]

8 ساعات مضت, Moosak said:

دالتين للتحويل بين أكواد ال RGB وال Hex

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

'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

وشكرا لأساتذة تشريفهم موضوعي.

[AbuuAhmed]

17 ساعات مضت, AbuuAhmed said:

- حاليا تبديل خصائص الخط في صندوق البحث يدويا (في طور التصميم) ويمكنكم إضافة تعديله بواسط الأزرار والخيارات في طور التشغيل.

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

RichTextHighlight_02.accdb

[jo_2010]

الخبير الفاضل AbuuAhmed  المبدع 

لكى يكتمل هذا العمل الرائع هل من الممكن التصفية اثناء الكتابة بدل من الضغط على مفتاح enter  للحصول على كلمات البحث المتشابهة

[AbuuAhmed]

في 3‏/7‏/2023 at 21:29, jo_2010 said:

هل من الممكن التصفية اثناء الكتابة بدل من الضغط على مفتاح enter

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

RichTextHighlight_03.accdb

تم تعديل يوليو 4, 2023 بواسطه AbuuAhmed

[AbuuAhmed]

في 2‏/7‏/2023 at 09:00, AbuuAhmed said:

لم أصل إلى نوع مقاس الخط لأتمكن من حويلة بشكل دقيق فاضطررت لاستخدام رقم تقريبي بتقسيمه على 3.5 .

تم الوصول إلى جواب لسؤالي عن طريق هذا الرد:
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

تم تعديل يوليو 4, 2023 بواسطه AbuuAhmed

[Moosak]

بوركت @AbuuAhmed

بقي لك أن تتخلص من رسائل التحديث المزعجة عند كل تحديث يحصل 🙂 

 

وتغيرر هاتين من Long إلى LongPtr لكي تعمل الدالة على النواة 64 بت :

[jo_2010]

بارك اللة فيك

خالص الشكر على هذا العمل الرائع

سؤال بسيط عند تغيير اسماء النماذج يتوقف البرنامج عن العمل ويعطى رسائل خطا كثيرة

خالص الشكر

[AbuuAhmed]

في 4‏/7‏/2023 at 09:29, Moosak said:

بقي لك أن تتخلص من رسائل التحديث المزعجة عند كل تحديث يحصل

تم حلها مع أنها خيار في الأكسس حسب رغبة المستخدم.
 

اقتباس

سؤال بسيط عند تغيير اسماء النماذج يتوقف البرنامج عن العمل ويعطى رسائل خطا كثيرة

أسم النموذج وصندوق البحث موجود في الاستعلام، لا بد من تبديله

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

 

 

 

تم تعديل يوليو 5, 2023 بواسطه AbuuAhmed
تنقيح الأكواد وبالخصوص دالة long2Hex

[AbuuAhmed]

16 ساعات مضت, Moosak said:

وتغيرر هاتين من Long إلى LongPtr لكي تعمل الدالة على النواة 64 بت :

#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

كلامك صحيح، تم التصحيح.

تم تعديل يوليو 4, 2023 بواسطه AbuuAhmed

[jo_2010]

الخبير الفاضل AbuuAhmed

اشكر سعة صدرك وتحمل اسالتنا

قمت بتغيير اسم النموذج فى الاستعلام كما بالصور

تظهر اخطاء فى الكود اليك الصور

توجد قاعدة صغيرة للتعديل عليها بخبرة حضرتك

RichText_Query_06.accdb

النموذج الاول  PlainText_Sel_06

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

سامحنى لقلة خبرتى وجهلى

شكرا جزيلا على اهتمام حضرتك بالرد عليا

[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))

 

[AbuuAhmed]

تشتتي زاد مع هذا الموضوع 😞
النسخ مرة أخرى بعد تصحيح الخطأ الأخير.

RichText_Memo_07.accdb RichText_Query_07.accdb PlainText_Sel_07.accdb

[jo_2010]

خالص الشكر على معلمنا الخبير الفاضل  AbuuAhmed

[AbuuAhmed]

8 ساعات مضت, jo_2010 said:

لنموذج الاول  PlainText_Sel_06

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

لا تستطيع تغيير لون التظليل ولا الخط.

[دروب مبرمج]

ما شاء الله لا قوة الا بالله فناااان و  مبدع

[AbuuAhmed]

3 ساعات مضت, دروب مبرمج said:

ما شاء الله لا قوة الا بالله فناااان و  مبدع

شكرا أستاذ، ما عليك زود