Страницы: 1
RSS
[ Закрыто ] Сохранение некоторых фигур - как jpg в отдельные папки, соответствующие названиям листов
 
Здравствуйте.
Помогите написать макрос.

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

Подскажите - как макросом сохранить их как jpg - в отдельные папки (соответствующие названиям листов) ?
Нужно сохранить все фигуры, кроме тех у которых в названии есть слова "овал", "прямоугольник" или "линия".
 
Отвечать на сообщения - не считаете нужным? Сначала нужно пройтись по своим темам и проявить минимальное уважение к помогающим
 
Помогите решить этот вопрос
 
Помогите решить задачу
 
Нужно макросом создать новую книгу с одним листом, создать папку по имени листа, удалить в листе не нужные фигуры и сохранить книгу как веб страницу и все графические объекты выпадут в эту папку
 
Помогите решить вопрос
 
Цитата
Dalm написал:
Нужно сохранить все фигуры,
каждую отдельно или надо все в один файл
По вопросам из тем форума, личку не читаю.
 
Почитайте эту статью на дружественном сайте.
 
Цитата
написал:
каждую отдельно или надо все в один файл
каждую отдельно, но в разные папки (по названиям листов).
 
Если кому то интересно делать , то обойти листы, на каждом обойти все фигуры, если группировка .type=msoGroup, то рекурсивно углубляться до единичной, проверить имя и если не из списка исключений записать   .SaveAsPicture  по сформированному пути . Имя листа или передавать или в глобальной держать. я предпочитаю передавать.
Изменено: БМВ - 15.12.2021 17:26:45
По вопросам из тем форума, личку не читаю.
 
Цитата
написал:
обойти лисnы, на каждом обойти все фигуры, если группировка .type=msoGroup, то рекурсивно углубляться до единичной, проверить имя и если не из списка исключений записать   .SaveAsPicture  по сформированному пути . Имя листа или передавать или в глобальной держать. я предпочитаю передавать.
Понятно.
Как же это в макрос записать ?
 
Цитата
Dalm написал:
Как же это в макрос записать ?
For Each  .... For Each ...... if  ... .type=.type=msoGroup then .....  ....
Dalm, мне это не интересно.
По вопросам из тем форума, личку не читаю.
 
Помогите написать макрос
 
По ссылке в #8 есть уже написанные макросы.
Владимир
 
Цитата
написал:
По ссылке в #8 есть уже написанные макросы.
Да там непонятно все.

Вот: "Сохранение всех картинок из всех выбранных файлов эксель - в папку"
Код
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
Но у меня несколько папок будет - по названиям листов.
Потом непонятно, что за выбранные файлы эксель. У меня только один файл - тот который открыт и из которого нужно все группы фигур или фигуры - сохранить как jpg - с тем именем, которое эта фигура или группа имела (если только в ее названии нет слова овал, прямоугольник, линия)..
 
Dalm, а раздел платных заказов пора. В одной теме постоянно клянчить не надоел? Помогите, помогите... Раз 6, е считая удаленных... Как нищий на паперти.
 
vikttur, дело даже не в том, что "клянчит" — под это сильно размытое определение можно любого вопрошающего подтянуть
Дело в том, что САМ он палец о палец не ударил, ведь ещё sokol92 в #14 сказал, что всё есть — просто нужно адаптировать
Так нет же — этому бесплатно надо, но чтобы всё готовое, и расжевать, и в ротик положить — канючилка, одним словом
Так про деток маленьких и капризных говорят — в силу несостоятельности ТСа, идеально подходит  :D
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Цитата
написал:
просто нужно адаптировать
Как адаптировать имеющийся макрос ?
 
Dalm,
варианта собственно 3:
1. научится это делать самому.
2. дождаться того кому интересно это все написать, бывает и такое.
3. Заинтересовать кого-то это написать
Цитата
vikttur написал:
раздел платных заказов пора.
По вопросам из тем форума, личку не читаю.
 
Вот я жду
 
Мир не без добрых людей.
Может кто-нибудь поможет.
 
Цитата
ЗАПРЕЩЕНО
3.6. Многократно поднимать тему
, если на поставленный вопрос ответ не был получен своевременно. В случае многократного поднятия темы сообщениями типа "up", это может быть расценено как флуд.
Не хотите платить другим за знания - учитесь сами.
Изменено: vikttur - 16.12.2021 17:17:44
 
Код
Sub SaveShapes()
    Dim iSht As Worksheet, iShape As Shape, EachShape As Shape
    Dim sFolderPath As String, oFSO As Object, sName As String
    
    Application.ScreenUpdating = False
    sFolderPath = ThisWorkbook.Path & "\"
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    For Each iSht In Worksheets 'каждый лист
        For Each iShape In iSht.Shapes 'каждый объект
            If iShape.Type = msoGroup Then 'если группа
                For Each EachShape In iShape.GroupItems
                    If Not EachShape.Name Like "*Oval*" And Not EachShape.Name Like "*Прямоугольник*" Then
                        If Not oFSO.folderexists(sFolderPath & iSht.Name) Then oFSO.CreateFolder (sFolderPath & iSht.Name)
                        sName = sFolderPath & iSht.Name & "\" & EachShape.Name
                        EachShape.Copy
                        With ActiveSheet.ChartObjects.Add(0, 0, EachShape.Width, EachShape.Height).Chart
                            .Parent.Select
                            .Paste
                            .Export Filename:=sName & ".jpg", FilterName:="jpg"
                            .Parent.Delete
                        End With
                    End If
                Next EachShape
            End If
        Next iShape
    Next iSht
    Application.ScreenUpdating = True
    MsgBox "Картинки сохранены!", vbInformation, "Конец"
End Sub
Страницы: 1
Наверх