Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Вставка изображения в соответствии со значением ячейки
 
#1
14.01.2014 15:43:58
Добрый день Великие!
Столкнулся с проблемой: Данные в файле формируются посредством ВПР из разных баз. Единственное с чем не получается - это изображение.
Действие происходит следующим образом: в ячейку "K1" вписывается ФИО человека, по этому ФИО данные собираются с разных мест. Есть папка с изображениями "C:\System32\Picture\Avatar\", где названия фото соответствуют ФИО людей.
Мне необходимо чтобы фото тоже подтягивалось из папки в ячейку "I5" (или диапазон ячеек) - оптимально по ширине или высоте ячейки (выравнивание по левому краю).
Перерыв интернет нашел только такую формулу, но в ней разобраться полностью не могу:
Код
Sub Vstavka_Kartinok() 
Sheets("Лист1").Select 
x = 1 
Range("A1").Select 
While Sheets("Лист1").Cells(x, 2).Text <> "" 
x = x + 1 
Wend 
x = x - 1 
For i = 2 To x 
kartinka = Sheets("Лист1").Cells(i, 2).Value 
Range("E" & CStr(i)).Select 
Dim SR As ShapeRange 

ActiveSheet.Pictures.Insert("C:\1\" & CStr(kartinka) & ".jpg").Select 
'Set SR = Selection.ShapeRange 

[B]Selection.ShapeRange.Left = 200 
Selection.ShapeRange.Top = 100 * (i - 2)[/B] 

Selection.ShapeRange.LockAspectRatio = msoFalse 
Selection.ShapeRange.Height = 152.2 
Selection.ShapeRange.Width = 183.75 
Selection.ShapeRange.Rotation = 0# 
Selection.ShapeRange.ScaleHeight 0.8, msoFalse, msoScaleFromTopLeft 
Next i 
MsgBox ("Изображение загружено") 
End Sub 

Sub InsertShapeNode() 
ActiveSheet.Shapes(1).Select 
With Selection.ShapeRange 
If .Type = msoFreeform Then 
.Nodes.Insert _ 
Index:=3, SegmentType:=msoSegmentCurve, _ 
EditingType:=msoEditingSymmetric, X1:=35, Y1:=100 
.Fill.ForeColor.RGB = RGB(0, 0, 200) 
.Fill.Visible = msoTrue 
Else 
MsgBox "This shape is not a Freeform object." 
End If 
End With 
End Sub
Помогите гуманитарию, если сталкивались с такой проблемой!
 
 
 
#2
14.01.2014 21:03:53
Запишите обыкновенный макрос вставки картинки с диска макрорекодером. Затем измените путь и все.

Код
 ActiveSheet.Pictures.Insert("C:\Users\Server\Pictures\1.png").Select
Изменено: Антон - 14.01.2014 22:03:30
 
 
 
#3
15.01.2014 13:31:47
Попробуйте прием описанный тут. По-моему Вам должно подойти.
 
 
 
#4
03.03.2014 15:34:04
Цитата
Антон пишет: Запишите обыкновенный макрос вставки картинки с диска макрорекодером. Затем измените путь и все.
Микрорекордером не получается правильно задать условное название переменной, а именно: \Photobaza\" & a1 & ".jpg"  ;)  
Цитата
ts-79 пишет: Попробуйте прием описанный тут. По-моему Вам должно подойти.
Такой вариант смотрел, не то что нужно (количество более 500 шт.).
на данный момент пришел к новому макросу, но не работает, пишет что требуется объект. В силу своей неграмотности, что-то не то написал. Может подскажите:
Код
Sub SelectionPhoto()
If Target.Address = "$AF$1" Then
    ActiveSheet.Pictures.Insert("C:\Users\\Photobaza\" & Target.Value).Select
    Selection.Left = Columns("Z".Left
    Selection.Top = Rows(5).Top
End If
End Sub
 
 
 
#5
04.03.2014 07:35:43
Цитата
Cipariz пишет:
Такой вариант смотрел, не то что нужно (количество более 500 шт.).
Согласен. Не очень удобно и трудоёмко. У меня стояла аналогичная задача, но только список в 2 раза меньше Вашего. Пару дней пришлось потратить на сканирование и вставку фото.
Эта тема меня тоже очень сильно интересует, поскольку часто приходится обновлять фото. Поэтому подписался сразу на эту тему когда увидел.
Но помочь с макросом, к сожалению, вне пределов моих скудных познаний.
Отпишитесь пожалуйста если найдете решение.
 
 
 
#6
04.03.2014 08:28:23
Может, проще нажать одну кнопку, чтобы всё само вставилось?
http://excelvba.ru/programmes/PastePictures
Изменено: Игорь - 04.03.2014 08:28:39
Надстройки для Excel  Парсинг сайтов  Мониторинг цен конкурентов
 
 
 
#7
04.03.2014 08:33:33
Игорь, с одной стороны проще, но проблема в том, что я делаю. а другие по сети пользуются - и надстройку надо ставить всем, и следить за этим. А хочеться уходить в отпуск и чтоб меня не тревожили)
 
 
 
#8
04.03.2014 09:56:42
Вот так работает, но при условии что название фото полностью совпадает с ФИО в А1 (без лишних пробелов) и имеет расширение *.jpg. Кроме того, вставляет реальный размер фото. Как подогнать под размер ячейки пока не знаю. Экспериментирую дальше.

Код
Sub SelectionPhoto()
Dim r As String
r = Sheets("ПКС").Cells(1, 1).Value
Sheets("ПКС").Pictures.Insert("C:\Users\ok5\Desktop\Фото сотрудников\" & r & ".jpg").Select 
Selection.Left = Columns("Z").Left 
Selection.Top = Rows(5).Top 
End Sub
Изменено: ts-79 - 04.03.2014 10:17:58
 
 
 
#9
04.03.2014 11:43:23
Работает, с размерами тоже экспериментирую)))
 
 
 
