Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1 2 След.
RSS
Вставка 2х изображений на нескольких листах с разным размером
 
#1
05.11.2018 18:48:49
Добрый день! Нашел отличный пример создания списка изображений для комплектующих. Сам пример во вложении. Проблема в том, что помимо заполнения маленькими картинками (размер 100*80) в таблице на Листе1, нужно еще заполнить каталог в бОльшем масштабе на Листе2 (200*160, например). В итоге, при смене маленького изображения будет меняться и большое изображение. Вот используемый код:

Код
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)Dim sAddress As String
Dim MyCell As Range

    On Error Resume Next
    Set MyCell = Target.Range
    
    ChDir ThisWorkbook.Path & "\Банк изображений\" & Target.Name
    sAddress = Application.GetOpenFilename(Title:="Выберите файл")
    MyCell.Font.ThemeColor = xlThemeColorDark1
    'MyCell.Clear
    Shapes.AddPicture _
        sAddress, False, True, MyCell.Left + 5, MyCell.Top + 5, 100, 80
                
End Sub
 
 
 
#2
05.11.2018 18:52:31
Код
MyCell.Left + 5, MyCell.Top + 5, 100, 80

Два певых числа - положение относительно ячейки, 100 и 80 - размер
 
 
 
#3
05.11.2018 18:53:59
vikttur, а другой лист возможен?
 
 
 
#4
05.11.2018 18:57:35
Ну да.
Например, после указанной строки обработать другой лист:
Код
With Worksheets("мой_большой_лист")
     ' тут все, что касается другого листа
End With
 
 
 
#5
05.11.2018 19:00:55
любой возможен
Worksheets(2).Shapes.AddPicture ...
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#6
05.11.2018 19:03:25
vikttur, боюсь сказать какую-нибудь глупость, но правильно понимаю, что код должен будет выглядеть примерно так:
Код
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)Dim sAddress As String
Dim MyCell As Range
 
    On Error Resume Next
    Set MyCell = Target.Range
     
    ChDir ThisWorkbook.Path & "\Банк изображений\" & Target.Name
    sAddress = Application.GetOpenFilename(Title:="Выберите файл")
    MyCell.Font.ThemeColor = xlThemeColorDark1
    'MyCell.Clear
    Shapes.AddPicture _
        sAddress, False, True, MyCell.Left + 5, MyCell.Top + 5, 100, 80 'для вставки в текущее место
        Shapes.AddPicture _
        
        sAddress, False, True, MyCell.Left + 5, MyCell.Top + 5, 200, 160
        with Worksheets("Лист2")
             'тут как-то прописать строку и столбец, куда вставить изображение
        end with

                 
End Sub
 
 
 
#7
05.11.2018 19:08:53
Ігор Гончаренко, остается вопрос, как указать столбец и ячейку на новом листе, куда должно быть помещено изображение? Как все таки верно, 2 раза прописывать Shapes.AddPicture для каждого изображения, или один раз, но с разными параметрами?
 
 
 
#8
05.11.2018 19:11:28
Цитата
bss17 написал:
Как все таки верно
Как больше нравится.
 
 
 
#9
05.11.2018 19:13:14
Я сейчас понял, что скорее всего не выйдет таким образом решить задачу... Ведь у меня будет не 1 изображение, которое должно быть в таблице на Листе1 и в каталоге на Листе2. Их будет несколько и как-то надо для больших прописывать отдельно куда они должны помещаться. Скажите, сохраняется ли где-то путь к изображению при вставке его с помощью Shapes.AddPicture? Может быть есть вариант уже на Листе2 из нужной ячейки обратить к адресу интересующего изображения и вставить его же, но с другими размерами? Есть такой вариант?
 
 
 
#10
05.11.2018 19:15:51
Код
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)Dim sAddress As String
Dim MyCell As Range
    On Error Resume Next
    Set MyCell = Target.Range
    ChDir ThisWorkbook.Path & "\Банк изображений\" & Target.Name
    sAddress = Application.GetOpenFilename(Title:="Выберите файл")
    MyCell.Font.ThemeColor = xlThemeColorDark1
    Shapes.AddPicture sAddress, False, True, MyCell.Left + 5, MyCell.Top + 5, 100, 80 'для вставки в текущее место
    Worksheets("Лист2").Shapes.AddPicture sAddress, False, True, MyCell.Left + 5, MyCell.Top + 5, 200, 160
