Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Удалить обрезанные области рисунков
 
#1
02.06.2016 08:56:53
Доброго всем дня!
Как обычно своего мозга не хватает, посему прошу помощи!
У меня есть прайс-лист с картинками (около 3,5 тыс позиций) картинки в прайсе длинные, но с краев много пустого, и хочется его убрать (обрезать).

Максим Зеленский написал для этого макрос (Спасибо ему еще раз) картинки приняли нормальный вид, но эксель не обрезал их а только перестал отображать лишнее и при выгрузке картинки принимают первоначальный вид длиииииииинного  прямоугольника (((.
Как можно удалить обрезанные области без возвратно?
Бог кости не бросает
 
 
 
#2
02.06.2016 09:57:36
Решения с помощью макроса не знаю. Если не найдете решения с помощью макроса, то вручную это можно попытаться сделать так: выделите один любой рисунок - вкладка "Формат" - группа "Изменение" - Сжать рисунки - снимите флажок "Применить только к этому рисунку" - OK. После этого обрезанные фрагменты должны удалиться.
 
 
 
#3
02.06.2016 10:19:23
Karataev, этот способ я тоже пробовал, но происходит обрезание части рисунка и растягивание его до прежнего размера, получается размытая клякса.
Бог кости не бросает
 
 
 
#4
02.06.2016 10:25:05
Сделайте файл пример. На одном листе рисунок обрезанный, но не сжатый, на втором листе этот же рисунок обрезанный и сжатый. Без файла-примера не понятна проблема, т.к. я сейчас обрезал рисунок, сжал его и внешне ничего не изменилось.
 
 
 
#5
02.06.2016 10:26:01
Karataev, один момент!
Изменено: coregonus - 02.06.2016 10:35:07
Бог кости не бросает
 
 
 
#6
02.06.2016 10:50:29
У меня тоже проблема с Вашим рисунком, но другая - не происходит удаление обрезков. Я пробую в Excel 2016.
Если после обрезки рисунок скопировать и вставить с помощью специальной вставки, то обрезки удаляются. Попробуйте этот макрос.
Код
Sub jjj()

    Dim shp As Shape, lngLeft As Long, lngTop As Long
    Dim i As Long
    
    Application.ScreenUpdating = False
    
    For i = ActiveSheet.Shapes.Count To 1 Step -1
        Set shp = ActiveSheet.Shapes(i)
        lngLeft = shp.Left: lngTop = shp.Top
        shp.Cut
        ActiveSheet.PasteSpecial Format:="Рисунок"
        Set shp = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
        shp.Left = lngLeft: shp.Top = lngTop
    Next
    
    Application.ScreenUpdating = True
    
End Sub
Изменено: Karataev - 02.06.2016 11:18:53
 
 
 
#7
02.06.2016 11:19:53
Karataev, пробую
Бог кости не бросает
 
 
 
#8
02.06.2016 11:20:52
Я только что внес изменения в макрос, возьмите новый код из поста 6.
 
 
 
#9
02.06.2016 11:30:43
Karataev, работает  :)
 а объединить  с этим можно ?  Или лучше по отдельности запускать ?
Код
Sub cut_em_all()
 
    For Each shsh In ActiveSheet.Shapes
    With shsh
        .LockAspectRatio = msoFalse
        .IncrementLeft 0.00007874015748
        .ScaleWidth 0.5896716444, msoFalse, msoScaleFromTopLeft
        .PictureFormat.Crop.PictureWidth = 1050
        .PictureFormat.Crop.PictureHeight = 201
        .PictureFormat.Crop.PictureOffsetX = 215
        .PictureFormat.Crop.PictureOffsetY = 0
        .IncrementLeft 441.4724409449
        .ScaleWidth 0.2874850932, msoFalse, msoScaleFromTopLeft
        .PictureFormat.Crop.PictureWidth = 1050
        .PictureFormat.Crop.PictureHeight = 201
        .PictureFormat.Crop.PictureOffsetX = 0
        .PictureFormat.Crop.PictureOffsetY = 0
    End With
    Next
End Sub
Изменено: coregonus - 03.06.2016 11:27:49
Бог кости не бросает
 
 
 
#10
02.06.2016 11:39:17
смотрите файл
 
 
 
#11
02.06.2016 11:48:16
Karataev, Огромное спасибо!!!!
Бог кости не бросает
 
 
 
#12
02.06.2016 21:11:38
coregonus, код следует оформлять соответствующим тегом: ищите такую кнопку. Тогда и строки пронумеруются сами. Посмотрите #6 - лучше читается, чем у Вас?
 
 
 
#13
03.06.2016 06:31:58
Юрий М, Виноват, исправлюсь!
Бог кости не бросает
 
 
 
#14
03.06.2016 11:21:43
Не вижу исправленного сообщения. Когда исправитесь? )
 
 
 
#15
03.06.2016 11:32:40
Исправляюсь
Только сейчас обратил внимание на наши аватарки )))).
Бог кости не бросает
 
 
 
#16
03.06.2016 11:49:04
Во-во! Это ждёт каждого, кто не будет оформлять код )
 
 
 
#17
03.06.2016 11:54:16
Буду стараться более не косячить.
Бог кости не бросает
 
 
 
Страницы: 1
Читают тему
Наверх