Страницы: 1
RSS
Метод Shapes.AddPicture (Excel) - как сохранить пропорции изображения?
 
Снова здравствуйте, дорогие эксперты!
Предыдущую тему я и назвал неверно, и сформулировал расплывчато, за что прошу прощения и конкретизирую вопрос:
Как при использовании метода Shapes.AddPicture сохранить пропорции изображения при его уменьшении?

Пример строки:      
Код
  Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height)

Пример скрипта:
Код
Sub InsertPictures()
'Update 20140513
Dim PicList() As Variant
Dim PicFormat As String
Dim Rng As Range
Dim sShape As Shape
On Error Resume Next
PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
xColIndex = Application.ActiveCell.Column
If IsArray(PicList) Then
    xRowIndex = Application.ActiveCell.Row
    For lLoop = LBound(PicList) To UBound(PicList)
        Set Rng = Cells(xRowIndex, xColIndex)
        Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
        xRowIndex = xRowIndex + 1
    Next
End If
End Sub
 
Доброе время суток
Цитата
whitemanehorsey написал:
сохранить пропорции изображения при его уменьшении?
Для этого нужно знать заранее его ширину и высоту, чтобы умножив их на некоторый коэффициент уменьшения, получить требуемую ширину и высоту. Ну, или хотя бы знать отношение сторон, например, ширины к высоте. Тогда зная требуемую ширину, можно будет найти высоту или наоборот. Как вы думаете логично?
Изменено: Андрей VG - 03.09.2018 19:10:20
 
Андрей VG, логично. Но разве нельзя эти значения вычислить? Например вот тут ктулху предлагает довольно интересный метод решения. Я пытаюсь его адаптировать для своих нужд, пропорции сохраняются, но картинки получаются очень маленькими не пойму почему. Чего я не учел?

Вот код:
Код
Sub InsertPictures()
'Update 20140513
Dim PicList() As Variant
Dim PicFormat As String
Dim Rng As Range
Dim sShape As Shape
On Error Resume Next
PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
xColIndex = Application.ActiveCell.Column
If IsArray(PicList) Then
    xRowIndex = Application.ActiveCell.Row
    For lLoop = LBound(PicList) To UBound(PicList)
        Set Rng = Cells(xRowIndex, xColIndex)
        Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, -1, -1)
        ratio = Rng.Width / sShape.Width
        sShape.ScaleWidth ratio, msoFalse
        sShape.ScaleHeight ratio, msoFalse
        xRowIndex = xRowIndex + 1
    Next
End If
End Sub
Изменено: whitemanehorsey - 03.09.2018 19:42:39
 
Сохранять пропорции:
Код
Selection.ShapeRange.LockAspectRatio = msoTrue
«Бритва Оккама» или «Принцип Калашникова»?
 
Спасибо, но...  Не работает... Или я не туда ставлю? Ставил в разные места - никак. После чего вписать эту строку надо?
 
Цитата
bedvit написал:
Сохранять пропорции:
Привет, Виталий.
Автор утверждает, что они сохраняются
Цитата
whitemanehorsey написал:
пропорции сохраняются,
whitemanehorsey, а проблема в следующем. При загрузке изображения LockAspectRatio = msoTrue, следовательно
sShape.ScaleWidth ratio, msoFalse уменьшит на ratio. И если бы вы остановились, то ширина рисунка была бы равна ширине диапазона, а высота уменьшилась на тот же коэффициент.
Но вы не останавливаетесь на достигнутом!
sShape.ScaleHeight ratio, msoFalse и к новой высоте снова применяете уменьшение...  :)
 
Цитата
whitemanehorsey написал:
Предыдущую тему я и назвал неверно
Название той темы поменял - использовал один из предложенных Вами вариантов. Но зачем создали новую тему, если следовало продолжать в старой?
 
Андрей VG, Спасибище! Заработало! Так и думал, что что-то упускаю из виду  :)

