Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Сохранение некоторых фигур - как jpg в отдельные папки - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Сохранение некоторых фигур - как jpg в отдельные папки (Макросы/Sub)
Сохранение некоторых фигур - как jpg в отдельные папки
dmitrijaltman8 Дата: Четверг, 16.12.2021, 17:26 | Сообщение № 1
Группа: Пользователи
Ранг: Участник
Сообщений: 61
Репутация: 0 ±
Замечаний: 20% ±

2016
Здравствуйте.
Помогите изменить макрос.

На листах файла эксель расставлены группы фигур.

Подскажите - как макросом сохранить их как jpg - в отдельные папки (соответствующие названиям листов) ?
Нужно сохранить все фигуры, кроме тех у которых в названии есть слова "овал", "прямоугольник" или "линия".

Нужно обойти листы, на каждом обойти все фигуры, если группировка .type=msoGroup, то рекурсивно углубляться до единичной, проверить имя и если не из списка исключений записать .SaveAsPicture по сформированному пути . Имя листа или передавать или в глобальной держать.
For Each .... For Each ...... if ... .type=.type=msoGroup then ..... ....

Вот похожий образец:
[vba]
Код

Sub Save_Object_As_Picture()
    Dim avFiles, li As Long, oObj As Object, wsSh As Worksheet, wsTmpSh As Worksheet
    Dim sImagesPath As String, sBookName As String, sName As String
    Dim wbAct As Workbook
    Dim IsForEachWbFolder As Boolean
  
    avFiles = Application.GetOpenFilename("Excel Files(*.xls*),*.xls*", , "Выбрать файлы", , True)
    If VarType(avFiles) = vbBoolean Then Exit Sub
  
    IsForEachWbFolder = (MsgBox("Сохранять картинки каждой книги в отдельную папку?", vbQuestion + vbYesNo, "www.excel-vba.ru") = vbYes)
  
    If Not IsForEachWbFolder Then
        sImagesPath = Environ("userprofile") & "\desktop\images\" '"
        If Dir(sImagesPath, 16) = "" Then
            MkDir sImagesPath
        End If
    End If
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set wsTmpSh = ThisWorkbook.Sheets.Add
    For li = LBound(avFiles) To UBound(avFiles)
        Set wbAct = Workbooks.Open(avFiles(li), False)
        'создаем папку для сохранения картинок
        If IsForEachWbFolder Then
            sImagesPath = wbAct.Path & "\" & wbAct.Name & "_images\"
            If Dir(sImagesPath, 16) = "" Then
                MkDir sImagesPath
            End If
        End If
        sBookName = wbAct.Name
        For Each wsSh In Sheets
            For Each oObj In wsSh.Shapes
                If oObj.Type = 13 Then
                    '13 - картинки
                    '1 - автофигуры
                    '3 - диаграммы
                    oObj.Copy
                    sName = ActiveWorkbook.Name & "_" & wsSh.Name & "_" & oObj.Name
                    With wsTmpSh.ChartObjects.Add(0, 0, oObj.Width, oObj.Height).Chart
                        .ChartArea.Border.LineStyle = 0
                        .Parent.Select
                        .Paste
                        .Export Filename:=sImagesPath & sName & ".jpg", FilterName:="JPG"
                        .Parent.Delete
                    End With
                End If
            Next oObj
        Next wsSh
        wbAct.Close 0
    Next li
    Set oObj = Nothing: Set wsSh = Nothing
    wsTmpSh.Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Объекты сохранены", vbInformation, "www.excel-vba.ru"
End Sub
[/vba]
К сообщению приложен файл: 4429141.xlsb(16.4 Kb)
 
Ответить
СообщениеЗдравствуйте.
Помогите изменить макрос.

На листах файла эксель расставлены группы фигур.

Подскажите - как макросом сохранить их как jpg - в отдельные папки (соответствующие названиям листов) ?
Нужно сохранить все фигуры, кроме тех у которых в названии есть слова "овал", "прямоугольник" или "линия".

Нужно обойти листы, на каждом обойти все фигуры, если группировка .type=msoGroup, то рекурсивно углубляться до единичной, проверить имя и если не из списка исключений записать .SaveAsPicture по сформированному пути . Имя листа или передавать или в глобальной держать.
For Each .... For Each ...... if ... .type=.type=msoGroup then ..... ....

Вот похожий образец:
[vba]
Код