End Sub
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#11
05.11.2018 19:16:55
Опишите нормально  задачу, замените пример (с учетом уточнений)
 
 
 
#12
05.11.2018 19:21:17
Цитата
bss17 написал:
Нашел отличный пример создания списка изображений
пример отличный для вставки 1-го изображение в текущую ячейку
а для содания списка изображение - абсолютно непригоден. после 20 выбраных файлов Вы начнете по-тихоньку ругаться, после 100 - громко материться, а после 300 - проклинать этот макрос
Изменено: Ігор Гончаренко - 05.11.2018 19:29:16
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#13
05.11.2018 19:24:06
vikttur, пример он остается. Формулировка задачи тоже - при выборе изображения в таблице на Листе1 в ячейку B3, добавляется изображение формата 100*80 в текущую ячейку, а так же на Лист2 в ячейку С6 более крупного размера 200*160. Дальше, при выборе изображения на Листе1 в ячейке B4 так же появляется более крупный размер в С23.
 
 
 
#14
05.11.2018 19:29:22
Ігор Гончаренко, точно, я это понял, когда удалось добавить 2е изображение на другой лист. Нужно подгонять отступом место положение рисунка. И 2я проблема - это то, что при выборе другого изображения в таблице Листа1, на Листе2 оно накладывается на первое изображение. Прошу Вашей помощи, как можно иначе реализовать задачу?
 
 
 
#15
05.11.2018 19:35:00
а) где брать файлы с изображениями?
б) как каждая строка связана и именем файла с изображением?
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#16
05.11.2018 19:38:34
Ігор Гончаренко,
Цитата
Ігор Гончаренко написал:
а) где брать файлы с изображениями?
Файлы с изображениями будут находиться в папке "Банк изображений", рядом с документом Excel. Как и сейчас в примере.
Цитата
Ігор Гончаренко написал:
б) как каждая строка связана и именем файла с изображением?
Пока никак, каждое изображение сейчас загружается вручную с помощью макроса. Вот если можно было бы как-то привязаться к адресу файла, который мы добавили в таблицу Листа1.
 
 
 
#17
05.11.2018 20:02:05
Сообщение №15. Именно эти вопросы Вас просил раскрыть в уточненном описании задачи. Сейчас в примере одна картинка и указаны места вставки. Но Ва же ужно:
Цитата
Их будет несколько и как-то надо для больших прописывать отдельно куда они должны помещаться
 
 
 
#18
05.11.2018 20:04:27
Код
Sub InsPictures()
  Dim pt$, sht&, f, fso, fd, r&
  Worksheets(1).Cells.RowHeight = 82:  Worksheets(2).Cells.RowHeight = 162
  pt = ThisWorkbook.Path & "\Банк изображений\"
  Set fso = CreateObject("Scripting.FileSystemObject"): Set fd = fso.GetFolder(pt): r = 3
  For Each f In fd.Files
    For sht = 1 To 2
      With Worksheets(sht)
        .Shapes.AddPicture pt & f.Name, False, True, .Cells(r, 3).Left, .Cells(r, 3).Top + 1, 100 * sht, 80 * sht
      End With
    Next
    r = r + 1
  Next
End Sub
Изменено: Ігор Гончаренко - 05.11.2018 20:05:34
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#19
05.11.2018 20:19:02
Небольшое дополнение
Код
Shapes.AddPicture sAddress, False, True, MyCell.Left + 5, MyCell.Top + 5, 100, 80 'для вставки в текущее место

может дать существенное ухудшение качества при изменении размера картинки в момент вставки.
Поэтому, рекомендую вставлять примерно так
Код
                Set cell = Cells(ii, 69)
                Set sha = cell.Worksheet.Shapes.AddPicture(File.Path, False, True, cell.Left + 1, cell.Top + 1, -1, -1)
                With sha
                    .LockAspectRatio = msoFalse
                    .Height = 323    'ht
                    .Width = 431    'wt
                End With

Все параметры подобрать под себя.
Изменено: RAN - 05.11.2018 20:19:45
 
 
 
