Categoria: Codice per Windows

Mi è capitato di avere un sacco di documenti word che volevo convertire in file di testo automaticamente e non sapevo come fare.

Ho risolto con questa macro VB che una volta lanciata chiede la cartella di partenza e poi la cartella di destinazione, convertendo tutti i file word che trova nella cartella iniziale.

Ecco il codice:

Option Explicit

Sub BatchDocxToTxt()
    Dim srcFolder As String, destRoot As String
    Dim fldrPicker As FileDialog
    
    ' Seleziona cartella sorgente
    Set fldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
    With fldrPicker
        .Title = "Seleziona la cartella sorgente (verranno cercati *.docx ricorsivamente)"
        If .Show <> -1 Then Exit Sub
        srcFolder = .SelectedItems(1)
    End With
    
    ' Seleziona cartella destinazione
    Set fldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
    With fldrPicker
        .Title = "Seleziona la cartella destinazione (qui verranno salvati i .txt)"
        If .Show <> -1 Then Exit Sub
        destRoot = .SelectedItems(1)
    End With
    
    If Right(srcFolder, 1) <> "\" Then srcFolder = srcFolder & "\"
    If Right(destRoot, 1) <> "\" Then destRoot = destRoot & "\"
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = wdAlertsNone
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    On Error GoTo CleanUp
    ProcessFolderRecursive fso.GetFolder(srcFolder), srcFolder, destRoot, fso
    
    MsgBox "Conversione completata.", vbInformation
CleanUp:
    Application.ScreenUpdating = True
    Application.DisplayAlerts = wdAlertsAll
    Set fso = Nothing
End Sub

Private Sub ProcessFolderRecursive(ByVal folder As Object, ByVal srcRoot As String, ByVal destRoot As String, ByVal fso As Object)
    Dim fileItem As Object
    Dim subFld As Object
    Dim relPath As String
    Dim targetFolder As String
    Dim doc As Document
    Dim srcPath As String
    Dim baseName As String
    Dim targetPath As String
    
    ' Processa i file .docx nella cartella corrente
    For Each fileItem In folder.Files
        If LCase(fso.GetExtensionName(fileItem.Name)) = "docx" Then
            ' skip temporary Word files (es. ~$_...)
            If Left(fileItem.Name, 2) <> "~$" Then
                srcPath = fileItem.Path
                ' Calcola percorso relativo della cartella contenente il file rispetto alla radice sorgente
                relPath = Replace(folder.Path, srcRoot, "")
                If Left(relPath, 1) = "\" Then relPath = Mid(relPath, 2)
                
                ' Crea cartella corrispondente nella destinazione (se serve)
                If relPath = "" Then
                    targetFolder = destRoot
                Else
                '    targetFolder = fso.BuildPath(destRoot, relPath)
                End If
                
                ' Nome base e percorso di destinazione
                baseName = fso.GetBaseName(fileItem.Name)
                targetPath = fso.BuildPath(destRoot, baseName & ".txt")
                
                ' Apri il documento e salva come testo Unicode (per preservare accenti/utf8)
                On Error Resume Next
                Set doc = Documents.Open(FileName:=srcPath, ReadOnly:=True, AddToRecentFiles:=False)
                If Err.Number <> 0 Then
                    Debug.Print "Errore aprendo: " & srcPath & " -> " & Err.Description
                    Err.Clear
                    On Error GoTo 0
                Else
                    On Error GoTo 0
                    ' wdFormatUnicodeText preserva Unicode; se vuoi ANSI usa wdFormatText (ma perde caratteri non ANSI)
                    doc.SaveAs2 FileName:=targetPath, FileFormat:=wdFormatUnicodeText
                    doc.Close SaveChanges:=False
                    Set doc = Nothing
                End If
            End If
        End If
    Next fileItem
    
    ' Ricorsione nelle sottocartelle
    For Each subFld In folder.SubFolders
        ProcessFolderRecursive subFld, srcRoot, destRoot, fso
    Next subFld
End Sub