выгрузка картинок из файла excel

[Monro]

добрый день
стоит задача выгружать картинки из экселевских файлов. в одном файле от 50 до 350 картинок, самих файлов количество тоже идет к сотне, по одной картинке выковыривать тупой работы очень много.
на просторах сети нашел макрос который позволяет выгружать все картинки из файла и что славно приссваивает им имена из соседних ячеек (т.е. можно не только порядковые номера получить что важно, но и например названия артикулов), но есть одна беда - качество картинок в папке плохое. пытался альтернативными методами выковыривать картинки (сохранять как веб-страницу, открывать как архив) но и там качество подубитое. обнаружил что excel в отличии от openoffica сжимает изображения и даже отключение этой функции не помогает. а найти аналогичный макрос для OO не удалось, а сам я не программист ни разу.

может кто сможет подсказать как бороться со сжатием изображений в экселевских файлах?

[Serge_Bliznykov]

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

может кто сможет подсказать как бороться со сжатием изображений в экселевских файлах?

погодите, давайте мухи отдельно, котлеты отдельно.

если Вы сохраняете

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

по одной картинке выковыривать тупой работы очень много

тогда качество нормальное?

если нет, то тогда о чём речь? Если картинки хранятся внутри в плохом виде, то никакой макрос чуда не сделает и качество не улучшит. Это из хорошего качества можно сделать плохое, а наоборот, к сожалению, нельзя!

[Monro]

если по одной вынимать, то качество нормальное. копировать, вставить в графический редактор - сохранить. т.е. те картинки которые в экселевском файле они в хорошем качестве, но если этот же экселевский файл открыть как архив и доставать картинки они будут в среднем качестве (не так плохо как от скрипта, но и не так хорошо как должно быть), а если сохранить скриптом то качество будет вообще отвратительное.

я немного поэксперементировал и сохранил таблицу в ods, открыл ее как архив извлек картинки и они в превосходном качестве. теперь единственная проблема как присвоить им имена в соответствии с их ячейками.
новый ods файл даже получился -чутьчуть меньше чем xlsx, но картинки в хорошем качестве. что меня убеждает в том что проблемы скачеством это специфика excel

[Monro]

может подкрепить примеры получившихся картинок для наглядности?

[Monro]

прилагаю картинки.
в экселе нашел в настройках отключение сжатия для конкретных файлов и теперь если как из архива вынимаются в нормальном качестве, но макросу это не помогло.

еще немного поэкспериментировав заметил что если растянуть картинку в экселе внутри ячейки то скрипт сохранит в более высоком разрешении. получается он делакт как бы серию минискриншотов - насколько картинка увеличена настолько и качественный результат. значит теперь нужен макрос на то чтобы увеличить все картинки в файле и соответственно ячейки в которых они сидят.

и нужен будет третий макрос который будет запускать предыдущие два)

[Serge_Bliznykov]

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

может подкрепить примеры получившихся картинок для наглядности?

можно.
а ещё надо прикрепить архив с исходным XLS файлом (несколько картинок в файле будет вполне достаточно для анализа)

[Monro]

оставил в файле минимум информации, мало ли где там коммерческая тайна начинается, прилагаю
макрос в первом посте прикреплен

[Serge_Bliznykov]

Ужасно КРИВОЙ код.
на тестовом примере вроде как работает.

Картинки сохраняет в папку "D:\PICTURES\" (см. в код)

ВНИМАНИЕ! В процессе работы похабит картинки на листе (изменяет им размер).
поэтому файл после работы макроса сохранять НЕ РЕКОМЕНДУЕТСЯ!!
А лучше вообще с копией запускать.

макрос:

Sub SavePicture_Main()
   Dim oShape As Shape, oSh As Shape, strImageName As String
   Dim oDia As Object, oChartArea As Object
   Dim sh As Worksheet: Set sh = ActiveSheet    ' лист с картинками
   Dim count As Long: count = 0
   Application.ScreenUpdating = False
    
   On Error Resume Next


   For Each oShape In ActiveSheet.Shapes
        strImageName = ActiveSheet.Cells(oShape.TopLeftCell.Row, 1).Value
        'oShape.Select ' Err.Clear
        
        Set oSh = oShape

        'Picture size to ORIGINAL
        oSh.ScaleHeight Factor:=1, RelativeToOriginalSize:=msoTrue
        
        oSh.Copy
        Set oDia = ActiveSheet.ChartObjects.Add(0, 0, oShape.Width, oShape.Height)
        Set oChartArea = oDia.Chart
        oDia.Activate
        With oChartArea
            .ChartArea.Select
            .Paste
            .Export ("D:\PICTURES\" & strImageName & ".jpg")
        End With
        count = count + 1
        
        oDia.Delete 'oChartArea.Delete

        'Picture size to small
        oSh.ScaleHeight Factor:=0.03, RelativeToOriginalSize:=msoTrue, Scale:=msoScaleFromTopLeft
        
        Err.Clear
   Next
    
   Application.ScreenUpdating = True
   
   MsgBox "Готово! Всего обработано изображений: " & CStr(count)
   
   MsgBox "ВНИМАНИЕ!! Размер всех картинок на листе был изменён! НЕ СОХРАНЯЙТЕ ТЕКУЩУЮ КНИГУ!!!"
    
End Sub

[AlexM12]

Я извлекаю картинки без макросов.
1. Открыть файл.
2. Сохранить как "Веб-страница(*.htm;*.html)
3. В папке с файлом появится папка, в которой сохранились все картинки.

[Monro]

Serge_Bliznykov
огромное Вам, человеческое, спасибо! вроде все работает буду тестить на других файлах

2 AlexM12
я пробовал так делать но
во-первых тоже херится качество картинок
во-вторых в папке появляются как превьюшки так и сами картинки отобрать нужное отфильтровав по размеру например не всегда удается, в 10% случаев приходится потом вручную сверять с исходным файлом, экологичнее уж открыть как архив файл xlsx
в-третьих это порядочно возни

еще пробовал сохранять как веб-страницу ods, но тогда картинкам присваиваются рандомные имена и сверять их с исходным файлом приходится опять вручную