Здравствуйте, уважаемые эксперты! С учетом всех замечаний позвольте мне исправиться. Помогите пожалуйста решить такую задачу: Есть файл (во вложении price.xls). Это прайс-лист. В нем, в графе "ITEM NO." указаны артикулы товаров. Также в комплекте с этим прайсом идет папка с фотографиями (пример во вложении pict.zip). Имена файлов изображений в этой папке соответствуют артикулам товаров. Размеры у изображений разные. Нужно вставить изображения из этой папки в прайс-лист в графу "Item Photos" в соответствии с артикулами в графе "ITEM NO.", при этом уменьшив эти изображения до приемлемого для прайс-листа размера 100 по высоте с сохранением пропорций по ширине и подогнав высоту строки под высоту этих изображений.
нет размера 50-100 есть размер 50, 51, 52, 53 ... продолжать? размер задается один на весь прайс или вычисляется к каждом конкретном случае (нужен алгоритм вычисления размера)
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
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
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
положение курсора не важно важно чтобы каждому значению в колонке В активного листа соответствовал файл с аналогичным именем, находящийся в той же папке, что и файл с макросом!
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
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
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!