Sub Save_Object_As_Picture()
    Dim avFiles, li As Long, oObj As Object, wsSh As Worksheet, wsTmpSh As Worksheet
    Dim sImagesPath As String, sBookName As String, sName As String
    Dim wbAct As Workbook
    Dim IsForEachWbFolder As Boolean
  
    avFiles = Application.GetOpenFilename("Excel Files(*.xls*),*.xls*", , "Выбрать файлы", , True)
    If VarType(avFiles) = vbBoolean Then Exit Sub
  
    IsForEachWbFolder = (MsgBox("Сохранять картинки каждой книги в отдельную папку?", vbQuestion + vbYesNo, "www.excel-vba.ru") = vbYes)
  
    If Not IsForEachWbFolder Then
        sImagesPath = Environ("userprofile") & "\desktop\images\" '"
        If Dir(sImagesPath, 16) = "" Then
            MkDir sImagesPath
        End If
    End If
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set wsTmpSh = ThisWorkbook.Sheets.Add
    For li = LBound(avFiles) To UBound(avFiles)
        Set wbAct = Workbooks.Open(avFiles(li), False)
        'создаем папку для сохранения картинок
        If IsForEachWbFolder Then
            sImagesPath = wbAct.Path & "\" & wbAct.Name & "_images\"
            If Dir(sImagesPath, 16) = "" Then
                MkDir sImagesPath
            End If
        End If
        sBookName = wbAct.Name
        For Each wsSh In Sheets
            For Each oObj In wsSh.Shapes
                If oObj.Type = 13 Then
                    '13 - картинки
                    '1 - автофигуры
                    '3 - диаграммы
                    oObj.Copy
                    sName = ActiveWorkbook.Name & "_" & wsSh.Name & "_" & oObj.Name
                    With wsTmpSh.ChartObjects.Add(0, 0, oObj.Width, oObj.Height).Chart
                        .ChartArea.Border.LineStyle = 0
                        .Parent.Select
                        .Paste
                        .Export Filename:=sImagesPath & sName & ".jpg", FilterName:="JPG"
                        .Parent.Delete
                    End With
                End If
            Next oObj
        Next wsSh
        wbAct.Close 0
    Next li
    Set oObj = Nothing: Set wsSh = Nothing
    wsTmpSh.Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Объекты сохранены", vbInformation, "www.excel-vba.ru"
End Sub
[/vba]

Автор - dmitrijaltman8
Дата добавления - 16.12.2021 в 17:26
RAN Дата: Четверг, 16.12.2021, 17:30 | Сообщение № 2
Группа: Друзья
Ранг: Экселист
Сообщений: 5638
Репутация: 1144 ±
Замечаний: 0% ±

2010


Быть или не быть, вот в чем загвоздка!
 
Ответить
СообщениеМы их в дверь, они в окно

Автор - RAN
Дата добавления - 16.12.2021 в 17:30
dmitrijaltman8 Дата: Четверг, 16.12.2021, 17:36 | Сообщение № 3
Группа: Пользователи
Ранг: Участник
Сообщений: 61
Репутация: 0 ±
Замечаний: 20% ±

2016
RAN, а что вы на закрытую тему-то ссылаетесь ?
 
Ответить
СообщениеRAN, а что вы на закрытую тему-то ссылаетесь ?

Автор - dmitrijaltman8
Дата добавления - 16.12.2021 в 17:36
Serge_007 Дата: Четверг, 16.12.2021, 17:40 | Сообщение № 4
Группа: Админы
Ранг: Местный житель
Сообщений: 15555
Репутация: 2559 ±
Замечаний: ±

Excel 2016
Цитата dmitrijaltman8, 16.12.2021 в 17:36, в сообщении № 3 ()
что вы на ... тему-то ссылаетесь ?
dmitrijaltman8, Вы полгода на форуме
Когда правила прочитаете?


ЮMoney:41001419691823 | WMR:126292472390
 
Ответить
Сообщение
Цитата dmitrijaltman8, 16.12.2021 в 17:36, в сообщении № 3 ()
что вы на ... тему-то ссылаетесь ?
dmitrijaltman8, Вы полгода на форуме
Когда правила прочитаете?

Автор - Serge_007
Дата добавления - 16.12.2021 в 17:40
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Сохранение некоторых фигур - как jpg в отдельные папки (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2022 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!