#20
05.11.2018 20:29:12
RAN, Ігор Гончаренко, слушайте, ну в принципе круто работает! Такой еще момент, как можно при вставке объекта Shapes.AddPicture в свойствах картинки установить "Перемещать и изменять объект вместе с ячейками"?
 
 
 
#21
05.11.2018 20:40:36
Включите макрорекордер, установите это свойство, остановите рекордер и посмотрите получившийся код.
 
 
 
#22
05.11.2018 20:51:15
Юрий М, параметр определился как ".Placement". Не могу никак прикрутить его именно к вставляемому объекту. Макрорекордером он определился как "Selection.Placement = xlMoveAndSize". Как прикрутить этот кусок к имеющемуся коду? )
 
 
 
#23
05.11.2018 21:01:15
Так Вы уже почти всё сделали )) У Вас есть конструкция With  - End With - вот в неё в дополнение к другим свойствам добавьте .Placement = xlMoveAndSize
Справитесь?
 
 
 
#24
05.11.2018 21:05:06
Код
Sub InsPictures()
  Dim pt$, sht&, r&, shp, f, fso, fd
  Worksheets(1).Cells.RowHeight = 82:  Worksheets(2).Cells.RowHeight = 162
  pt = ThisWorkbook.Path & "\Банк изображений\"
  Set fso = CreateObject("Scripting.FileSystemObject"): Set fd = fso.GetFolder(pt): r = 3
  For Each f In fd.Files
    For sht = 1 To 2
      With Worksheets(sht)
        Set shp = .Shapes.AddPicture(pt & f.Name, False, True, .Cells(r, 3).Left, .Cells(r, 3).Top + 1, -1, -1)
        shp.LockAspectRatio = True: shp.Height = 80 * sht:  shp.Placement = xlMoveAndSize
      End With
    Next
    r = r + 1
  Next
End Sub
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#25
05.11.2018 21:14:04
Юрий М, Ігор Гончаренко,ДА, спасибо большое за помощь!
 
 
 
#26
05.11.2018 22:19:47
Вместе мы сила!  :)
 
 
 
#27
06.11.2018 07:04:00
RAN, Ігор Гончаренко, Юрий М, коллеги! в процессе эксплуатации возникли сложности. Картинка загружается качественно, благодаря:
Код
Set sha = MyCell.Worksheet.Shapes.AddPicture(sAddress, False, True, MyCell.Left + 1, MyCell.Top + 1, -1, -1)
    With sha
        .LockAspectRatio = msoFalse
        .Height = 85
        .Width = 107
    End With
Но вот после сохранения документа, качество картинки резко падает, и обновляется связанная с ней большая картинка, все расплывается в пикселях. Скажите, как-то можно настроить параметры так, чтобы при сохранении качество картинки не изменялось?
 
 
 
#28
06.11.2018 12:15:14
никто не знает что из того, что тут было рекомендовано собрали Вы
соотв. никто не знает что там происходит в Вашем файле
соотв. лечение по фотографиям - это на другой форум
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#29
06.11.2018 12:19:10
Ігор Гончаренко, я эмпирическим путем установил, что если второй аргумент Shapes.AddPicture установить True, то качество картинки сохраняется:
Код
Set sha = MyCell.Worksheet.Shapes.AddPicture(sAddress, TRUE, True, MyCell.Left + 1, MyCell.Top + 1, -1, -1)    With sha
        .LockAspectRatio = msoFalse
        .Height = 85
        .Width = 107
    End With
 
 
 
#30
06.11.2018 12:27:42
я обычно действую таким же способом: исправляю код до тех пор, пока он не начнет работать так, как мне нужно

программирование в этом плане сильно отличается от хирургии - Вы можете проводить эксперименты над кодом без нанесения необратимых разрушений (всегда можно зафиксировать какое-то состояние, откатывать к нему столько раз, сколько потребуется и попробовать другие варианты)
а если хирург отрезал не ту ногу, то откатить ситуацию назад и отрезать ту, что нужно - уже не возможно! (т.е. уже можно только отрезать и другую)
Изменено: Ігор Гончаренко - 06.11.2018 12:37:07
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
Страницы: 1 2 След.
Наверх