#10
04.03.2014 13:13:27
Может использовать пользовательскую форму и в ней
выбирать ФИО из списка и подтягивать данные и фото.
 
 
 
#11
04.03.2014 13:48:16
Код
Sub SelectionPhoto() 
  Dim r As String 
  r = Sheets("Êàðòà" ) .Cells(1, 32).Value 
  Sheets("Êàðòà" ) .Pictures.Insert("C:\Users\PhotoBaza\" & r & ".jpg" ) .Select 
  Selection.Left = Columns("Z" ) .Left 
  Selection.Top = Rows(5).Top 
  With Selection 
    .Top = 55 
    .Left = 480 
    .Width = 50 
    .Height = 160 
  End With 
End Sub


Виноват, справлюсь)
 
 
 
#12
04.03.2014 13:49:46
Тогда эти строки уже лишние
Код
Selection.Left = Columns("Z").Left 
Selection.Top = Rows(5).Top
Вариант если фото можно жестко привязать к определенному месту, предназначенному для фото.
 
 
 
#13
04.03.2014 13:58:50
Посмотрите пример из книги Билла Джелена,
файлы с фото д.б. в том же каталоге, что и
рабочая книга с макросом
 
 
 
#14
04.03.2014 14:12:31
Спасибо за совет и пример.
Наверное это все можно реализовать и на листе.
Вставить соответствующий элемент ActiveX и прописать соответствующий код. Да и путь к каталогу с фото также думаю можно прописать в другое место.
Надо поэкспериментировать. На досуге попробую. Сейчас пока другие задачи.
Изменено: ts-79 - 04.03.2014 14:13:34
 
 
 
#15
04.03.2014 16:03:04
А ссылкой у меня тоже проблема появилась, изначально документы выложил в гугл диск, и дал доступ другим, а фото на других компах не вставляет, так как в ссылке присутствует разное название компьютеров, например: "C:\Users1 или 2 или 3\Google Диск\PhotoBaza\" & r & ".jpg"/

Вариант:
Цитата
Kuzmich пишет: ФормаВводаПользовательскихДанных.rar
не совсем удобен когда файл размещен в папке с большим количесвом фотографий. Хотя они и находяться в паралелльных папках: Google Диск\PhotoBaza и Google Диск\Baza.
 
 
 
#16
04.03.2014 16:07:57
Вариант с SelectionPhoto() в этом виде приведет к катастрофическому увеличению размера файла, если не удалять ранее вставленные фото.
Т.е. при каждом выборе ФИО новое фото встает поверх старого и необходимо как-то программно удалять предыдущее фото.

Вариант предложенный Kuzmich-ем, адаптированный под Image на листе долго подгружает фото (несколько секунд), и имеется та же проблема с подгоном размера фото под размеры Image. Либо сразу необходимо складировать фото с определенными размерами.
 
 
 
#17
04.03.2014 16:10:55
Цитата
ts-79 пишет: Вариант с SelectionPhoto() в этом виде приведет к катастрофическому увеличению размера файла,...
Я вышел из положения следующим образом, на кнопке висит несколько макросов, первый чистит фотки, второй вставляет.
 
 
 
#18
04.03.2014 16:21:08
Цитата
Cipariz пишет:
первый чистит фотки,
Поделитесь? лень искать, переделывать. А у нас задачи одинаковые. Поэтому думаю мне подойдет.
 
 
 
#19
04.03.2014 16:25:08
Код
Sub StartMain()
 Call DeleteButton
 Call SelectionPhoto
End Sub

Sub DeleteButton()
  Dim figa As Shape
  For Each figa In ActiveSheet.Shapes
  If Not Intersect(Range(figa.BottomRightCell.Address), Range("Z5:AE16")) Is Nothing Then   'диапазон ячеек где находиться картинка
  figa.Delete
  End If
  Next
End Sub

Sub SelectionPhoto()
 Dim r As String
 r = Sheets("Карта" ;) .Cells(1, 32).Value
 Sheets("Карта" ;) .Pictures.Insert("C:\Users\Google Диск\Baza\Photobaza\" & r & ".jpg" ;) .Select
 Selection.Left = Columns("Z" ;) .Left
 Selection.Top = Rows(5).Top
 With Selection
 .Top = 55
 .Left = 480
 .Width = 50
 .Height = 160
 End With
End Sub


Не вопрос
Изменено: Cipariz - 04.03.2014 16:29:10
 
 
 
#20
04.03.2014 16:32:16
Цитата
Cipariz пишет: Application.Calculate
Но Application.Calculate просто пересчитывает, но не удаляет предыдущие фото.
 
 
 
#21
05.03.2014 18:05:29
По совету Kuzmichа:

На лист в нужное месть добавляем элемент ActiveX Image (изображение) необходимого размера.
В исходный текст листа прописываем код:
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.text = "" Then Exit Sub
    If Not Intersect(Target, Cells(1, 1)) Is Nothing Then
       iName = Target
       Image1.Picture = LoadPicture(ThisWorkbook.Path & "\фото сотрудников\" & iName & ".jpg" 
 
      End If 
End Sub
Фото будет менятся при изменении/выборе ФИО в ячейке А1.
Папка с фото должна находится в той же директории что и сам файл Ексель

Если папку с фото необходимо расположить в другом месте то строку в коде необходимо заменить на
Код
 Image1.Picture = LoadPicture("C:\Users\ok5\Desktop\фото сотрудников\" & iName & ".jpg"
где: C:\Users\ok5\Desktop\фото сотрудников\ - путь к папке с фото.

Подгон фото под размер элемента Image (изображение), осуществляется в свойствах этого элемента.
PictureSizeMode необходимо выбрать 1- fmPictureSizeModeStretch (по умолчанию 0- fmPictureSizeModeClip).
Это в Ексель 2010. В других не знаю как. Но нужно искать свойство Stretch и выставлять True.

Вот такой вариант получился у меня.
 
 
 
#22
05.03.2014 23:36:09
Обратите внимание:метод .Pictures.Insert в Excel 2010 вставляет не сами картинки, а ссылки на картинки.
Если вы потом этот файл с картинками кому-нибудь вышлете по почте, - получателю картинки видны не будут.

Лучше использовать другой способ вставки:
http://excelvba.ru/code/PastePictures#comment-3126
Надстройки для Excel  Парсинг сайтов  Мониторинг цен конкурентов
 
 
 
#23
11.04.2014 17:24:42
Игорь, не намекнете как у вас в надстройке вставляется картинка ЛЮБОГО формата, т.е. неважно jpg, bmp, png и т.д.?
С уважением, Андрей.
 
 
 
#24
11.04.2014 17:36:11
Наверное лучше и быстрее будет спросить об этом на сайте автора, по мейлу, скайпу или аське.
Изменено: ts-79 - 11.04.2014 17:36:59
 
 
 
#25
13.04.2014 10:00:16
Цитата
UnDrew пишет:вставляется картинка ЛЮБОГО формата, т.е. неважно jpg, bmp, png и т.д.?
Код
 PicLocation = Application.GetOpenFilename("Image Files (*.jpg),*.jpg", , "Select Image File", , False)
добавьте расширения и все
 
 
 
Страницы: 1
Читают тему
Наверх