Word Deletar todos os arquivos RTF da pasta e subpastas

[pedroch]

Olá, estou com dificuldade em elaborar uma macro no word que realize a conversão de todos os arquivos da pasta (+subpastas) selecionada para docx e delete todos os arquivos .rtf após convertê-los.

 

Até agora a macro converte todos os arquivos .rtf para docx. sem problemas, porém não estou conseguindo fazer com que ele delete os arquivos .rtf contidos na pasta e subpastas depois de convertê-los. Não consegui encaixar esta parte.

 

Segue o código abaixo:

 

Private Sub Converter_arquivos_Click()

    Dim fso As FileSystemObject, fFile As file, fFolder As Folder
    Dim fSubFolder As Folder, fPath As String, FileToSearch As String
    Dim ext As String, doc As Word.Document, SelFiles() As String, SelFolders() As String
    Dim s As Long, i As Long, x As Long, strSubFolders() As String
    On Error GoTo errHandler
    
    Set fso = New FileSystemObject

    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select the Folder to Search"
        .AllowMultiSelect = False
        .InitialFileName = CurDir
        If .Show = 0 Then Exit Sub
        Set fFolder = fso.GetFolder(.SelectedItems(1))
        On Error Resume Next
        ReDim Preserve SelFolders(i)
        SelFolders(i) = fFolder.Path & Application.PathSeparator
    End With
    
    
LoopThruFolders:
    On Error GoTo errHandler
    If SelFolders(0) = vbNullString Then Exit Sub
    For i = 0 To UBound(SelFolders)
        Set fFolder = fso.GetFolder(SelFolders(i))
        On Error Resume Next
        If fFolder.Files.Count > 0 Then
            'deals with files at the first directory level
            For Each fFile In fFolder.Files
                ext = Right(fFile, Len(fFile) - InStrRev(fFile, "."))
                If ext = "rtf" Or ext = "RTF" Then
                    ReDim Preserve SelFiles(s)
                    SelFiles(s) = fFolder & "\" & Left(fFile.Name, Len(fFile.Name) - 4)
                    s = s + 1
                    On Error GoTo errHandler
                End If
            Next fFile
        End If
        On Error GoTo errHandler
        If fFolder.subFolders.Count > 0 Then
            For Each fSubFolder In fFolder.subFolders
                ReDim Preserve strSubFolders(x)
                strSubFolders(x) = fSubFolder
                x = x + 1
            Next fSubFolder
        End If
    Next i
    
    On Error GoTo errHandler
    If strSubFolders(0) = vbNullString Then
        'there are no more folders to process
    Else
        Erase SelFolders
        For x = 0 To UBound(strSubFolders)
            On Error Resume Next
            ReDim Preserve SelFolders(x)
            SelFolders(x) = strSubFolders(x)
        Next x
        Erase strSubFolders
        x = 0
        On Error Resume Next
        ReDim Preserve strSubFolders(x)
        GoTo LoopThruFolders
    End If
    
    On Error GoTo errHandler
    
   'all folders have been seached and SelFiles contains paths to all RTF files
    If SelFiles(0) = vbNullString Then
        MsgBox "No RTF files found", vbInformation, "RTF to DOCX"
        Exit Sub
    End If
    For s = 0 To UBound(SelFiles)
        Set doc = Documents.Open(FileName:=SelFiles(s) & ".rtf", AddToRecentFiles:=False, Visible:=False)
        doc.SaveAs2 FileName:=SelFiles(s), FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
        doc.Close SaveChanges:=True
    Next s
    s = UBound(SelFiles) + 1
    MsgBox s & " Files Converted", vbInformation, "Convert RTF to DOCX"

errHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Description, vbExclamation, "RTF to DOCX"
        Err.Clear
    End If
    

End Sub

[Basole]

@pedroch não tem como eu testar, pois não estou no meu PC no momento, mas experimente, a cima da Linha Next s colocar o comando abaixo: 

 

Kill SelFiles(s) & ".rtf"

 

 

[pedroch]

@Basole Deu certo, obrigado!