Страницы: 1
RSS
Как реализовать массовую вставку картинок в прайс-лист в соответствии с артикулами и с сохранением пропорций
 
Здравствуйте, уважаемые эксперты! С учетом всех замечаний позвольте мне исправиться. Помогите пожалуйста решить такую задачу:
Есть файл (во вложении price.xls). Это прайс-лист. В нем, в графе "ITEM NO." указаны артикулы товаров. Также в комплекте с этим прайсом идет папка с фотографиями (пример во вложении pict.zip). Имена файлов изображений в этой папке соответствуют артикулам товаров. Размеры у изображений разные. Нужно вставить изображения из этой папки в прайс-лист в графу "Item Photos" в соответствии с артикулами в графе "ITEM NO.", при этом уменьшив эти изображения до приемлемого для прайс-листа размера 100 по высоте с сохранением пропорций по ширине и подогнав высоту строки под высоту этих изображений.
Изменено: whitemanehorsey - 10.10.2018 15:06:44
 
нет размера 50-100
есть размер 50, 51, 52, 53 ... продолжать?
размер задается один на весь прайс или вычисляется к каждом конкретном случае (нужен алгоритм вычисления размера)
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Ігор Гончаренко, размер задается один на весь прайс. Пусть будет 100 по высоте с сохранением пропорций по ширине.
Изменено: whitemanehorsey - 09.10.2018 23:09:45
 
whitemanehorsey,
Нашел код в копилке, добавляет фото в комментарии. Модифицировать уже не проблема под себя ;)
Код
Sub bb()
    With ActiveSheet.Range("B4")
        .AddComment
        With .Comment
            .Visible = False
            .Text Text:=" "
            With .Shape
                .Fill.Transparency = 0#
                .Fill.Visible = msoTrue
                .Fill.UserPicture "D:\002.jpg"
                .ScaleWidth 1.47, msoFalse, msoScaleFromTopLeft
                .ScaleHeight 1.91, msoFalse, msoScaleFromTopLeft
            End With
       End With
    End With
End Sub
Изменено: ivanok_v2 - 09.10.2018 23:33:15
 
Код
Sub InsPictures()
  Const sz& = 100
  Dim r&:  r = 7
  Do While Not IsEmpty(Cells(r, 2))
    With ActiveSheet.Pictures.Insert(ThisWorkbook.Path & Application.PathSeparator & Cells(r, 2) & ".jpeg")
    Rows(r).RowHeight = sz: .Left = 0: .Top = Cells(r, 1).Top: .ShapeRange.LockAspectRatio = msoTrue: .Height = sz
    End With: r = r + 1
  Loop
End Sub
Изменено: Ігор Гончаренко - 09.10.2018 23:47:32
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Ігор Гончаренко, спасибо, но почему-то не работает, выдает ошибку:


Куда мне нужно поставить курсор перед запуском?

ivanok_v2, Интересный метод, спасибо, но нужно вставить изображения именно в ячейки, а не в комментарии, чтобы получилось что-то типа:
 
Изменено: whitemanehorsey - 10.10.2018 02:10:17
 
положение курсора не важно
важно чтобы каждому значению в колонке В активного листа соответствовал файл с аналогичным именем, находящийся в той же папке, что и файл с макросом!  
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Код
Sub InsPictures()
  Const sz& = 100
  Dim r&, fn$:  r = 7
  Do While Not IsEmpty(Cells(r, 2))
    fn = ThisWorkbook.Path & Application.PathSeparator & Cells(r, 2) & ".jpeg"
    If Dir(fn) = "" Then
      Cells(r, 1) = "нет файла!!!"
    Else
      With ActiveSheet.Pictures.Insert(fn)
        Rows(r).RowHeight = sz: .Left = 0: .Top = Cells(r, 1).Top: .ShapeRange.LockAspectRatio = msoTrue: .Height = sz
      End With
    End If
    r = r + 1
  Loop
End Sub
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Ігор Гончаренко, круть, спасибо! Исправил ".jpeg" на ".jpg" и заработало! А можно пару уточнений?
Код
 Dim r&, fn$:  r = 7
Я правильно понял, что r = 7 - это стартовая ячейка? Можно ее как-то сделать переменной, чтобы начинало с той ячейки, куда установлен курсор?

И возможно ли как-то уйти от расширения? Это скорее гипотетический вопрос, т.к. кроме джипегов пока ничего не присылали.
 
r = 7 - это стартовая строка
уйти от расширений:
...  & Cells(r, 2) & ".*"
Изменено: Ігор Гончаренко - 10.10.2018 18:01:25
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Ігор Гончаренко, спасибо!
Страницы: 1
Наверх