Страницы: 1
RSS
Вставить изображение в ячейку эксель програмно, Вставить изображение в ячейку эксель програмно
 

Здравствуйте, нашел отличный макрос у Дмитрия Щербакова (не знаю можно ли на другой сайт оставлять ссылку)

Помогите пожайлуста добавить следующее (что возможно из списка ниже):

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
Изменено: Евген1788 - 15.08.2020 23:46:56
 
Один вопрос - одна тема. Комплексно - в разделе Работа
 
Заново там создать или перенесете туда?
 
Перенесена
 
Есть готовое решение
Контакты в профиле
 
Да я уже знаком с этим решением. Но когда в свободном доступе есть макрос Щербакова (который  70% выполняет Вашей надстройки), то цена великовата за надстройку. Тем более ею пользоваться не каждый день.  
 
Доброе время суток
Цитата
Евген1788 написал:
цена великовата
Тогда озвучьте свою цену - быстрее исполнителя найдёте.
 
Мне бы понять что можно из моего списка реализовать. И уже исходя из этого думать какая цена
 
Пишу в личку.
 
Здравствуйте, только увидел. Уже ответил  
 
Я пас (бюджет ТС до 500р за все).
 
Повторю здесь. Готовая надстройка стоит 1500. Макрос который я нашел уже выполняет что нужно. Но если добавить то что я писал было немного лучше. Поэтому такая цена.  
 
Цитата
Евген1788 написал:
Но если добавить то что я писал было немного лучше. Поэтому такая цена
А вы не задумывались над таким вопросом, что это немного по коду может быть больше, чем найденный макрос?
 
Конечно больше я не спорю. Но все описанные пункты реализовать уже можно сейчас без дополнительной доработки. Например размер и сжимать делается через выделить все и задать нужный параметр. Насчет поиска по папкам с помощью тотал командер можно скопировать все содержимое в одну папку итд.До того момента пока Щербаков не выложил свой макрос цена была актуальна и для надстройки Игоря. Но сейчас ситуация другая. Тем более что данную операцию нужно делать очень редко.  
 
Евген1788, ситуация выглядит смешно: Вы, не имея навыков программирования и не представляя, сколько времени потребуется для написания и тестирования  макроса, утверждаете, что 500 р. - адекватная цена. В то же время люди, которые занимаются программированием, утверждают, что это мало. В противном случае давно бы уже кто-нибудь откликнулся.
Но в любом случае определять СВОЙ бюджет - исключительно Ваше право )) Остаётся только ждать исполнителя, который согласится на Ваги условия.
 
Цитата
Евген1788 написал:
Тем более что данную операцию нужно делать очень редко.  
Согласен, не спорю, успехов. Приношу извинения за излишний offtop. Спасибо, что поделились своими рассуждениями - всегда было интересно, как люди строят логические цепочки.
Изменено: Андрей VG - 16.08.2020 14:16:30
 
Юрий М, Да не имею, но я понимаю что это очень сложно, основной причиной такой цены именно всего это БЕСПЛАТНЫЙ макрос Щербакова, не будь его все было бы иначе. Тем более все свои задачи я уже могу выполнить просто немного больше движений надо сделать,но эта задача не каждый день, поэтому нету смысла платить больше (но это в моем случае) кто ежедневно этим занимается есть смысл подумать о надстройке Игоря (кстати надстройка очень классная).
Надстройка Игоря стоит 1500р, человек предлагает доделать макрос минимум за 2000, это целесообразно ?
Изменено: Евген1788 - 16.08.2020 15:01:03
 
Андрей VG, Наоборот надо обсуждать и смотреть с разных сторон и никакого offtop  в этом нету, просто Вы со своей стороны это видите, я о своей, надо как то к общему знаменателю прийти да и все
 
Доброго времени суток знатоки VBA. Работая каждый день с этой базой, наконец решил облегчить себе учесть. Со ценами не знаком. Подскажите на сколько это сложно и во сколько мне это обойдется.
Прикрепил 2 файла. один файл заказа, там примером написал разнообразие возможных перечислений в заказе. второй пример базы. где при подобном заказе пример выполнения как все должно заполнятся.
не знаю даже сюда ли заказы писать)
 
Создайте отдельную тему
 
Цитата
vikttur написал:
Создайте отдельную тему
Я могу уже брать деньги за аренду ))
 
Цитата
Евген1788 написал:
нашел отличный макрос у Дмитрия Щербакова
А почему бы Вам не обратиться напрямую к Дмитрию?
Цитата
Евген1788 написал:
Я могу уже брать деньги за аренду
так и цену за макрос отобьёте  :D  
Страницы: 1
Наверх