Здравствуйте. Суть в том, что существующий макрос, который импортирует все фото из указанной папки и располагает их через определенное количество строк, друг за другом, начиная с указанной строки и импортирует их с одинаковым указанным разрешением. [vba]
Код
Sub AddOlEObject()
Dim mainWorkBook As Workbook
Set mainWorkBook = ActiveWorkbook
For i = 4 To ThisWorkbook.Sheets.Count 'отсчет выгрузки фоток с "--" листа
With Sheets(i) 'процедура для каждого листа далее
Sheets(i).Activate
Folder = Range("AB3") 'адрес папки с фотками
Folderpath = Folder 'папка с фотками
Set fso = CreateObject("Scripting.FileSystemObject")
If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _ Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _ Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then counter = counter + 26 'расстояние между фото Call insert(strCompFilePath, counter - 16) 'расстояние от первой строки Sheets(i).Activate End If End If Next End With counter = 0 Next End Sub
Function insert(PicPath, counter)
With ActiveSheet.Pictures.insert(PicPath) With .ShapeRange .LockAspectRatio = msoTrue .Width = 204 'ширина фото .Height = 379 'высота фото End With .Left = ActiveSheet.Range("A" & counter).Left 'расстояние от первой строки (ширина ячейки) .Top = ActiveSheet.Range("A" & counter).Top 'расстояние от первой строки (ширина ячейки) .Placement = 1 .PrintObject = True End With End Function
[/vba]
Это отлично подошло для одного из моих шаблонов, но приходиться раскидывать группы фотографий по папкам для каждого листа. Подскажите как сделать,
что бы на лист импортировались каждые по порядку группы по пять фотографий из одной папки для второго шаблона
(например: в лист n - фото a1,b1,c1,d1,e1; в лист n+1 - фото a2,b2,c2,d2,e2 и т.д.)
при этом с заданным расположением и разрешением фотографий a,b,c,d,e.
Извините за название темы, хотелось максимально все описать.
Вчера мне здорово помогли с корректировкой существующей программы, спасибо!
Здравствуйте. Суть в том, что существующий макрос, который импортирует все фото из указанной папки и располагает их через определенное количество строк, друг за другом, начиная с указанной строки и импортирует их с одинаковым указанным разрешением. [vba]
Код
Sub AddOlEObject()
Dim mainWorkBook As Workbook
Set mainWorkBook = ActiveWorkbook
For i = 4 To ThisWorkbook.Sheets.Count 'отсчет выгрузки фоток с "--" листа
With Sheets(i) 'процедура для каждого листа далее
Sheets(i).Activate
Folder = Range("AB3") 'адрес папки с фотками
Folderpath = Folder 'папка с фотками
Set fso = CreateObject("Scripting.FileSystemObject")
If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _ Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _ Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then counter = counter + 26 'расстояние между фото Call insert(strCompFilePath, counter - 16) 'расстояние от первой строки Sheets(i).Activate End If End If Next End With counter = 0 Next End Sub
Function insert(PicPath, counter)
With ActiveSheet.Pictures.insert(PicPath) With .ShapeRange .LockAspectRatio = msoTrue .Width = 204 'ширина фото .Height = 379 'высота фото End With .Left = ActiveSheet.Range("A" & counter).Left 'расстояние от первой строки (ширина ячейки) .Top = ActiveSheet.Range("A" & counter).Top 'расстояние от первой строки (ширина ячейки) .Placement = 1 .PrintObject = True End With End Function
[/vba]
Это отлично подошло для одного из моих шаблонов, но приходиться раскидывать группы фотографий по папкам для каждого листа. Подскажите как сделать,
что бы на лист импортировались каждые по порядку группы по пять фотографий из одной папки для второго шаблона
(например: в лист n - фото a1,b1,c1,d1,e1; в лист n+1 - фото a2,b2,c2,d2,e2 и т.д.)
при этом с заданным расположением и разрешением фотографий a,b,c,d,e.
Извините за название темы, хотелось максимально все описать.
Вчера мне здорово помогли с корректировкой существующей программы, спасибо!Maratej
nilem, в первом шаблоне формула в ячейке в каждом листе с указанием адреса папки на компе, т.е. в каждый лист загружается из отдельной папки; K-SerJC, да хотелось бы, что бы не надо было раскидывать фотки по папкам, а макрос сам отбирал из папки 1,2,3,4,5 фото (по порядку по наименованию) в первый лист, 6,7,8,9,10 (1+5;2+5;3+5;4+5;5+5) во второй лист и так далее; и желательно, что бы можно было выставить для каждой фотографии (1 и 6; 2 и 7; 3 и 8; 4 и 9; 5 и 10) стандартное расположение на листе расположение на листе.
nilem, в первом шаблоне формула в ячейке в каждом листе с указанием адреса папки на компе, т.е. в каждый лист загружается из отдельной папки; K-SerJC, да хотелось бы, что бы не надо было раскидывать фотки по папкам, а макрос сам отбирал из папки 1,2,3,4,5 фото (по порядку по наименованию) в первый лист, 6,7,8,9,10 (1+5;2+5;3+5;4+5;5+5) во второй лист и так далее; и желательно, что бы можно было выставить для каждой фотографии (1 и 6; 2 и 7; 3 и 8; 4 и 9; 5 и 10) стандартное расположение на листе расположение на листе.Maratej
Sub AddOlEObject() Dim i&, fls, nPic&, fso As Object, counter& Dim strCompFilePath$, Folderpath$ Application.ScreenUpdating = False
Folderpath = Sheets("Макрос1").Range("H2") 'адрес папки с фотками Set fso = CreateObject("Scripting.FileSystemObject") i = 1
For Each fls In fso.GetFolder(Folderpath).Files strCompFilePath = Folderpath & "\" & fls.Name 'названия картинок If InStr(strCompFilePath, "jpg") Or InStr(strCompFilePath, "jpeg") Or InStr(strCompFilePath, "png") Then nPic = nPic + 1: counter = counter + 25 If nPic > 5 Then ' 5 картинок будем вставлять i = i + 1: counter = 25: nPic = 1 If i > ThisWorkbook.Sheets.Count Then Exit For End If Call insPhoto(i, strCompFilePath, counter - 15) 'расстояние от первой строки End If Next Application.ScreenUpdating = True Set fso = Nothing End Sub
Sub insPhoto(nWsh As Long, PicPath As String, counter As Long) With ThisWorkbook.Sheets(nWsh).Pictures.insert(PicPath) With .ShapeRange .Width = 200 'ширина фото .Height = 375 'высота фото End With .Left = Range("B" & counter).Left 'расстояние от первой строки (ширина ячейки) .Top = Range("B" & counter).Top 'расстояние от первой строки (ширина ячейки) .Placement = 1 .PrintObject = True End With End Sub
[/vba]
пробуйте так:
[vba]
Код
Sub AddOlEObject() Dim i&, fls, nPic&, fso As Object, counter& Dim strCompFilePath$, Folderpath$ Application.ScreenUpdating = False
Folderpath = Sheets("Макрос1").Range("H2") 'адрес папки с фотками Set fso = CreateObject("Scripting.FileSystemObject") i = 1
For Each fls In fso.GetFolder(Folderpath).Files strCompFilePath = Folderpath & "\" & fls.Name 'названия картинок If InStr(strCompFilePath, "jpg") Or InStr(strCompFilePath, "jpeg") Or InStr(strCompFilePath, "png") Then nPic = nPic + 1: counter = counter + 25 If nPic > 5 Then ' 5 картинок будем вставлять i = i + 1: counter = 25: nPic = 1 If i > ThisWorkbook.Sheets.Count Then Exit For End If Call insPhoto(i, strCompFilePath, counter - 15) 'расстояние от первой строки End If Next Application.ScreenUpdating = True Set fso = Nothing End Sub
Sub insPhoto(nWsh As Long, PicPath As String, counter As Long) With ThisWorkbook.Sheets(nWsh).Pictures.insert(PicPath) With .ShapeRange .Width = 200 'ширина фото .Height = 375 'высота фото End With .Left = Range("B" & counter).Left 'расстояние от первой строки (ширина ячейки) .Top = Range("B" & counter).Top 'расстояние от первой строки (ширина ячейки) .Placement = 1 .PrintObject = True End With End Sub
Даже не знаю, подставил свой путь, - все работает Попробуйте вставлять как шейпы [vba]
Код
Sub insPhoto(nWsh As Long, PicPath As String, counter As Long) With ThisWorkbook.Sheets(nWsh) With .Cells(counter, 2) .Parent.Shapes.AddPicture PicPath, False, True, .Left, .Top, 200, 375 End With End With End Sub
[/vba]
Даже не знаю, подставил свой путь, - все работает Попробуйте вставлять как шейпы [vba]
Код
Sub insPhoto(nWsh As Long, PicPath As String, counter As Long) With ThisWorkbook.Sheets(nWsh) With .Cells(counter, 2) .Parent.Shapes.AddPicture PicPath, False, True, .Left, .Top, 200, 375 End With End With End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
