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

**AbuuAhmed** · يوليو 2, 2023

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

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

**jjafferr** · يوليو 2, 2023

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

**Moosak** · يوليو 2, 2023

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

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

Expand

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

استوقفتني هذه الجملة وقد مررت سابقا بموقف مشابه ، والآن مع وجود الذكاء الاصطناعي سألته يعطيني دالتين للتحويل بين أكواد ال 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** · يوليو 2, 2023

في 2‏/7‏/2023 at 08:31, Moosak said:

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

Expand

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

'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** · يوليو 2, 2023

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

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

Expand

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

RichTextHighlight_02.accdbFetching info...

**jo_2010** · يوليو 3, 2023

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

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

**AbuuAhmed** · يوليو 3, 2023

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

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

Expand

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

RichTextHighlight_03.accdbFetching info...

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

**AbuuAhmed** · يوليو 4, 2023

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

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

Expand

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

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

**Moosak** · يوليو 4, 2023

بوركت @AbuuAhmed

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

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

**jo_2010** · يوليو 4, 2023

بارك اللة فيك

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

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

خالص الشكر

**AbuuAhmed** · يوليو 4, 2023

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

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

Expand

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

اقتباس

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

Expand

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

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

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

**AbuuAhmed** · يوليو 4, 2023

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

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

Expand

#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** · يوليو 5, 2023

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

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

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

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

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

RichText_Query_06.accdbFetching info...

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

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

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

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

**AbuuAhmed** · يوليو 5, 2023

بدل 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** · يوليو 5, 2023

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

RichText_Memo_07.accdbFetching info... RichText_Query_07.accdbFetching info... PlainText_Sel_07.accdbFetching info...

**jo_2010** · يوليو 5, 2023

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

**AbuuAhmed** · يوليو 5, 2023

في 5‏/7‏/2023 at 08:39, jo_2010 said:

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

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

Expand

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

**دروب مبرمج** · يوليو 5, 2023

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

**AbuuAhmed** · يوليو 6, 2023

في 5‏/7‏/2023 at 22:22, دروب مبرمج said:

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

Expand

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

تسجيل الدخول

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

الردود الموصى بها

AbuuAhmed

jjafferr

Moosak

AbuuAhmed

AbuuAhmed

jo_2010

AbuuAhmed

AbuuAhmed

Moosak

jo_2010

AbuuAhmed

AbuuAhmed

jo_2010

AbuuAhmed

AbuuAhmed

jo_2010

AbuuAhmed

دروب مبرمج

AbuuAhmed

Join the conversation

محتوي مشابه

طريقة ربط برنامج Access على شبكة لاى عدد مستخدمين ... ببساطة

دوال برمجية دالتان للتحويل بين الميلادي والهجري باحترازات أكثر

مشكلة في فتح ملف أكسس | مرفق صُور الخطأ

الغاء التصفية عند فتح النموذج

كيف يمكن عمل ملف جداول منفصل لكل سنة مالية؟

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information