Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Как реализовать массовую вставку картинок в прайс-лист без искажения их геометрии?, Скрипт по вставке картинок не запускается
 
Здравствуйте, уважаемые эксперты! Появилась у меня необходимость вставки большого количества картинок в прайс-листы. Нашел я на просторах всемирной сети, как показалось мне, идеальный скрипт, да вот беда — не видит его excel при попытке запустить. Вставляю как модуль, а при попытке запуска показывает такое окно


А вот сам код:
Код
Sub ВставитьКартинку(ByRef PicRange As Range, ByVal PicPath As String, _
                     Optional ByVal AdjustWidth As Boolean, _
                     Optional ByVal AdjustHeight As Boolean, _
                     Optional ByVal AdjustPicture As Boolean = False)
    ' ==========  функция получает в качестве параметров:  ====================
    ' PicRange - прямоугольный диапазон ячеек, поверх которого будет расположено изображение
    ' PicPath - полный путь к файлу картинки (файл в формате JPG, BMP, PNG, и т.д.)
    ' AdjustWidth - если TRUE, то включен режим подбора ширины (подгонка по высоте)
    ' AdjustHeight - если TRUE, то включен режим подбора высоты (подгонка по ширине)
    ' AdjustPicture - если TRUE, то подгоняются размеры картинки под ячейку,
    '                 если FALSE (по умолчанию), то изменяются размеры ячейки

    On Error Resume Next: Application.ScreenUpdating = False
    ' вставка изображения на лист
    Dim ph As Picture: Set ph = PicRange.Parent.Pictures.Insert(PicPath)
    ' совмещаем левый верхний угол ячейки и картинки
    ph.Top = PicRange.Top: ph.Left = PicRange.Left
 
    K_picture = ph.Width / ph.Height    ' вычисляем соотношение размеров сторон картинки
    K_PicRange = PicRange.Width / PicRange.Height    ' вычисляем соотношение размеров сторон диапазона ячеек

    If AdjustPicture Then    ' ПОДГОНЯЕМ РАЗМЕРЫ ИЗОБРАЖЕНИЯ под ячейку (оптимальный вариант)

        ' если AdjustWidth=TRUE, то высоту не трогаем - изменяем ширину
        If AdjustWidth Then ph.Width = PicRange.Width: ph.Height = ph.Width / K_picture
 
        ' если AdjustHeight=TRUE, то ширину не трогаем - изменяем высоту
        If AdjustHeight Then ph.Height = PicRange.Height: ph.Width = ph.Height * K_picture
 
        ' AdjustWidth=TRUE и AdjustHeight=TRUE: вписываем картинку в ячейку (без соблюдения пропорций)
        If AdjustWidth And AdjustHeight Then ph.Width = PicRange.Width: ph.Height = PicRange.Height
 
 
    Else    ' ИЗМЕНЯЕМ РАЗМЕРЫ ЯЧЕЙКИ под размеры изображения (нежелательно при вставке НЕСКОЛЬКИХ картинок...)

        If AdjustWidth Then    ' если AdjustWidth=TRUE, то высоту не трогаем - изменяем ширину
            PicRange.Cells(1).ColumnWidth = PicRange.Cells(1).ColumnWidth * ph.Width / PicRange.Cells(1).Width
            While Abs(PicRange.Cells(1).Width - ph.Width) > 0.1    ' точный подбор ширины ячейки
                PicRange.Cells(1).ColumnWidth = PicRange.Cells(1).ColumnWidth - 0.2 * (PicRange.Cells(1).Width - ph.Width)
            Wend
        End If
 
        If AdjustHeight Then    ' если AdjustHeight=TRUE, то ширину не трогаем - изменяем высоту
            PicRange.Cells(1).RowHeight = PicRange.Cells(1).RowHeight * ph.Height / PicRange.Cells(1).Height
            While Abs(PicRange.Cells(1).Height - ph.Height) > 0.1    ' точный подбор высоты ячейки
                PicRange.Cells(1).RowHeight = PicRange.Cells(1).RowHeight - 0.2 * (PicRange.Cells(1).Height - ph.Height)
            Wend
        End If
 
    End If
