Новости:

Прикрепить к сообщению можно только файлы xls, gif, jpg, rar, zip,7z, bas, frm, cls, doc размером до 150 Кб.

Главное меню

Вставка картинок по данным из двух столбцов

Автор runner, 03.08.2018, 11:41

« назад - далее »

runner

Доброго дня всем читающим!
Есть код, полученный в этом же форуме (за что автору отдельное спасибо!), который хотелось бы модифицировать, но моих знаний для этого не хватает.

Модуль берёт название картинки(в виде артикул.jpg) из ячейки, добавляет его в конец прописанного пути R:\ФОТО\BOSCH\150\ и загружает картинку в ячейку справа от ячейки с названием.
Хочется, чтобы путь тоже был "составным", так как папок с картинками по брендам много, и каждый раз переписывать путь неудобно.
Надо чтобы название папки, в данном конкретном случае "BOSCH", бралось из ячейки слева от ячейки с названием картинки.
Результат должен выглядеть, как в приложенном файле.

Sub InsertPictures()
Const PATH = "R:\ФОТО\BOSCH\150\" 'папка с картинками
Dim c As Range
For Each c In Selection
   With ActiveSheet.Shapes.AddPicture(PATH & c, _
       msoFalse, msoTrue, c(, 2).Left, c(, 2).Top, 100, 100)
       .ScaleHeight 1, msoTrue, msoScaleFromTopLeft    'вернуть исходную высоту
       .ScaleWidth 1, msoTrue, msoScaleFromTopLeft     'вернуть исходную ширину
       c.RowHeight = .Height + 10                      'подстроить высоту строки
   End With
Next
End Sub


Совсем идеальным вариантом было бы, если и расширение файла с картинкой (.jpg) добавлялось бы в конец пути в коде, чтобы не создавать столбец дополнительно а использовать два столбца бренд/артикул)


boa

Здравствуйте,
закомментируйте(Удалите) строку, где добавляется Патч

и перед With ActiveSheet...
добавьте
PATH = c.Offset(, -1).value
Но путь в ячейке 1 должен быть полным и заканчиваться слэшем "\".

Либо надо составлять дополнительный справочник путей для разных наименований и обращаться к нему
Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра

runner

Спасибо!
Вполне рабочий вариант! Жаль, не удалось обойтись имеющимися столбцами, но требуемый выстраивается просто, так что - результат достигнут.
Кстати, у меня срабатывает как раз без слэша в конце, т.е. '...jpg' и всё

boa

Цитата: boa от 03.08.2018, 12:45
Но путь в ячейке 1 должен быть полным и заканчиваться слэшем "\".
Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра

boa

Цитата: runner от 03.08.2018, 11:41
Совсем идеальным вариантом было бы, если и расширение файла с картинкой (.jpg) добавлялось бы в конец пути в коде, чтобы не создавать столбец дополнительно а использовать два столбца бренд/артикул)
Не знаю всей логики составления пути к файлу, но могу предположить вариант
Filename = "R:\ФОТО\" & c.Offset(, -1).Value & "\150\" & c.Value & ".jpg"
соответственно "Filename" заменит в коде "PATH & c"
Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра

runner

Всё ли я так сделал?
не срабатывает.
Логика пути - общий ресурс диск R:, на нём раздел ФОТО, в нём папки именованные названием бренда, внутри полноразмерные фото в формате артикул.jpg и папка под названием "150" в которой аналогичные фото с такими же названиями, но с максимальной высотой в 150 точек.
Собственно их и предполагается загружать в таблицу. 


Sub InsertPictures()
Dim c As Range
For Each c In Selection
   With ActiveSheet.Shapes.AddPicture(Filename = "R:\ФОТО\" & c.Offset(, -1).Value & "\150\" & c.Value & ".jpg", _
       msoFalse, msoTrue, c(, 2).Left, c(, 2).Top, 100, 100)
       .ScaleHeight 1, msoTrue, msoScaleFromTopLeft    'вернуть исходную высоту
       .ScaleWidth 1, msoTrue, msoScaleFromTopLeft     'вернуть исходную ширину
       c.RowHeight = .Height + 10                      'подстроить высоту строки
   End With
Next
End Sub

boa

Цитата: runner от 03.08.2018, 14:11
Всё ли я так сделал?
не совсем
Sub InsertPictures()
Dim c As Range
dim Filename as string
For Each c In Selection
Filename = "R:\ФОТО\" & c.Offset(, -1).Value & "\150\" & c.Value & ".jpg"
   With ActiveSheet.Shapes.AddPicture(Filename, _
       msoFalse, msoTrue, c(, 2).Left, c(, 2).Top, 100, 100)
       .ScaleHeight 1, msoTrue, msoScaleFromTopLeft    'вернуть исходную высоту
       .ScaleWidth 1, msoTrue, msoScaleFromTopLeft     'вернуть исходную ширину
       c.RowHeight = .Height + 10                      'подстроить высоту строки
   End With
Next
End Sub
Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра

runner

Спасибо огромное! Теперь всё идеально!

boa

#8
Цитата: runner от 03.08.2018, 18:17
Теперь всё идеально!
позвольте усомниться ;)
в вашем коде надо выделять ячейки только в колонке с артикулами.
Не большое преобразование и можно оторваться от этой привязки...
В строки, которые попали в любое выделение ячеек(только не пытайтесь выделить целые столбцы, иначе надо будет еще преобразрвывать...), будут вставлены картинки в 3-м столбце;)
Если, конечно, сгенерированный из значений 1-й и 2-й ячейки путь к картинке существует.
Sub InsertPictures()
Dim c As Range
Dim Filename As String
on error resume next
For Each c In Selection.EntireRow
Filename = "R:\ФОТО\" & c.Cells(1).Value & "\150\" & c.Cells(2).Value & ".jpg"
   With ActiveSheet.Shapes.AddPicture(Filename, _
       msoFalse, msoTrue, c.Cells(3).Left, c.Cells(3).Top, 100, 100)
       .ScaleHeight 1, msoTrue, msoScaleFromTopLeft    'вернуть исходную высоту
       .ScaleWidth 1, msoTrue, msoScaleFromTopLeft     'вернуть исходную ширину
       c.RowHeight = .Height + 10                      'подстроить высоту строки
   End With
Next
End Sub
Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра

runner

У меня просто нет слов ..... этот модуль опередил мои следующие вопросы!  :D :D :D


boa

Всегда ставьте себе максимальные цели, а лишь потом корректируйте свои "аппетиты" встретившимися ограничениями, и то, не все ограничения являются таковыми!
Постановка "полуцелей" - ошибка большинства.
Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра