' *- 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