Всем привет! Через ком-объект делаю документ, сохраняю его как docx. Проблема в том что в нем много картинок и файлик на выходе получается большой. Если интерактивно сохранять документ, то там есть кнопочки в подменю "Сжатие рисунков":
https://www.dropbox.com/s/p0kzjul8gf4rrj3/картинка1.png?dl=0
https://www.dropbox.com/s/pyancv8goml2qc5/картинка2.png?dl=0

Как достучаться до этих методов программно?

1). Начать запись макроса.
2). Сделать всё вручную.
3). Остановить запись макроса.
4). Скопипастить и подкорректировать.
5). Отхлебнуть чая, откусить булку.

(1) 5. повторять пока не получится...

(1) Черт, я про макросы забыл. Спасибооооо!

достал попкорн

(4) Ага, нифига не взлетает.

Получил макрос
ChangeFileOpenDirectory "C:\Users\odubrovin\AppData\Local\Temp\"
    ActiveDocument.SaveAs2 FileName:="????? ?.?. ??????? ????222.docx", _
        FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _
        AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
        EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
        :=False, SaveAsAOCELetter:=False, CompatibilityMode:=14

Выполняю его - все хорошо, все сжимается.
Продублировал для 1С:

ПутьКФайлу = КаталогВременныхФайлов()+РаботаСФайлами.УдалитьЗапрещенныеСимволыИмени(Строка(Контрагент))+".docx";
NewDoc.SaveAs2(ПутьКФайлу, 12, False, "", True, "", False,False, False, False, False, 14);

(5)+ Все равно получается как и раньше несжатый файл.

(6) А где код вызова макроса?
Я чет заметил только запись :)

не ловится макросом это <....> сжатие (

2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31

    

Sub BatchCompress()
  
  dirpath = "С:\Temp\"                                          'целевой каталог
  driveletter = Left(dirpath, 1)                                'диск
  ChDrive driveletter                                           'устанавливаем диск
  ChDir dirpath                                                 'устанавливаем путь
  cmd = " /c dir *.doc /s /b > dir.txt"                         'формируем строку для dir
  Shell Environ$("comspec") & cmd, vbHide                       'получаем список doc-файлов

  MsgBox "Dir List Created!"

  dirfile = dirpath & "dir.txt"                                 'путь к списку файлов (DOS CP866)
  Set dirlist = Documents.Open(dirfile, , , , , , , , , , msoEncodingOEMCyrillicII) 'открываем список
  For i = 1 To dirlist.Paragraphs.Count                         'перебираем строки списка
    With dirlist.Paragraphs(i).Range            
      fn = .Text
      fn = Replace(fn, vbCr, "")                                'удаляем CR/LF
      fn = Replace(fn, vbLf, "")
      Set od = Documents.Open(fn)                               'открываем doc-файл
      SendKeys "оп~"                                            'устанавливаем опции компрессии
      od.Application.CommandBars.ExecuteMso "PicturesCompress"  'выполняем сжатие рисунков
      od.Save                                                   'сохраняем файл
      od.Close                                                  'закрываем файл
    End With
  Next

  MsgBox "Compressing Finished!"

  dirlist.Close                                                 'закрываем список файлов
  
End Sub

Смотреть туда http://www.cyberforum.ru/ms-word/thread520208.html

(10) это для 2003-го наверно
в 2010 поменяли все

к сожалению так и не победил программное сжатие
более менее сжимает если в бинарный вариант сохранять

(10) Я так и сделал кстати.
(11) В 2010 тоже работает, правда показывает диалоговое окно, которое я побороть не смог.

(13)+ для потомков
WordApplication.CommandBars.ExecuteMso("PicturesCompress");

вернемся к теме таки кто нить победил полностью программное сжатие картинок на 2010 офисе?

пишу простой код

Sub BatchCompress()
Dim od As Workbook

      Set od = Workbooks.Open("C:\Прайсы\2\Образец.xls")
      SendKeys "оИ~"                                            'устанавливаем опции компрессии
      od.Application.CommandBars.ExecuteMso "PicturesCompress"  'выполняем сжатие рисунков
      od.Save                                                   'сохраняем файл
      od.Close                                                  'закрываем файл
  
End Sub

и нифига не сжимает в 2010
открывает тупит но результата нет
даже окно сжатия вроде как открывается но ....

(16) Ваш вариант, Данила?

пока нет варианта - просто народ пишет что решение есть, но пока не вижу (

(18) Может оно сжимает BMP, а вы еще раз JPG сжать пытаетесь :)

(18) Так то вариант есть. Разобрать файл, сжать картинки. И собрать его обратно :)

может проще самому сжать до ставки в ворд, чтоб наверняка

юзать имэйдж мэджик

А в макросе то какая функция?

(23) А в макросе это не записывалось.

(16) У меня окно было доступно - и при максимальном варианте сжималось с 36 мегов до 2.9. Все картинки изначально в jpg конечно.

(21) Скорей всего, тогда придется нанимать сжимальщика. Либо работать по сжатию файлов Word на той же ставке :)

если вручную сжать то сжимает будь здоров

(23) Её нет. 1С не соизволила сей момент автоматизировать :)

(28) Чуть что - сразу 1С виновата?)

(27) Вот оно как. Т.е. если сжатие и есть, то выполняется оно под другой команде :)

еще заметил, что нумлок на клаве отключается после макроса
странно

(29) А ведь, что за мание преследования. Сколько версий клиента 1С. И ни в одной нет функции "Пайза" (Sleep)

Я имел ввиду, что если записать макрос на сжатие, а потом посмотреть его одержимое, то что там внутри?

попробуй )

Я попробуй?????

Да пустой макрос будет, чем вы слушаете?

сам спрашиваешь сам и попробуй

(35) Мы уже попробовали. Если вы соизволите прочесть весь пост, то поймете, что из этого вышло :)

Нашел интересный вариант.

http://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=8&TID=18073

Sub Compress_PIX()

Dim octl As CommandBarControl

With Selection
Set octl = Application.CommandBars.FindControl(ID:=6382)

Application.SendKeys "{TAB}"
Application.SendKeys "{UP}"
Application.SendKeys "~"
octl.Execute
End With

End Sub

это 2003-й офис