Использовал другой код, с сайта ОСЗона.ру где ссылались на этот сайт
Sub SaveAllToWeb()
Dim sDir As String
Dim sFileName As String
Dim oDoc As Document
Dim i As Integer
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Выберите папку"
If .Show Then sDir = .SelectedItems(1) Else Exit Sub
End With
Application.ScreenUpdating = False
sFileName = Dir(sDir & Application.PathSeparator & "*.rtf")
While Len(sFileName) > 0
sFileName = sDir & Application.PathSeparator & sFileName
Set oDoc = Documents.Open(sFileName, False, False, False)
oDoc.SaveAs Mid(sFileName, 1, InStrRev(sFileName, ".")) & "htm", wdFormatHTML, AddToRecentFiles:=False
oDoc.Close
sFileName = Dir
i = i + 1
DoEvents
Wend
Application.ScreenUpdating = True
MsgBox "Пересохранение завершено. Сохранено " & i & " файлов."
End Sub
Пришлось капельку изменить под себя, и получаю три макроса
Sub SaveDOCToText()
Dim sDir As String
Dim sFileName As String
Dim oDoc As Document
Dim i As Integer
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Âûáåðèòå ïàïêó"
If .Show Then sDir = .SelectedItems(1) Else Exit Sub
End With
Application.ScreenUpdating = False
sFileName = Dir(sDir & Application.PathSeparator & "*.doc")
While Len(sFileName) > 0
sFileName = sDir & Application.PathSeparator & sFileName
Set oDoc = Documents.Open(sFileName, False, False, False)
oDoc.SaveAs Mid(sFileName, 1, InStrRev(sFileName, ".")) & "txt", wdFormatText, AddToRecentFiles:=False
oDoc.Close
sFileName = Dir
i = i + 1
DoEvents
Wend
Application.ScreenUpdating = True
MsgBox "Ïåðåñîõðàíåíèå çàâåðøåíî. Ñîõðàíåíî " & i & " ôàéëîâ."
End Sub
Sub SaveDocxToText()
Dim sDir As String
Dim sFileName As String
Dim oDoc As Document
Dim i As Integer
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Âûáåðèòå ïàïêó"
If .Show Then sDir = .SelectedItems(1) Else Exit Sub
End With
Application.ScreenUpdating = False
sFileName = Dir(sDir & Application.PathSeparator & "*.docx")
While Len(sFileName) > 0
sFileName = sDir & Application.PathSeparator & sFileName
Set oDoc = Documents.Open(sFileName, False, False, False)
oDoc.SaveAs Mid(sFileName, 1, InStrRev(sFileName, ".")) & "txt", wdFormatText, AddToRecentFiles:=False
oDoc.Close
sFileName = Dir
i = i + 1
DoEvents
Wend
Application.ScreenUpdating = True
MsgBox "Ïåðåñîõðàíåíèå çàâåðøåíî. Ñîõðàíåíî " & i & " ôàéëîâ."
End Sub
Все три - делают то что мне нужно, а это --- Конвертируют папку с файлами Doc Docx и RTF, в файлы TXT в этих же папках
За скрипт спасибо El Sanchez, и viter.alex
Остался вопрос, как объединить все три скрипта в один. Пробовал добалением расширений через запятую, но не получилось, потому что не представляю как это работает. Пробовал добавлением дополнительных строк, но, не получилось, так как макрос читает первую строку с расширением, и остальные игнорирует
подскажите плиз
Да, путём подстановки знака "*" в строке сразу после "*.Doc"
sFileName = Dir(sDir & Application.PathSeparator & "*.doc*")
Получилось избавиться от второго скрипта. Данный сможет работать с DOC и DOCX одновременно (а также docf, docg и doccjffjjg)
однако с RTF проблема не решена.
Можно конечно подставить знак *.* но тогда под раздачу люлей могут попасть не те файлы (например desktop.ini, thumb.db, а так же *pdf и html )
В итоге если файл вордом не откроется, то макрос выдаст ошибку и конвертация прекратится.
Отредактировано Godlatro (16.03.2011 16:04:52)
