Здравствуйте, нашел отличный макрос у Дмитрия Щербакова (не знаю можно ли на другой сайт оставлять ссылку)
Помогите пожайлуста добавить следующее (что возможно из списка ниже):
1. Размеры картинки подгонялись под размеры ячейки (по вертикали и горизонтали), сейчас макрос делает только по вертикали
2. можно было задать разрешение
3. Поиск фото по нескольким папкам (например есть папка «Товар» внутри этой папки картинки по категориям «Категория1» Категория2» итд, в макросе указать путь к папке «Товар» и он по категориям просматривал и вставлял нужное фото)
4. Можно было вставлять изображение по имени, или по гиперссылке.
Код
Sub InsertPictureByVal()
Dim sPicsPath As String
Dim sPicName As String, sPFName As String, sSpName As String
Dim llastr As Long, lr As Long
Dim oShp As Shape
Dim zoom As Double
'выбираем путь к папке с картинками
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Выбрать папку с картинками" 'заголовок окна диалога
.ButtonName = "Выбрать папку"
.Filters.Clear 'очищаем установленные ранее типы файлов
.InitialFileName = ThisWorkbook.Path 'назначаем первую папку отображения
.InitialView = msoFileDialogViewLargeIcons 'вид диалогового окна
If .Show = 0 Then Exit Sub 'показываем диалог
sPicsPath = .SelectedItems(1) 'считываем путь к папке
End With
' если путь надо указать статичный - вместо диалога прописываем одну строку
' sPicsPath = "C:\images\"
'проверяем, есть ли слеш после пути к папке
'если нет - добавляем, иначе путь к картинке будет неверный
If Right(sPicsPath, 1) <> Application.PathSeparator Then
sPicsPath = sPicsPath & Application.PathSeparator
End If
'определяем последнюю ячейку по столбцу с именами картинок
llastr = Cells(Rows.Count, 2).End(xlUp).Row
'если кроме шапки в столбце с именами картинок ничего нет
If llastr < 2 Then
Exit Sub
End If
'цикл по столбцу с именами картинок
For lr = 2 To llastr
sPicName = Cells(lr, 2).Value
'проверяем наличие картинки в папке
sPFName = sPicsPath & sPicName
If Dir(sPFName, 16) <> "" And sPicName <> "" Then
'в эту ячейку вставляем картинку
With Cells(lr, 3)
'задаем картинке уникальный адрес,
'привязанный к адресу ячейки
sSpName = "_" & .Address(0, 0) & "_autopaste"
'если картинка уже есть - удаляем её
Set oShp = Nothing
On Error Resume Next
Set oShp = ActiveSheet.Shapes(sSpName)
If Not oShp Is Nothing Then
oShp.Delete
End If
On Error GoTo 0
'вставляем выбранную картинку
Set oShp = ActiveSheet.Shapes.AddPicture(sPFName, False, True, .Left + 1, .Top + 1, -1, -1)
'определяем размеры картинки в зависимости от размера ячейки
zoom = Application.Min(.Width / oShp.Width, .Height / oShp.Height)
oShp.Height = oShp.Height * zoom - 2
'переименовываем вставленную картинку(чтобы потом можно было заменить)
oShp.Name = sSpName
End With
End If
Next
End Sub
Да я уже знаком с этим решением. Но когда в свободном доступе есть макрос Щербакова (который 70% выполняет Вашей надстройки), то цена великовата за надстройку. Тем более ею пользоваться не каждый день.
Повторю здесь. Готовая надстройка стоит 1500. Макрос который я нашел уже выполняет что нужно. Но если добавить то что я писал было немного лучше. Поэтому такая цена.
Конечно больше я не спорю. Но все описанные пункты реализовать уже можно сейчас без дополнительной доработки. Например размер и сжимать делается через выделить все и задать нужный параметр. Насчет поиска по папкам с помощью тотал командер можно скопировать все содержимое в одну папку итд.До того момента пока Щербаков не выложил свой макрос цена была актуальна и для надстройки Игоря. Но сейчас ситуация другая. Тем более что данную операцию нужно делать очень редко.
Евген1788, ситуация выглядит смешно: Вы, не имея навыков программирования и не представляя, сколько времени потребуется для написания и тестирования макроса, утверждаете, что 500 р. - адекватная цена. В то же время люди, которые занимаются программированием, утверждают, что это мало. В противном случае давно бы уже кто-нибудь откликнулся. Но в любом случае определять СВОЙ бюджет - исключительно Ваше право )) Остаётся только ждать исполнителя, который согласится на Ваги условия.
Евген1788 написал: Тем более что данную операцию нужно делать очень редко.
Согласен, не спорю, успехов. Приношу извинения за излишний offtop. Спасибо, что поделились своими рассуждениями - всегда было интересно, как люди строят логические цепочки.
Юрий М, Да не имею, но я понимаю что это очень сложно, основной причиной такой цены именно всего это БЕСПЛАТНЫЙ макрос Щербакова, не будь его все было бы иначе. Тем более все свои задачи я уже могу выполнить просто немного больше движений надо сделать,но эта задача не каждый день, поэтому нету смысла платить больше (но это в моем случае) кто ежедневно этим занимается есть смысл подумать о надстройке Игоря (кстати надстройка очень классная). Надстройка Игоря стоит 1500р, человек предлагает доделать макрос минимум за 2000, это целесообразно ?
Андрей VG, Наоборот надо обсуждать и смотреть с разных сторон и никакого offtop в этом нету, просто Вы со своей стороны это видите, я о своей, надо как то к общему знаменателю прийти да и все
Доброго времени суток знатоки VBA. Работая каждый день с этой базой, наконец решил облегчить себе учесть. Со ценами не знаком. Подскажите на сколько это сложно и во сколько мне это обойдется. Прикрепил 2 файла. один файл заказа, там примером написал разнообразие возможных перечислений в заказе. второй пример базы. где при подобном заказе пример выполнения как все должно заполнятся. не знаю даже сюда ли заказы писать)