Сохранение скриншота в excel

[dmiry74]

Может кто подскажет, как решить проблему сохранения скриншота диапазона ячеек в формате jpg. Вчера после нескольких часов копания форумов и экспериментирования получилось сделать сохранение в формате emf... а в jpg вообще никак не получается...(((


Использую такой код:

Private Sub CommandButton1_Click()
Worksheets("Лист1").Range("A1:H20") .CopyPicture xlScreen, Format:=xlBitmap
Set oPic = PastePicture(xlScreen)
SavePicture oPic, "C:\" & Replace(Time, ":", "_") & ".jpg"
End Sub


Function PastePicture(Optional lXlPicType As Long = xlBitmap) As IPicture
'Some pointers
Dim h As Long, hPicAvail As Long, hPtr As Long, hPal As Long, lPicType As Long, hCopy As Long
'Convert the type of picture requested from the xl constant to the API constant
lPicType = IIf(lXlPicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)
'Check if the clipboard contains the required format
hPicAvail = IsClipboardFormatAvailable(lPicType )
If hPicAvail <> 0 Then
'Get access to the clipboard
h = OpenClipboard(0&)
If h > 0 Then
'Get a handle to the image data
hPtr = GetClipboardData(lPicType)
'Create our own copy of the image on the clipboard, in the appropriate format.
If lPicType = CF_BITMAP Then
hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
Else
hCopy = CopyEnhMetaFile(hPtr, vbNullString)
End If
'Release the clipboard to other programs
h = CloseClipboard
'If we got a handle to the image, convert it into a Picture object and return it
If hPtr <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, lPicType)
End If
End If

Если кто в курсе, как сделать - подскажите пожалуйста! Работоспособный файл с сохранением в emf прилагается.

Cкриншоты.zip

[doober]

Sub RngToJPG()
    Dim rng As Range, oChart As ChartObject
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Set rng = Range("A1:D10")
    With rng
        .CopyPicture
        Set oChart = ActiveSheet.ChartObjects.Add(.Left, .Top, .Width, .Height)
        With oChart.Chart
            .ChartArea.Border.LineStyle = 0
            .Paste
            .Export "C:\Pic1.jpg"
            .Parent.Delete
        End With
    End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

[dmiry74]

Ого! Спасибо огромное, отлично работает! Вы просто волшебник!

Один только вопрос - справа и снизу скриншота появляется широкая белая полоса... от нее можно избавиться?

[doober]

Она идет по периметру.
Вы же получаете картинку диаграммы.
От нее не избавитесь

[ikki_pf]

среди приложений MSOffice сохранять вставленные картинки в формате jpg умеет MS PowerPoint

если макрос doober'а в Excel'e оставить в таком виде:

Sub RngToJPG()
    Dim rng As Range, oChart As ChartObject
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Set rng = Range("A1:D10")
    rng.CopyPicture
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

затем открыть PP, вставить картинку из буфера и сохранить в jpg, то макрорекодер PP даёт примерно такой код:

Sub Макрос1()
  ActiveWindow.View.Paste
  ActiveWindow.Selection.Unselect
  ActiveWindow.Selection.SlideRange.Shapes("Picture 5").Select
  ActivePresentation.SaveAs FileName:="D:\Рисунок1.jpg", FileFormat:=ppSaveAsJPG, EmbedTrueTypeFonts:=msoFalse
End Sub

но у меня не получилось "соединить" эти два фрагмента

что-то вроде

Sub RngToJPG()
    Dim rng As Range, oChart As ChartObject, ppApp As Object

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Set rng = Range("A1:D10")
    rng.CopyPicture
    Set ppApp = CreateObject("PowerPoint.Application")
    Set x = ppApp.Presentations.Add
    Set y = x.Slides.Add(1, ppLayoutBlank)
    With ppApp.ActiveWindow
      .View.Paste
      .SlideRange.Shapes(1).SaveAs Filename:="D:\123.jpg", FileFormat:=ppSaveAsJPG, EmbedTrueTypeFonts:=msoFalse
    End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

ругается нехорошими словами ("Application.ActiveWindow : Invalid request. There is no currently active document window") на строку с With

что я делаю неправильно?

[ikki_pf]

вот так отрабатывает без ругани. но результат совершенно другой

Sub RngToJPG()
    Dim rng As Range, oChart As ChartObject, ppApp As Object

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Set rng = Range("A1:D10")
    rng.CopyPicture
    Set ppApp = CreateObject("PowerPoint.Application")
    ppApp.Visible = True
    Set x = ppApp.Presentations.Add
    Set y = x.Slides.Add(1, ppLayoutBlank)
    y.Shapes.Paste.Select
    x.SaveAs Filename:="D:\123.jpg", FileFormat:=ppSaveAsJPG, EmbedTrueTypeFonts:=msoFalse
    ppApp.Quit
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

[ikki_pf]

вывод: макрорекодер PowerPoint'а нагло врёт

сохранение отдельного рисунка (пункт "Сохранить как рисунок") контекстного меню рисунка НЕ ИМЕЕТ аналога в объектной модели PP.
у объекта Shape нет даже отдаленно похожего метода, а метод SaveAs объекта Presentation приводит к созданию папки с указанным именем (без расширения) и набором jpg-файлов, каждый из которых представляет целиком слайд.

вот так-то.

[EducatedFool]

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

вот так отрабатывает без ругани. но результат совершенно другой

...
    x.SaveAs Filename:="D:\123.jpg", FileFormat:=ppSaveAsJPG, EmbedTrueTypeFonts:=msoFalse
   ...

вывод: макрорекодер PowerPoint'а нагло врёт

Знаете, что меня смущает?
Вы создаёте экземпляр объекта ppApp через CreateObject, что неявно, но подразумевает отсутствие ссылки на PowerPoint в Tools-References.
В то же время, в коде вы используете константы PowerPoint (например, ppSaveAsJPG), забыв заменить из значениями.

Если ссылки на PowerPoint в Tools-References нет, то Excel не знает, чему равно ppSaveAsJPG, и из-за этого код может работать неверно.

Может, макрорекодер PowerPoint'а всё-таки не врёт, а кто-то при переносе кода чего-то напутал? ))

[ikki_pf]

да всё может быть...
но ссылка в референсах есть.

[ikki_pf]

ну вот, заменил позднее связывание на раннее:

Dim rng As Range, oChart As ChartObject, ppApp As New PowerPoint.Application

легче не стало