Sub ВставкаКартинок()
Attribute ВставкаКартинок.VB_ProcData.VB_Invoke_Func = "q\n14"
'
' выделение первого столбца и редактирование
Columns("A:B").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
'.Font.Bold = True
.Font.Size = 9
End With
' Изменение высоты и ширины столбца В
Columns("B:B").Select
Selection.RowHeight = 50
Selection.ColumnWidth = 15
'-------------------------------------
Dim a As String
' цикл пока не кончатся значения
20 While ActiveSheet.Cells(i + 1, 1).Value <> ""
i = i + 1
b = ActiveSheet.Cells(i, 1).Value
'------------------------------
' замена символов
b = Application.Substitute(b, "/", "_", 1)
b = Application.Substitute(b, "А", "A", 1)
b = Application.Substitute(b, "В", "B", 1)
b = Application.Substitute(b, "У", "", 1)
'------------------------------
If Dir("\\smbsrv\dshare\ФотоНоменклатуры\ФОТО\" & b & ".jpg") = "" Then GoTo Error404
a = "\\smbsrv\dshare\ФотоНоменклатуры\ФОТО\" & b & ".jpg"
' выделение второго столбца, чтобы вставлять туда
Cells(i, 2).Select
Dim MyPicture As Excel.Picture
Set MyPicture = ActiveSheet.Shapes.AddPicture("\\smbsrv\dShare\фотономенклатуры\фото\" & b & ".jpg", False, True, -1, -1, -1, -1)
MyPicture.ShapeRange.Height = 50
' перемещать и сортировать вместе с ячейками
MyPicture.Placement = xlMoveAndSize
MyPicture.PrintObject = True
Wend
GoTo 10
Error404:
код прикрепил. пробовал его поправить, но пока не выходит.
Если добавлять вручную, то он добавляется. Проблема не в этом. Проблема в том, что на шару где лежат фото, выкладывают готовый файл, где уже все собрано. файл открывается. а картинок неть. И потом хотелось бы чтобы картинки сохранялись в файле, ибо часть файлов отправляется поставщикам. а они без картинок не принимают. Вот этот момент я попробовал переделать, до этого код был немного другой.
