Последние записи
- TChromium (CEF3), сохранение изображений
- Как в Delphi XE обнулить таймер?
- Изменить цвет шрифта TextBox на форме
- Ресайз PNG без потери прозрачности
- Вывод на печать графического файла
- Взаимодействие через командную строку
- Перенести программу из Delphi в Lazarus
- Определить текущую ОС
- Автоматическая смена языка (раскладки клавиатуры)
- Сравнение языков на массивах. Часть 2
Интенсив по Python: Работа с API и фреймворками 24-26 ИЮНЯ 2022. Знаете Python, но хотите расширить свои навыки?
Slurm подготовили для вас особенный продукт! Оставить заявку по ссылке - https://slurm.club/3MeqNEk
Online-курс Java с оплатой после трудоустройства. Каждый выпускник получает предложение о работе
И зарплату на 30% выше ожидаемой, подробнее на сайте академии, ссылка - ttps://clck.ru/fCrQw
8th
Сен
Макрос пакетной конвертации docx в doc
Posted by obzor under VBA, Софт
На борту 300 файлов в формате docx. Существует ли макрос, который умеет их пакетно конвертировать в doc? (у меня Word 2003 и он крайне медленно открывает docx’ы).
не смущает, что формат DOCX — это расширенный формат? В нём могут быть фишки, недоступные в DOC. (например, может «поплыть» разметка, оформление, шрифты и т.д.)
Вы пробовали взять несколько произвольных штук из ваших 300 и сконвертировать в DOC?
Всё сохранилось? Открывается быстро?
Сделайте копию своих документов и попробуйте, например, такой макрос:
Sub SaveAllFormData(path As String)
Dim doc As Document
Dim fileName As String
fileName = Dir(path & "*.docx")
' Loop through all .docx files in that path
Do While fileName <> ""
Set doc = Application.Documents.Open(path & fileName)
' Save form data
doc.SaveAs2 FileName:=doc.FullName & ".doc", FileFormat:= _
wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _
True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _
False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False, CompatibilityMode:=0
doc.Close wdDoNotSaveChanges
fileName = Dir
Loop
End Sub
Sub SaveAllFormData()
Dim doc As Document
Dim fileName As String
dim path as string: path = "c:\333\" ' смотрим папку 333 на Ц
fileName = Dir(path & "*.docx")
' Loop through all .docx files in that path
Do While fileName <> ""
Set doc = Application.Documents.Open(path & fileName)
' Save form data
doc.SaveAs2 FileName:=doc.FullName & ".doc", FileFormat:= _
wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _
True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _
False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False, CompatibilityMode:=0
doc.Close wdDoNotSaveChanges
fileName = Dir
Loop
End Sub
Sub SaveAllFormData()
Dim path As String: path = "c:\abc\" ' путь к папке с файлами
Call RecursiveDir(path, "*.docx", True)
End Sub
Public Function RecursiveDir(strFolder As String, _
strFileSpec As String, _
bIncludeSubfolders As Boolean)
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
Dim doc As Document
'Add files in strFolder matching strFileSpec to colFiles
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
' конвертация тут
Set doc = Application.Documents.Open(strFolder & strTemp)
' Save form data
ActiveDocument.SaveAs fileName:=doc.FullName & ".doc", FileFormat:= _
wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _
True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _
False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False
doc.Close wdDoNotSaveChanges
strTemp = Dir
Loop
If bIncludeSubfolders Then
'Fill colFolders with list of subdirectories of strFolder
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call RecursiveDir for each subfolder in colFolders
For Each vFolderName In colFolders
Call RecursiveDir(strFolder & vFolderName, strFileSpec, True)
Next vFolderName
End If
End Function
Public Function TrailingSlash(strFolder As String) As String
If Len(strFolder) > 0 Then
If Right(strFolder, 1) = "\" Then
TrailingSlash = strFolder
Else
TrailingSlash = strFolder & "\"
End If
End If
End Function
Похожие статьи
Купить рекламу на сайте за 1000 руб
пишите сюда - alarforum@yandex.ru
Да и по любым другим вопросам пишите на почту
пеллетные котлы
Пеллетный котел Emtas
Наши форумы по программированию:
- Форум Web программирование (веб)
- Delphi форумы
- Форумы C (Си)
- Форум .NET Frameworks (точка нет фреймворки)
- Форум Java (джава)
- Форум низкоуровневое программирование
- Форум VBA (вба)
- Форум OpenGL
- Форум DirectX
- Форум CAD проектирование
- Форум по операционным системам
- Форум Software (Софт)
- Форум Hardware (Компьютерное железо)