End Sub
 

Подскажите пожалуйста, что я упустил или не понял?

Изменено: whitemanehorsey - 3 Сен 2018 20:49:40 (поправил изображение)
 
Цитата
whitemanehorsey написал:
Что я делаю не так?
Не ознакомились с правилами форума и дали название темы так, что её обязательно закроют модераторы. Уж после 20-ти сообщений можно было основные правила форума осознать.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Дмитрий(The_Prist) Щербаков, в запаре запутался, прошу прощения. Не вижу, как это исправить? Не создавать же дубликат темы с верным названием?
Изменено: whitemanehorsey - 3 Сен 2018 16:18:34
 
Просто предложите новое название. Модераторы обожают их менять :)
А по поводу макроса еще раз внимательно почитайте там, откуда Вы его взяли - https://excelvba.ru/code/PastePictures
Там выше что написано?
Цитата
В этом примере демонстрируются возможные варианты применения функции вставки картинок:
Скажи мне, кудесник, любимец ба’гов...

 
Цитата
_Boroda_ написал:
Просто предложите новое название
Спасибо! Вот варианты нового названия темы:
- Скрипт для вставки изображений в прайс-листы не хочет запускаться
- Как использовать приведенный ниже скрипт для вставки нескольких картинок?
- Как реализовать массовую вставку картинок в прайс-лист без искажения их геометрии
- Автоматизация вставки изображений в прайс-листы

Цитата
_Boroda_ написал:
Там выше что написано?
Уже нашел, попробовал и понял, что не совсем то, что нужно. Там примеры вставки единичных картинок, а нужна именно массовая вставка, как в примере ниже. Недостаток этого скрипта в том, что он искажает геометрию изображения. Возможно ли это как-то исправить?
Код
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 - 3 Сен 2018 18:01:20
 
Цитата
_Boroda_ написал:
Модераторы обожают их менять
:D Надо добавлять, по себе знаю.
 
Цитата
БМВ написал:
Надо добавлять, по себе знаю.
А где я модератор, там сутки ТС может поменять свой пост (и название поста тоже). Поэтому мы сами там темы не переименовываем, а на ТС ругаемся и его заставляем, а ответы на такие вопросы просто стираем с комментарием "Не исправлено замечание модератора". Народ уже привык. Ну, почти
Скажи мне, кудесник, любимец ба’гов...

 
Я думаю, что эту тему можно просто закрыть, т.к. и скрипт не совсем тот, и название кривое, и начало не очень. Сам уже с половиной разобрался и понял, что зашел в тупик. Поэтому я конкретизировал вопрос и вывел его в новую тему. Это, конечно, в том случае, если никто не подскажет, как использовать скрипт в начале для массовой загрузки. Но мне кажется, что это тупиковый путь и другой скрипт, который я указал в последующих сообщениях более эффективен. Там только один момент не понятен, его я и вынес в отдельную тему.
 
_Boroda_,  тут тоже можно править, до первого ответа в теме. :-). Движок такой.
 
Цитата
БМВ написал:
тут тоже можно править, до первого ответа в теме
Мдя, потрясающая логика - пока нет сообщений в теме, ТС думает, что назвал тему правильно (он же только что думал о том, как ее назвать), а когда ему сообщили о неверном названии, то сообщили в посте его темы и, следовательно, ТС уже, даже если захочет, поменять название не может. Кто ж это, интересно, так извратился для движка?
Ну это я так, меня всегда привлекали такие интересные логические выверты - вроде теоретически можно, а по факту нельзя
Скажи мне, кудесник, любимец ба’гов...

 
_Boroda_, Александр, логика вышла из документа оборота по всей видимости, только там еще и сообщение нельзя исправлять после того как кто-то начал что-то делать. Это  в миру сделано тоже хорошо. Тут пока имеем то что имеем
 
off
само сообщение изменить можно, но название темы нет.
 
Off
Цитата
Catboyun написал:
само сообщение изменить можно
при  этом всегда, даже через годы, что тоже неправильно.
Страницы: 1
Читают тему (гостей: 1)
Наверх