Вот рабочий код:
Код
Sub InsertPictures()
'Особая благодарность форуму www.planetaexcel.ru и его участникам, особенно Андрею VG
Dim PicList() As Variant
Dim PicFormat As String
Dim Rng As Range
Dim sShape As Shape
On Error Resume Next
PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
xColIndex = Application.ActiveCell.Column
If IsArray(PicList) Then
    xRowIndex = Application.ActiveCell.Row
    For lLoop = LBound(PicList) To UBound(PicList)
        Set Rng = Cells(xRowIndex, xColIndex)
        Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, -1, -1)
        ratio = Rng.Height / sShape.Height
        sShape.ScaleHeight ratio, msoFalse
        'Для масштабирования по ширине меняем Height на Width
        xRowIndex = xRowIndex + 1
        'Для распределения по строке, а не по столбцу меняем xRowIndex = xRowIndex + 1 на xColIndex = xColIndex + 1
    Next
End If
End Sub

Изменено: whitemanehorsey - 03.09.2018 21:01:21
 
Юрий М, создал новую, дабы отделить мух от котлет. Там в самой теме я пошел по неверному пути и просто всех запутал. Скрипт в теме рабочий был, просто назначение у него другое. Именно поэтому в той теме уже пошел флуд по поводу возможности редактирования вместо разбора вопроса. Да и вопрос был сформирован не очень корректно, что резко снижало вероятность получить ответ. Зато стоило мне переформулировать вопрос, как мне тут же указали на мою ошибку и итогом стал рабочий скрипт, за что я очень всем благодарен, особенно Андрею VG . Если я что-то нарушил, то прошу прощения.
 
Вам никто не говорил, что нужно создавать новую тему, а вот о том, что нужно предложить новое название,- говорили.  
 
Юрий М, извините, я больше не буду  :oops:  Нет возможности объединить темы?
 
Нет такой возможности.
 
Юрий М, тогда тем более извините  :oops:  
 
Андрей привет! Что ж делать, если автору нужно не то, что написано в названии темы :) А с двойным изменением встречался не раз на форумах, ставят сохранять пропорции, потом уменьшают ширину на какой либо коэффициент, а потом и высоту на тот же коэффициент - итог предсказуем :)
Юрий приветствую! С новичками не соскучишься:)
Изменено: bedvit - 03.09.2018 23:39:36
«Бритва Оккама» или «Принцип Калашникова»?
 
Цитата
bedvit написал:
А с двойным изменением встречался не раз на форумах
Это да. Недавно вы меня как раз ткнули носом в эту ошибку - вот я оперативно и расстарался :)  Так и не провёл исследование, как вашим подходом - уменьшить, вырезать, вставить и вернуть прежний размер, добиться требуемого уменьшения числа пиксел рисунка на листе. Правда, затык пока, как не трогать уже уменьшенные до 96dpi рисунки, чтоб качество окончательно не поплыло. Всё же через WIA путь более контролируемый.
 
Андрей, так это были вы?) AndVGri? Не опознал, думал просто культурный новичек )) Так, а в чем затык? Вышлите пример, я вам накидаю решение. Можно в той теме. Можно ссылку здесь оставить, что бы не засорять эту тему и если кому интересно станет. А через wia я не делал, и даже не знаю что это, поделитесь?)
Изменено: bedvit - 04.09.2018 09:38:55
«Бритва Оккама» или «Принцип Калашникова»?
 
Цитата
bedvit написал:
Вышлите пример, я вам накидаю решение
Виталий, да в общем и целом не актуально. Рассматривал сугубо как задачу, а если вдруг пригодится. Постараюсь вечером набросать пример, если вам будет интересно.
 
Всегда полезно разобраться в теме, поэтому предлагаю "добить тему".
Цитата
Андрей VG написал:
как не трогать уже уменьшенные до 96dpi рисунки
- прописать, к примеру циклом
Код
....ShapeRange.Title = "no_run"
и не обрабатывать эти картинки.
А далее что-то вроде:
Код
 If Workbooks(w).Sheets(s).Shapes(Pict).Title = "no_run" Then
«Бритва Оккама» или «Принцип Калашникова»?
 
Виталий, спасибо большое за вариант. Дойдут руки, поковыряю. Пока более интересные задачи попадаются.
Страницы: 1
Наверх