[Закрыто] макрос пересохраняющий все .docx файлы в .doc

Sub SaveDocxToDoc()
  Dim sPath As String
  Dim sFileName As String
  Dim counter As Long
  
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Выберите папку"
    .AllowMultiSelect = False
    If .Show Then
      sPath = .SelectedItems(1)
    Else
      Exit Sub
    End If
  End With
  
  sFileName = Dir(sPath & Application.PathSeparator & "*.docx")
  
  Do While Len(sFileName) > 0
    With Documents.Open(sPath & Application.PathSeparator & sFileName, AddToRecentFiles:=False)
      .SaveAs Mid(.FullName, 1, InStrRev(.FullName, ".") - 1) & ".doc", wdFormatDocument97
      .Close
    End With
    sFileName = Dir
    DoEvents
    counter = counter + 1
  Loop
  If counter > 0 Then
    MsgBox "Пересохранение docx в doc завершено." & vbNewLine & "Обработано " & counter & " документов.", vbInformation, "Пересохранение docx в doc"
  Else
    MsgBox "В папке """ & sPath & """ файлы docx не обнаружены.", vbInformation, "Пересохранение docx в doc"
  End If
End Sub