Привет!

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

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

 

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 мая, 20215 г. пользователем Эльдар Надирович

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

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

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

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

 

 

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

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

 

 

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

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 мая, 20215 г. пользователем SergioJek

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

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

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

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

 

 

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

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

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

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

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

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

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 мая, 20215 г. пользователем SergioJek

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

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

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 

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

 

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