Как уменьшить разрешение скриншота?

[Anton 459]

Привет!

Уважаемые прогеры, этот всем известный макрос делает скриншот листа.

Можно в нём как-нибудь задать разрешение этого скриншота, а то когда этих картинок набирается несколько сотен, то папка начинает весить несколько гигов? Не чтобы сильно критично, но всё же)

 

Sub Range_to_Picture()
    Dim sName As String, nName As String, dName As String, wsTmpSh As Worksheet
    nName = Range("AO1").Value
    dName = Range("K2").Value
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Range("A1:AG38").Select
    With Selection
        .CopyPicture
        Set wsTmpSh = ThisWorkbook.Sheets.Add
        sName = ActiveWorkbook.FullName & "_" & Format(dName, "dd/mm/yy hh mm") & "_" & nName
        With wsTmpSh.ChartObjects.Add(0, 0, .Width, .Height).Chart
            .ChartArea.Border.LineStyle = 0
            .Parent.Select
            .Paste
            .Export Filename:=sName & ".jpg", FilterName:="JPG"
            .Parent.Delete
        End With
    End With
    wsTmpSh.Delete
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Range("A1").Select
End Sub

 

 

Изменено 11 мая, 2021 пользователем Эльдар Надирович

[Farel 1 146]

Если эта программа по ставкам, то советую забить на скриншоты и начать работать по архивам. Это в 50-100 раз ускорит поиск прибыльных систем. Если нет, то ждите ответ от спецов по коду.

[Anton 459]

4 минуты назад, Farel сказал:

Если эта программа по ставкам, то советую забить на скриншоты и начать работать по архивам. Это в 50-100 раз ускорит поиск прибыльных систем. Если нет, то ждите ответ от спецов по коду.

имхо работа только по архивам это путь в никуда, плавали, знаем, но вам в этом ещё предстоит убедиться) 

 

 

[Farel 1 146]

Только что, Эльдар Надирович сказал:

имхо работа только по архивам это путь в никуда, плавали, знаем, но вам в этом ещё предстоит убедиться) 

 

 

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

[SergioJek 2 110 475]

16 минут назад, Эльдар Надирович сказал:

Привет!

Уважаемые прогеры, этот всем известный макрос делает скриншот листа.

Можно в нём как-нибудь задать разрешение этого скриншота, а то когда этих картинок набирается несколько сотен, то папка начинает весить несколько гигов? Не чтобы сильно критично, но всё же)

 

Sub Range_to_Picture()
    Dim sName As String, nName As String, dName As String, wsTmpSh As Worksheet
    nName = Range("AO1").Value
    dName = Range("K2").Value
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Range("A1:AG38").Select
    With Selection
        .CopyPicture
        Set wsTmpSh = ThisWorkbook.Sheets.Add
        sName = ActiveWorkbook.FullName & "_" & Format(dName, "dd/mm/yy hh mm") & "_" & nName
        With wsTmpSh.ChartObjects.Add(0, 0, .Width, .Height).Chart
            .ChartArea.Border.LineStyle = 0
            .Parent.Select
            .Paste
            .Export Filename:=sName & ".jpg", FilterName:="JPG"
            .Parent.Delete
        End With
    End With
    wsTmpSh.Delete
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Range("A1").Select
End Sub

 

 

PNG попробуй поставить вместо JPG

Изменено 11 мая, 2021 пользователем SergioJek

[Anton 459]

2 минуты назад, SergioJek сказал:

PNG попробуй поставить вместо JPG

А он почему-то  и так сохраняет в png) поменял, но эффект, тот же.
Мне кажется в этом месте можно задать разрешение:
 

With wsTmpSh.ChartObjects.Add(0, 0, .Width, .Height).Chart

 

 

[Anton 459]

5 минут назад, Farel сказал:

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

блин, Фарель вот даже ведь не знаешь для чего мне скриншоты и все равно пытаешься продать свою "чудо" прогу, но продолжай, это веселит)  

[Farel 1 146]

1 минуту назад, Эльдар Надирович сказал:

блин, Фарель вот даже ведь не знаешь для чего мне скриншоты и все равно пытаешься продать свою "чудо" прогу, но продолжай, это веселит)  

Я ничего не пытаюсь продать. Даю дельный совет. Скинь скрин посмотреть хоть, что там такое на нем, что нельзя скинуть в архив? Если я смог даже графики закинуть в свой архив. И после нашел сотни прибыльных алгоритмов. А на скринах ничего этого не было видно.

[SergioJek 2 110 475]

8 минут назад, Эльдар Надирович сказал:

А он почему-то  и так сохраняет в png) поменял, но эффект, тот же.
Мне кажется в этом месте можно задать разрешение:
 

With wsTmpSh.ChartObjects.Add(0, 0, .Width, .Height).Chart

 

 

With Range("B2:F3")

        .CopyPicture

        Set wsTmpSh = ThisWorkbook.Sheets.Add

        sName = ActiveWorkbook.FullName & "_" & ActiveSheet.Name & "_Range"

        With wsTmpSh.ChartObjects.Add(0, 0, .Width, .Height).Chart

            .ChartArea.Border.LineStyle = 0

            .Parent.Select

            .Paste

            .Export Filename:=sName & ".gif", FilterName:="GIF"

            .Parent.Delete

        End With

    End With

Можно еще так поиграться

ChartObjects.Add(50, 40, 200, 100)

Изменено 11 мая, 2021 пользователем SergioJek

[SergioJek 2 110 475]

http://starik2222.narod.ru/ppp/lec/24.htm

Это первое что дал поиск по синтаксису

[Anton 459]

5 минут назад, SergioJek сказал:

With Range("B2:F3")

        .CopyPicture

        Set wsTmpSh = ThisWorkbook.Sheets.Add

        sName = ActiveWorkbook.FullName & "_" & ActiveSheet.Name & "_Range"

        With wsTmpSh.ChartObjects.Add(0, 0, .Width, .Height).Chart

            .ChartArea.Border.LineStyle = 0

            .Parent.Select

            .Paste

            .Export Filename:=sName & ".gif", FilterName:="GIF"

            .Parent.Delete

        End With

    End With

 

Вот если тут задать размеры, то норм работает
было

With wsTmpSh.ChartObjects.Add(0, 0, .Width, .Height).Chart

стало

With wsTmpSh.ChartObjects.Add(0, 0, 1200, 528).Chart 

[Anton 459]

Всем спасибо, вроде разобрался, может кому нужно, вот:

 

Sub Range_to_Picture()
    Dim sName As String, nName As String, dName As String, wsTmpSh As Worksheet
    nName = Range("AO1").Value
    dName = Range("K2").Value
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Range("A1:AG38").Select
    With Selection
        .CopyPicture
        Set wsTmpSh = ThisWorkbook.Sheets.Add
        sName = ActiveWorkbook.FullName & "_" & Format(dName, "dd/mm/yy hh mm") & "_" & nName
        With wsTmpSh.ChartObjects.Add(0, 0, 1920, 1080).Chart                                                                       'тут поменял разрешение
            .ChartArea.Border.LineStyle = 0
            .Parent.Select
            .Paste
            .Export Filename:=sName & ".jpg", FilterName:="JPG"
            .Parent.Delete
        End With
    End With
    wsTmpSh.Delete
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Range("A1").Select
End Sub