макрос для сжатия файлов doc

[caute]

Обратил внимание, что если конвертировать файл doc в новый формат docx, а затем этот docx обратно в doc, то размер итогового doc файла оказывается заметно (иногда в разы) меньше, чем у исходного. Возможно ли создать макрос, который выполнял бы эту двойную конвертацию для открытого документа? (а еще лучше - для всех файлов doc в выбранной папке, по типу макроса пакетной замены)

[garik64]

Сообщение от caute

Обратил внимание, что если конвертировать файл doc в новый формат docx, а затем этот docx обратно в doc, то размер итогового doc файла оказывается заметно (иногда в разы) меньше, чем у исходного.

doc: 174080
docx: 109866
doc: 173056

[viter.alex]

Можно попробовать, если это действительно нужно.

Private Declare Function GetTickCount Lib "kernel32" () As Long

Sub CompressDocs()
  

  If Val(Application.Version) < 12 Then Exit Sub 'Использовать только в Word 2007 и выше
  
  Dim sPath As String 'Путь к папке
  Dim sFileNameDoc As String 'Имя doc-документа
  Dim sFileNameDocx As String 'Имя docx-документа
  Dim SizeBefore As Long 'Размер до
  Dim SizeAfter As Long 'Размер после
  Dim TotalSizeBefore As Long 'Размер до общий
  Dim TotalSizeAfter As Long 'Размер после общий
  Dim n As Long 'Счётчик
  Dim time As Long 'Время работы
  Dim oDoc As Document 'Сам документ
  Dim FSO As Object
  
  Set FSO = CreateObject("Scripting.FileSystemObject")
  
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Укажите папку с файлами doc"
    If .Show Then sPath = .SelectedItems(1) Else Exit Sub
  End With
  time = GetTickCount
  sFileNameDoc = Dir(sPath & "\*.doc")
  
  Do While Len(sFileNameDoc) <> 0
    n = n + 1
    sFileNameDoc = sPath & "\" & sFileNameDoc
    sFileNameDocx = sFileNameDoc & "x"
    'Размер исходного файла в кб
    SizeBefore = FSO.GetFile(sFileNameDoc).Size / 1024
    TotalSizeBefore = TotalSizeBefore + SizeBefore
    'Открываем документ
    Set oDoc = Documents.Open(sFileNameDoc, AddToRecentFiles:=False)
    'Сохраняем документ в формат docx
    oDoc.SaveAs sFileNameDocx, wdFormatDocument, AddToRecentFiles:=False
    'Сохраняем документ обратно в формат doc
    oDoc.SaveAs sFileNameDoc, wdFormatDocument97, AddToRecentFiles:=False
    
    oDoc.Close
    
    'Размер пересохранённого файла в кб
    SizeAfter = FSO.GetFile(sFileNameDoc).Size / 1024
    TotalSizeAfter = TotalSizeAfter + SizeAfter
    'Удаляем документ docx
    Kill sFileNameDocx
    'чтобы не подвиснуть
    DoEvents
    'Читаем следующий файл
    sFileNameDoc = Dir
    'Записываем лог-файл
    Open sPath & "\comressing.log" For Append As #1
    Print #1, n & vbTab & sFileNameDoc & " Размер до: " & SizeBefore & "кб; Размер после: " & SizeAfter & "кб."
    Close #1
  Loop
  Set FSO = Nothing
    Open sPath & "\comressing.log" For Append As #1
    Print #1, "Пересохранение сэкономило " & TotalSizeBefore - TotalSizeAfter & " кб. дискового пространства"
    Print #1, "Прошло " & (GetTickCount - time) / 1000; " сек."
    Close #1
  'Открываем лог-файл
  Shell "notepad.exe """ & sPath & "\comressing.log" & """"
End Sub

Приложенный файл — шаблон, который нужно загрузить как надстройку. Появится дополнительная вкладка с кнопкой. Дальше всё понятно: выбираем каталог и ждём. После работы макроса откроется лог-файл с результатами. Можно будет наглядно посмотреть сколько мы выгадали.

[caute]

Простите, забыл сказать, что у меня Word 2003. Для более новых версий этот макрос, действительно, вряд ли нужен. Мне иногда попадают файлы, сохраненные, видимо, в режиме "быстрого сохранения" - текста внутри немного, а размер файла большой. Сжимаю их вручную, конвертируя в docx и обратно в doc.

[viter.alex]

Исправленный макрос:

Private Declare Function GetTickCount Lib "kernel32" () As Long

Sub CompressDocs()
  

  If Val(Application.Version) < 12 Then Exit Sub 'Использовать только в Word 2007 и выше
  
  Dim sPath As String 'Путь к папке
  Dim sFileNameDoc As String 'Имя doc-документа
  Dim sFileNameDocx As String 'Имя docx-документа
  Dim SizeBefore As Long 'Размер до
  Dim SizeAfter As Long 'Размер после
  Dim TotalSizeBefore As Long 'Размер до общий
  Dim TotalSizeAfter As Long 'Размер после общий
  Dim n As Long 'Счётчик
  Dim time As Long 'Время работы
  Dim oDoc As Document 'Сам документ
  Dim FSO As Object
  
  Set FSO = CreateObject("Scripting.FileSystemObject")
  
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Укажите папку с файлами doc"
    If .Show Then sPath = .SelectedItems(1) Else Exit Sub
  End With
  time = GetTickCount
  sFileNameDoc = Dir(sPath & "\*.doc")
  
  Do While Len(sFileNameDoc) <> 0
    n = n + 1
    sFileNameDoc = sPath & "\" & sFileNameDoc
    sFileNameDocx = sFileNameDoc & "x"
    'Размер исходного файла в кб
    SizeBefore = FSO.GetFile(sFileNameDoc).Size / 1024
    TotalSizeBefore = TotalSizeBefore + SizeBefore
    'Открываем документ
    Set oDoc = Documents.Open(sFileNameDoc, AddToRecentFiles:=False)
    'Сохраняем документ в формат docx
    oDoc.SaveAs sFileNameDocx, wdFormatXMLDocument, AddToRecentFiles:=False
    'Сохраняем документ обратно в формат doc
    oDoc.SaveAs sFileNameDoc, wdFormatDocument97, AddToRecentFiles:=False
    
    oDoc.Close
    
    'Размер пересохранённого файла в кб
    SizeAfter = FSO.GetFile(sFileNameDoc).Size / 1024
    TotalSizeAfter = TotalSizeAfter + SizeAfter
    'Удаляем документ docx
    Kill sFileNameDocx
    'чтобы не подвиснуть
    DoEvents
    'Читаем следующий файл
    sFileNameDoc = Dir
    'Записываем лог-файл
    Open sPath & "\comressing.log" For Append As #1
    Print #1, n & vbTab & sFileNameDoc & " Размер до: " & SizeBefore & "кб; Размер после: " & SizeAfter & "кб."
    Close #1
  Loop
  Set FSO = Nothing
    Open sPath & "\comressing.log" For Append As #1
    Print #1, "Пересохранение сэкономило " & TotalSizeBefore - TotalSizeAfter & " кб. дискового пространства"
    Print #1, "Прошло " & (GetTickCount - time) / 1000; " сек."
    Close #1
  'Открываем лог-файл
  Shell "notepad.exe """ & sPath & "\comressing.log" & """"
End Sub

[Sasha_Smirnov]

1	Эти глаза не лгут.docx Размер до: 10кб; Размер после: 22кб.
2	РЕД.docx Размер до: 11кб; Размер после: 22кб.
3	GetPrimes.doc Размер до: 11кб; Размер после: 23кб.
4	PrimeFactors.doc Размер до: 66кб; Размер после: 66кб.
5	Если хотите испытать.doc Размер до: 68кб; Размер после: 55кб.
6	Разборчивая .doc Размер до: 36кб; Размер после: 36кб.
7	Расплата.doc Размер до: 22кб; Размер после: 22кб.
8	Я не пишу о красоте природы.doc Размер до: 24кб; Размер после: 24кб.
9	 Размер до: 22кб; Размер после: 22кб.
Пересохранение сэкономило -22 кб. дискового пространства
Прошло 4,766 сек.

Только пересохранение 5-го файла принесло пользу. Но макрос замечательный!

Экономит само по себе редактирование с сохранением, где-то 1 раз из каждых 6-ти. Происходит какой-то внутренний «сброс» мусора. Как пример — 2 файла из поста Darkwinter (объём 2-го меньше, но текст программы в нём — больше: 4341 знак против 3921, т. е. на 10%).

Возможно, такое самоочищение происходит, допустим, когда «наросло» 20% мусора. Очень похоже на то.

Вот ещё раз пробую последний вариант (первый раз я его и пробовал, сохранив в Normal.dotm):

1	IsItPlan.doc Размер до: 66кб; Размер после: 66кб.
2	Mat.doc Размер до: 50кб; Размер после: 48кб.
3	NumFields.doc Размер до: 44кб; Размер после: 40кб.
4	NumLines.doc Размер до: 30кб; Размер после: 30кб.
5	PalindromBinOctDecHexPrimes.doc Размер до: 37кб; Размер после: 33кб.
6	Polygon.doc Размер до: 54кб; Размер после: 54кб.
7	PrimeQuantity.doc Размер до: 38кб; Размер после: 36кб.
8	 Размер до: 38кб; Размер после: 33кб.
Пересохранение сэкономило 17 кб. дискового пространства
Прошло 3,813 сек.

Теперь эффект очевиден, но этого же (пусть не так резко) я достигал и обычным пересохранением в формате DOC. Тот же IsItPlan.doc вчера занимал 49 килобайт, а не 66 — в посте Darkwinter тот вариант и прикреплён. Это он же, без ручных поправок! Так что возможны и неожиданные скачḱи вверх

[viter.alex]

Sasha_Smirnov, попробуй исправленный макрос.

[Sasha_Smirnov]

1	Расплата.doc Размер до: 22кб; Размер после: 22кб.
2	РЕД.doc Размер до: 24кб; Размер после: 24кб.
3	Что такое счастье.doc Размер до: 22кб; Размер после: 22кб.
4	Эти глаза не лгут.doc Размер до: 22кб; Размер после: 22кб.
5	Я не пишу о красоте природы.doc Размер до: 22кб; Размер после: 22кб.
6	 Размер до: 22кб; Размер после: 22кб.
Пересохранение сэкономило 0 кб. дискового пространства
Прошло 1,875 сек.

Эти 5 файлов созданы были в формате DOCX. Может, потому и экономия 0. И ещё их пришлось восстанавливать.

[Вождь]

Когда я пишу макросы в Normal.dot он разрастается в 2-3 раза.

Помогает следующая процедура:
- копируем Normal.dot из папки с шаблонами в «Мои документы»
- меню «Файл» > пункт «Открыть» > файл «Мои документы\Normal.dot»
- Alt+F11 (Visual Basic) > меню «Debug» > пункт «Compile»
- закрываем Visual Basic > закрываем Word с сохранением Normal.dot

На днях таким макаром я ужал Normal.dot с 10 Мб до 4 Мб.

[caute]

Сообщение от Вождь

На днях таким макаром я ужал Normal.dot с 10 Мб до 4 Мб.

а у меня, наоборот, normal.dot после этой операции вырос с 1264 kb до 2040 kb. Кому как везет :0)
При этом, в ходе дебага обнаружилось 4 штуки Compile errors (в макросах, которые отлично работают и написаны гигантами VB'шной мысли). Интересные пирожки...