Rechercher et afficher une ou plusieurs occurences d'une chaîne dans un Txtbox ou un Richtextbox

Commenter

Contenu du snippet 

'   *- RETOURNE LA POSITION  D'UN MOT DANS UNE CHAÎNE/OBJET (RICH)TXTBOX ET LE SURLIGNE -*
Private Function FindText(ByRef Obj As Object, sText As String, Optional Start As Long = 1, Optional  bSelectText As Boolean  = True) As Long
'   retourne 0 (false) si texte pas trouvé, sinon la  position
    FindText = False
    If Start < 1 Then Start = 1
    If Not Obj Is Nothing Then
        If (TypeOf Obj Is TextBox) Or (TypeOf  Obj Is RichTextBox) Then
            If LenB(Obj.Text) > 0 And LenB(sText) > 0 Then
                Dim iPos As Long
                iPos = InStr(Start, Obj.Text, sText)
                If iPos > 0 Then
                    If bSelectText Then
                        Obj.SelStart = iPos - 1
                        Obj.SelLength = Len(sText)
                        Obj.SetFocus
                    End If
                    FindText = iPos
                End If
            End If
        End If
    End If
End Function
'   *- RETOURNE  TOUTES LES POSITIONS D'UN MOT DANS UNE CHAÎNE/OBJET (RICH)TXTBOX -*
Private Function FindTexts(ByRef Obj As Object, sText As String, ByRef aArray() As Long) As  Long
'   NB : CETTE FONCTION NECESSITE LA FONCTION  "FindText"
'   retourne le compte, donc ubound +  1
    Dim lRet As Long, lCpt As Long
    lCpt = 0
    Erase aArray()
    
    Do
        lRet = FindText(Obj, sText, lRet + 1, False)
        If lRet Then
            ReDim Preserve aArray(lCpt)
            aArray(lCpt) = lRet
            lCpt = lCpt + 1
        End If
    Loop Until (lRet = 0)
    
    FindTexts = lCpt
End Function



' =====================
' EXEMPLE  D'UTILISATION
'  =====================
' PLACER 1 TXTBOX  MULTILIGNE ET 3 BOUTONS
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Const MYTEXT As String = "L'horloge" & vbCrLf & vbCrLf & _
        "Horloge! dieu sinistre, effrayant, impassible," & vbCrLf & "Dont le doigt nous  menace et nous dit : ""Souviens-toi !""" & vbCrLf & "Les vibrantes  Douleurs dans ton coeur plein d'effroi" & vbCrLf & "Se planteront  bientôt comme dans une cible;" & vbCrLf & vbCrLf & _
        "Le plaisir vaporeux fuira vers l'horizon" & vbCrLf & "Ainsi Qu 'une  sylphide au fond de la coulisse;" & vbCrLf & "Chaque instant te  dévore un morceau du délice" & vbCrLf & "A chaque homme  accordé pour toute sa saison" & vbCrLf & vbCrLf & _
        "Trois mille six cents fois par heure la Seconde" & vbCrLf & "Chuchote:  Souviens-toi!- Rapide, avec sa voix" & vbCrLf & "D 'insecte,  Maintenant dit : Je suis Autrefois," & vbCrLf & "Et j 'ai pompé ta  vie avec ma trompe immonde!" & vbCrLf & vbCrLf & _
        "Remember! Souviens-toi! Prodigue! Esto memor!" & vbCrLf & "( Mon gosier de  métal parle toutes les langues.)" & vbCrLf & "Les minutes, mortel  folâtre, sont des gangues" & vbCrLf & "Qu 'il ne faut pas  lâcher sans en extraire l'or!" & vbCrLf & vbCrLf & _
        "Souviens-toi que le Temps est un joueur avide" & vbCrLf & "Qui gagne sans  tricher, à tout coup! c'est la loi," & vbCrLf & "Le jour décroît; la  nuit augmente; souviens-toi!" & vbCrLf & "La gouffre a  toujours soif; la clepsydre se vide," & vbCrLf & vbCrLf & _
        "Tantôt sonnera l'heure où le divin Hasard," & vbCrLf & "Où l 'auguste  Vertu, ton épouse encore vierge," & vbCrLf & "Où le Repentir même  ( oh! la dernière auberge! )," & vbCrLf & "Où tout te dira :  Meurs vieux lâche! il est trop tard!" & vbCrLf & vbCrLf & "Charles Baudelaire(1821 - 1867)"
Private Const MYFIND As String = "an"
Private Sub Form_Load()
    Text1.Text = MYTEXT
    Text1.Width = 4335
    Text1.Height = 6735
    Command1.Caption = "méthode  1"
    Command2.Caption = "boucle sur méthode 1"
    Command1.Caption = "méthode  2"
End Sub
Private Sub Command1_Click()
    Buttons False
    Debug.Print FindText(Text1, MYFIND)
    Sleep 500
    Debug.Print FindText(Text1, MYFIND, 45)
    Sleep 500
    Debug.Print FindText(Text1, MYFIND, 205)
    Buttons True
End Sub
Private Sub Command2_Click()
    Buttons False
    Dim lRet As Long
    lRet = 0
    Do
        lRet = FindText(Text1, MYFIND, lRet + 1)
        Sleep 500
    Loop Until (lRet = 0)
    Buttons True
End Sub
Private Sub Command3_Click()
    Buttons False
    Dim aRet() As Long
    Dim lRet As Long
    Dim i As Long
    lRet = FindTexts(Text1, MYFIND, aRet)
    
    If lRet Then
        Text1.SetFocus
        For i = 0 To lRet - 1
            Text1.SelStart = aRet(i) - 1 'carac avant le  résultat
            Text1.SelLength = Len(MYFIND)
            Sleep 500
        Next i
    End If
    Buttons True
End Sub
Private Sub Buttons(bShow As Boolean)
    Command1.Visible = bShow
    Command2.Visible = bShow
    Command3.Visible = bShow
    DoEvents
End Sub

Compatibilité : VB6, VBA

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (PCPT)