Excel to jpg

[Acro]

1. Делаю скрин диапазона
2. Вставляю картинку в лист
3. Через контекстное меню сохраняю как *.jpg

Sub inFail()
Dim str As String, strFiNa As String, strShNa As String, MyH As Long, MyW As Long
Dim SStime As Long
    str = ActiveSheet.Name
    If TypeName(Selection) = "Picture" Then
        strFiNa = Application.GetSaveAsFilename(InitialFileName:="Table", FileFilter:="GIF file,*.gif,JPG file,*.jpg")
        If strFiNa = "False" Then Exit Sub
        MyH = Selection.Height
        MyW = Selection.Width
        Selection.Copy
        Charts.Add
        ActiveChart.Location Where:=xlLocationAsObject, Name:=str
        strShNa = ActiveChart.Name
        strShNa = Trim(Replace(strShNa, str, vbNullString))
        ActiveSheet.Shapes(strShNa).Height = MyH * 1.01
        ActiveSheet.Shapes(strShNa).Width = MyW * 1.01
        DoEvents
        ActiveChart.Paste
        ActiveChart.Export Filename:=strFiNa, FilterName:=Right(strFiNa, 3)
        ActiveSheet.Shapes(strShNa).Delete
    End If
End Sub

Не устраивает качество получаемого файла. Нельзя как то программно связать Excel mspaint.exe?

[valerij]

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

1. Делаю скрин диапазона
Не устраивает качество получаемого файла.

Добавь расширение .rar:
Будет выглядеть так:
имя.jpg.rar

При просмотре удаляется .rar и смотрится с отличным качеством.

[Acro]

Как то не выходит. Разницы не вижу

[valerij]

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

Как то не выходит. Разницы не вижу

Наверное я тебя не понял, я подумал, что на форум прикрепить не можешь

[EducatedFool]

Используйте для копирования диапазона такой код:

Range("B18:C39").CopyPicture Appearance:=xlScreen, Format:=xlPicture

Вместо B18:C39 укажите нужный диапазон ячеек

Этот код помещает "скрин" диапазона ячеек в буфер обмена.
Потом вставляйте рисунок в любой графический редактор (тот же Paint)
Качество вроде приличное.

Здесь есть информация по теме.

[Acro]

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

Используйте для копирования диапазона такой код:

Range("B18:C39").CopyPicture Appearance:=xlScreen, Format:=xlPicture

Вместо B18:C39 укажите нужный диапазон ячеек

Этот код помещает "скрин" диапазона ячеек в буфер обмена.
Потом вставляйте рисунок в любой графический редактор (тот же Paint)
Качество вроде приличное.

Здесь есть информация по теме.

Копирование нужного диапазона в скрипте я уже реализовал, почитав msdn:

Sub RangeToScreen()
Worksheets("1").Range("A1:AK39").CopyPicture xlScreen, xlBitmap
Worksheets("img").Paste _
    Destination:=Worksheets("img").Range("D2")
End Sub

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

За ссылку спасибо, по задачам схожее, но принципиально отличное решение.

[EducatedFool]

Попробуйте в строке
Worksheets("1").Range("A1:AK39").Co pyPicture xlScreen, xlBitmap

заменить xlBitmap на xlPicture
В таком случае картинка копируется в буфер обмена в векторном формате

[КаМММ]

заменить xlBitmap на xlPicture
В таком случае картинка копируется в буфер обмена в векторном формате

Работает и так и так но разницы не прочувствовал.
(Изображение в Ирфан выгружал - совпадает до пикселя)

[Acro]

Соверешенно верно разницы нет. На форумах msdn нашел код экспорта идельного качества jpeg. 1.9 Mb на выходе 1:1 через ОЛЕ. Как, уже, уменьшить программно получаемое качество не разобрался. Остановился на модификации вышеуказанного варианта.
Но там есть баг, повторяемость не отловил - иногда размер xls начинает расти после экспорта, хотя внешне в файле ничего не появилось нового. Остатки буфера что ли...

[КаМММ]

А у экселя я тоже заметил такой глюк.

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

У меня есть файл с макросами и формами (используется в качестве программы для расчёта стоимости воздуховодов, начисления зарплаты жестянщикам, списания металла, короче наворочено жуть сколько)
Если файл открыть отключив макросы и закрыть, то он спрашивает "сохранять ли изменения?" даже если изменений не делать.
После такого "сохранения" файл "худеет" с 1,3 Мб до 1 Мб
Иногда больше иногда меньше но процентов на двадцать.
если открыть с макросами и снова закрыть с сохранением то опять толстеет.
Причём иногда бывает что "Толстый файл" при запуске "Глючит"
"Худой" не глючит никогда.
Ps Офис 2003