[السندبااد]

السلام عليكم ورحمة الله وبركاته

من أراد أن يبحث عن أكثر من كلمة في الريتش بوكس فليستخدم هذا الكود :

كود :

        'إما أن تعمل مصفوفة بهذا الشكل
        'Dim Days(6) As String
        'Days(0) = "الله"
        'Days(1) = "رسول"
        'Days(2) = "عن"
        'Days(3) = "قال"
        'Days(4) = "من"
        'Days(5) = "عليه"
        'Days(6) = "سلم"

        'أو مصفوفة بهذا الشكل
        Dim Days() As String = {"الله", "رسول", "عن", "قال", "من", "عليه", "سلم"}

        'عدد محتويات المصفوفة
        'MsgBox((Days.Count))

        Dim range As New TextRange(RichTxtPost.Document.ContentStart, RichTxtPost.Document.ContentEnd)
        'منسق
        Dim GetPost As String
        GetPost = myInput2
        Dim documentBytes = Encoding.UTF8.GetBytes(GetPost)
        Using reader = New MemoryStream(documentBytes)
            reader.Position = 0
            RichTxtPost.SelectAll()
            RichTxtPost.Selection.Load(reader, DataFormats.Rtf)
        End Using

        Dim pattern As String = ""
        For ii = 0 To Days.Count - 1
            For Each c As Char In Days(ii).ToString
                pattern = pattern & Regex.Escape(c) & "[\u064B-\u0653]*"
            Next c
            'تنسيق الكلمات لتخرج بالنهاية هكذا
            '"(عليه|سلم|من|قال|عن|رسول|الله)"
            pattern = "(" & pattern & ")" & "|"
        Next
        'سنحذف من آخر المتغير القوس والعمود |)
        pattern = Mid(pattern, 1, Len(pattern) - 2)
        'MsgBox(pattern)

        'للبحث عن كلمة واحدة
        'نضع المتغير + القوس الذي حذفناها فنحن كانت غايتنا حذف العمود لا القوس فهنا نعيد القوس في النهاية
        Dim reg As New Regex(pattern & ")", RegexOptions.Compiled Or RegexOptions.IgnoreCase)
        'للبحث عن عدة كلمات
        'Dim reg As New Regex("(" & pattern & "| مُحَمَّدٍ " & "| إِبْرَاهِيمَ " & ")", RegexOptions.Compiled Or RegexOptions.IgnoreCase)

        If reg.Matches(range.Text).Count < 1 Then
            MsgBox("لا يوجد نتائج")
        Else
            MsgBox("عدد النتائج : " & reg.Matches(range.Text).Count)
        End If

        Dim start = RichTxtPost.Document.ContentStart
        While start IsNot Nothing AndAlso start.CompareTo(RichTxtPost.Document.ContentEnd) < 0
            If start.GetPointerContext(LogicalDirection.Forward) = TextPointerContext.Text Then
                Dim match = reg.Match(start.GetTextInRun(LogicalDirection.Forward))

                Dim textrange = New TextRange(start.GetPositionAtOffset(match.Index, LogicalDirection.Forward), start.GetPositionAtOffset(match.Index + match.Length, LogicalDirection.Backward))
                textrange.ApplyPropertyValue(TextElement.ForegroundProperty, New SolidColorBrush(Colors.HotPink))
                textrange.ApplyPropertyValue(Inline.TextDecorationsProperty, TextDecorations.Underline)
                'textrange.ApplyPropertyValue(Inline.FontStyleProperty, FontStyles.Italic)
                'textrange.ApplyPropertyValue(TextElement.FontWeightProperty, FontWeights.Bold)
                start = textrange.[End]
            End If
            start = start.GetNextContextPosition(LogicalDirection.Forward)
        End While