Microsoft Office Forums - View Single Post - [Solved] problem with capturing group in findText/ReplaceWith

Ddadoo57 · 02-19-2025, 07:25 AM

Thanks for your interest in my post!

You can forget about the loop because it's the same thing without a loop and I was using it in a special case.

I'm attaching all the following code that creates errors. You can see your code there, and in this case the error changes place a little.
In my rtf file I simply have a “Hi ...Hello!” after processing I have “Hi H... ello!”.

Code:

Sub M2_RTF_CorrectionPonctuation_WIP()    
	Dim objWord As Object
    Dim objDoc As Object
    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim dossier As String
    Dim texte As Range
	
	With Application.fileDialog(msoFileDialogFolderPicker)
        .Title = "Sélectionnez le dossier contenant les fichiers RTF"
        .InitialFileName = ActiveDocument.Path & "\rtfs\" '"." 'dossierParDefaut 
        If .Show = -1 Then
            dossier = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFSO.GetFolder(dossier)

    Set objWord = CreateObject("Word.Application")
    objWord.Visible = False 
    
    For Each objFile In objFolder.Files
        If LCase(objFSO.GetExtensionName(objFile.Name)) = "rtf" Then
            nbrFilesToDo = nbrFilesToDo + 1
        End If
    Next
    
    If nbrFilesToDo < 1 Then
        objWord.Quit
        Set objWord = Nothing
        Set objFolder = Nothing
        Set objFSO = Nothing
        
        MsgBox "Pas de fichiers RTF à traiter dans le dossier sélectionné !", vbInformation        
        Exit Sub
    End If

    Set regex = CreateObject("VBScript.RegExp")

    For Each objFile In objFolder.Files
    
        If LCase(objFSO.GetExtensionName(objFile.Name)) = "rtf" Then
        
            Set objDoc = objWord.Documents.Open(objFile.Path, ReadOnly:=False)             

            objDoc.TrackRevisions = True
            
            Set texte = objDoc.content
			
			With texte.Find
			  .ClearFormatting
			  .Replacement.ClearFormatting
			  .Execute FindText:="...", ReplaceWith:="…", MatchWildcards:=True, format:=False, Wrap:=wdFindContinue, Replace:=wdReplaceAll
			End With

			Application.ScreenUpdating = False
			With texte.Find
			  .ClearFormatting
			  .Replacement.ClearFormatting
			  .Execute FindText:="…([A-Za-zÀ-ÖØ-öø-ÿ0-9])", ReplaceWith:="… \1", MatchWildcards:=True, format:=False, Wrap:=wdFindContinue, Replace:=wdReplaceAll
			End With
			Application.ScreenUpdating = True			
            
            objDoc.Save
            objDoc.Close False
        End If
    Next objFile
    
    objWord.Quit

    Set objDoc = Nothing
    Set objWord = Nothing
    Set objFile = Nothing
    Set objFolder = Nothing
    Set objFSO = Nothing    
    Set regex = Nothing
End Sub