Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Не работает макрос - вставка картинки в примечание
 
#1
18.05.2018 09:38:41
Добрый день, всем!
Я ни на минуточку не программист, но на этом сайте нашла макрос Николая. Это то, что мне нужно!
Все сделала по инструкции, даже отредактировала диапазоны и запустила макрос (не смейтесь, для меня это достижение :))))
Но выдается ошибка, в чем дело не понимаю :( http://take.ms/xSKhdv
Буду очень благодарна за помощь.  
 
 
 
#2
18.05.2018 14:36:01
eliina, попробуйте сохранить картинки на компьютер (и изменить соответственно пути в колонках J:K). Кажется, этот макрос не может скачивать картинки  из интернета.
Изменено: tolstak - 18.05.2018 14:36:23
In GoTo we trust
 
 
 
#3
18.05.2018 14:57:48
Спасибо большое за ответ, tolstak!
Можно ли доработать этот макрос, чтобы он скачивал картинку?
Мне нужно в экселевский файл вставить картинки. Если я сохраню картинки на компьютер, то как я их потом привяжу к нужным моделям?
Их много, очень много.
 
 
 
#4
18.05.2018 16:00:12
eliina, можно :-)
Файлы сохраняются в подпапку Pics в месте сохранения файла, и оттуда заносятся в книгу
Код
' WinApi
Public Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Sub InsertPicturesInComments()
     Dim rngPics As Range, rngOut As Range
    Dim i As Long, p As String, w As Long, h As Long
    Set rngPics = Range("K3:K32")    'диапазон путей к картинкам
    Set rngOut = Range("C3:C32")     'диапазон вывода примечаний
    rngOut.ClearComments        'удаляем старые примечания
    'проходим в цикле по ячейкам
    For i = 1 To rngPics.Cells.Count
        p = rngPics.Cells(i, 1).Value       'считываем путь к файлу картинки
        sd = loadPicFromInternet(p)
        DoEvents
        w = LoadPicture(sd).Width            'и ее размеры
        h = LoadPicture(sd).Height
        With rngOut.Cells(i, 1)
            .AddComment.Text Text:=""       'создаем примечание без текста
            .Comment.Visible = True
            .Comment.Shape.Select True
        End With
        With rngOut.Cells(i, 1).Comment.Shape   'заливаем картинкой
            .Fill.UserPicture sd
            .ScaleWidth 1, msoFalse, msoScaleFromTopLeft
            .ScaleHeight h / w * 1.8, msoFalse, msoScaleFromTopLeft     'корректируем размеры
        End With
    Next i
End Sub

' Загрузка по URL
Function loadPicFromInternet(ByVal RequestAddr As String) As String
    Dim fileTmpFolderTxt As String, picName As String, fileTmpPath As String, fso As Object
    ' Папка для загрузки картинок = путь до этой книги / pics/
    fileTmpFolderTxt = ThisWorkbook.Path & "/pics/"
    ' Разделяем адрес URL на части по слэшу
    tmpArr = Split(RequestAddr, "/")
    ' Имя картинки для сохранения - все что после последнего слэша
    picName = tmpArr(UBound(tmpArr))
    ' Полный путь до файла
    fileTmpPath = fileTmpFolderTxt & picName
    ' Объект для взаимодействия с файловой системой
    Set fso = CreateObject("Scripting.FileSystemObject")
    ' Если папка для сохранения картинок не существует - создадим
    If Not fso.FolderExists(fileTmpFolderTxt) Then
        fso.CreateFolder fileTmpFolderTxt
    Else
        ' Если существует - проверим, а вдруг там уже есть файл
        ' Если есть - выдаем на него ссылку и выходим из функции
        If fso.FileExists(fileTmpPath) Then
            loadPicFromInternet = fileTmpPath
            Exit Function
        End If
    End If
    ' Папка создана, файла с таким именем нет - скачиваем с помощью WinApi
    URLDownloadToFile 0, RequestAddr, fileTmpPath, 0, 0
    ' Выдаем ссылку на файл
    loadPicFromInternet = fileTmpPath
End Function
Изменено: tolstak - 19.05.2018 10:15:58
In GoTo we trust
 
 
 
#5
18.05.2018 23:05:42
Спасибо Вам большое, Tolstak, за то, что помогаете мне!
Макрос на что-то ругнулся, скрин здесь: http://take.ms/umnjD. Мне надо что-то переустановить, чтобы заработало?
А если в какой-то строчке картинки не будет? Он перейдет к следующей или зависнет?
Изменено: eliina - 19.05.2018 00:07:48
 
 
 
#6
18.05.2018 23:25:32
eliina,
если у Вас не работает макрос вставки картинки в примечания значит у Вас что-то не так:
- с картинками
- с примечаниями
- с макросом
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#7
19.05.2018 00:03:02
Я вижу, что у меня не получается.
У меня задача - отобразить картинки в экселе. Я это делаю поштучно и трачу на это уйму сил и времени. На этом замечательном сайте нашла Макрос Николая, который делает то, что мне нужно. Я хотела вставлять картинки в ячейки, но потом мне объяснили, что сложно масштабировать картинки, поэтому их проще вставить в примечания.

Отличие в том, что мои картинки находятся в интернете. А я сама программировать не умею совсем. Могу немного поправить диапазон, сделать еще какие-то простейшие вещи (чаще методом тыка), когда есть примечания к команде.

Tolstak помогает мне, за что ему огромное спасибо.
 
 
 
#8
19.05.2018 00:06:12
Irop Гончаренко, у Вас классная подпись!
Изменено: eliina - 19.05.2018 00:06:35
 
 
 
#9
19.05.2018 00:32:23
eliina, а Вы пробовали перевести сообщение, которое на скрине?
 
 
 
#10
19.05.2018 01:00:58
пробовала :)
даже с помощью переводчика перевела.
А что делать дальше не поняла.
Если надо что-то переустановить, то подскажите, пожалуйста. Я сделаю, как надо.
 
 
 
#11
19.05.2018 01:09:06
Строка, которая подсвечена красным, написана для 32-битной версии, а у Вас более современная - 64 бита.
 
 
 
#12
19.05.2018 01:13:20
А Вы можете переделать эту строку для 64-битной версии? Или это в принципе невозможно? (Вы=программисты)
Изменено: eliina - 19.05.2018 01:14:02
 
 
 
#13
19.05.2018 08:28:04
eliina, попробуйте заменить
Код
Public Declare Function
на
Код
Public Declare PtrSafe Function
In GoTo we trust
 
 
 
#14
19.05.2018 08:43:21
Доброе время суток.
Цитата
tolstak написал:
Public Declare PtrSafe Function
Коллега, предполагаю, что в объявлении нужно ещё в двух местах LongPtr указать. К сожалению, в Win32API_PtrSafe.TXT не описано.
 
 
 
#15
19.05.2018 09:30:38
Спасибо всем, кто откликнулся!
Макрос отработал первую строчку. Споткнулся в середине, здесь http://take.ms/UBjII.
Ошибка такая http://take.ms/lguCd
Изменено: eliina - 19.05.2018 09:31:30
 
 
 
#16
19.05.2018 10:09:45
eliina, правильно ли понимаю, что останавливается на строчке где нет картинки?
Добавил проверку на пропуск пустых строчек
Код
' WinApi
Public Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Sub InsertPicturesInComments()
     Dim rngPics As Range, rngOut As Range
    Dim i As Long, p As String, w As Long, h As Long
    Set rngPics = Range("K3:K32")    'диапазон путей к картинкам
    Set rngOut = Range("C3:C32")     'диапазон вывода примечаний
    rngOut.ClearComments        'удаляем старые примечания
    'проходим в цикле по ячейкам
    For i = 1 To rngPics.Cells.Count
        p = rngPics.Cells(i, 1).Value       'считываем путь к файлу картинки
        ' Проверяем, что адрес загрузки не пуст
        If p <> "" Then
            sd = loadPicFromInternet(p)
            DoEvents
            w = LoadPicture(sd).Width            'и ее размеры
            h = LoadPicture(sd).Height
            With rngOut.Cells(i, 1)
                .AddComment.Text Text:=""       'создаем примечание без текста
                .Comment.Visible = True
                .Comment.Shape.Select True
            End With
            With rngOut.Cells(i, 1).Comment.Shape   'заливаем картинкой
                .Fill.UserPicture sd
                .ScaleWidth 1, msoFalse, msoScaleFromTopLeft
                .ScaleHeight h / w * 1.8, msoFalse, msoScaleFromTopLeft     'корректируем размеры
            End With
        End If
    Next i
End Sub

' Загрузка по URL
Function loadPicFromInternet(ByVal RequestAddr As String) As String
    Dim fileTmpFolderTxt As String, picName As String, fileTmpPath As String, fso As Object
    ' Папка для загрузки картинок = путь до этой книги / pics/
    fileTmpFolderTxt = ThisWorkbook.Path & "/pics/"
    ' Проверяем, что адрес загрузки не пуст
    If RequestAddr <> "" Then
        ' Разделяем адрес URL на части по слэшу
        tmpArr = Split(RequestAddr, "/")
        ' Имя картинки для сохранения - все что после последнего слэша
        picName = tmpArr(UBound(tmpArr))
        ' Полный путь до файла
        fileTmpPath = fileTmpFolderTxt & picName
        ' Объект для взаимодействия с файловой системой
        Set fso = CreateObject("Scripting.FileSystemObject")
        ' Если папка для сохранения картинок не существует - создадим
        If Not fso.FolderExists(fileTmpFolderTxt) Then
            fso.CreateFolder fileTmpFolderTxt
        Else
            ' Если существует - проверим, а вдруг там уже есть файл
            ' Если есть - выдаем на него ссылку и выходим из функции
            If fso.FileExists(fileTmpPath) Then
                loadPicFromInternet = fileTmpPath
                Exit Function
            End If
        End If
        ' Папка создана, файла с таким именем нет - скачиваем с помощью WinApi
        URLDownloadToFile 0, RequestAddr, fileTmpPath, 0, 0
        ' Выдаем ссылку на файл
        loadPicFromInternet = fileTmpPath
    Else
        loadPicFromInternet = ""
    End If
End Function


Андрей VG, спасибо за замечание. К сожалению, недостаточно компетентен в вопросах взаимодействия с WinApi. Вы часом не знаете ресурс, где можно было бы ознакомиться детально с этой темой (и разницей 32 и 64 версий)?
Изменено: tolstak - 19.05.2018 10:19:39
In GoTo we trust
 
 
 
#17
19.05.2018 10:31:33
Tolstak, спасибо. Макрос работает!!!
Вы столько времени на меня потратили, как я могу отблагодарить Вас?
 
 
 
#18
19.05.2018 10:32:41
eliina, рад помочь) Ничего не нужно, просто была интересна Ваша задача :)
In GoTo we trust
 
 
 
#19
19.05.2018 10:40:40
Tolstak, СПАСИБО Вам еще раз. Вы мне столько времени сэкономили.
Благодарю тысячу раз!
 
 
 
#20
19.05.2018 12:03:58
Tolstak, видимо, воспользуюсь Вашей добротой еще раз.
У меня есть второй формат файла. Я надеялась, что сама адаптирую Ваш макрос. Не получилось...
Я картинку использую из столбца J.
 
 
 
#21
19.05.2018 13:53:24
eliina, готово :)
3 из 4 картинок не найдены на сервере, добавил еще одну проверку - вставляются только те, которые найдены.
Код
' WinApi
Public Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
 
Sub InsertPicturesInComments()
    Dim rngPics As Range, rngOut As Range
    Dim i As Long, p As String, w As Long, h As Long
    Dim fso As Object
    Set rngPics = Range("J2:J5")    'диапазон путей к картинкам
    Set rngOut = Range("F2:F5")     'диапазон вывода примечаний
    rngOut.ClearComments        'удаляем старые примечания
    
    ' Объект для взаимодействия с файловой системой
    Set fso = CreateObject("Scripting.FilesystemObject")
    
    'проходим в цикле по ячейкам
    For i = 1 To rngPics.Cells.Count
        p = rngPics.Cells(i, 1).Value       'считываем путь к файлу картинки
        ' Проверяем, что адрес загрузки не пуст
        If p <> "" Then
            ' Функция загрузки из интернета
            sd = loadPicFromInternet(p)
            DoEvents
            ' Вставляем комментарий если картинка найдена в директории, иначе - пропускаем
            If fso.FileExists(sd) = True Then
                w = LoadPicture(sd).Width            'и ее размеры
                h = LoadPicture(sd).Height
                With rngOut.Cells(i, 1)
                    .AddComment.Text Text:=""       'создаем примечание без текста
                    .Comment.Visible = True
                    .Comment.Shape.Select True
                End With
                With rngOut.Cells(i, 1).Comment.Shape   'заливаем картинкой
                    .Fill.UserPicture sd
                    .ScaleWidth 1, msoFalse, msoScaleFromTopLeft
                    .ScaleHeight h / w * 1.8, msoFalse, msoScaleFromTopLeft     'корректируем размеры
                End With
            End If
        End If
    Next i
End Sub
 
' Загрузка по URL
Function loadPicFromInternet(ByVal RequestAddr As String) As String
    Dim fileTmpFolderTxt As String, picName As String, fileTmpPath As String, fso As Object
    ' Папка для загрузки картинок = путь до этой книги / pics/
    fileTmpFolderTxt = ThisWorkbook.Path & "/pics/"
    ' Проверяем, что адрес загрузки не пуст
    If RequestAddr <> "" Then
        ' Разделяем адрес URL на части по слэшу
        tmpArr = Split(RequestAddr, "/")
        ' Имя картинки для сохранения - все что после последнего слэша
        picName = tmpArr(UBound(tmpArr))
        ' Полный путь до файла
        fileTmpPath = fileTmpFolderTxt & picName
        ' Объект для взаимодействия с файловой системой
        Set fso = CreateObject("Scripting.FileSystemObject")
        ' Если папка для сохранения картинок не существует - создадим
        If Not fso.FolderExists(fileTmpFolderTxt) Then
            fso.CreateFolder fileTmpFolderTxt
        Else
            ' Если существует - проверим, а вдруг там уже есть файл
            ' Если есть - выдаем на него ссылку и выходим из функции
            If fso.FileExists(fileTmpPath) Then
                loadPicFromInternet = fileTmpPath
                Exit Function
            End If
        End If
        ' Папка создана, файла с таким именем нет - скачиваем с помощью WinApi
        URLDownloadToFile 0, RequestAddr, fileTmpPath, 0, 0
        ' Выдаем ссылку на файл
        loadPicFromInternet = fileTmpPath
    Else
        loadPicFromInternet = ""
    End If
End Function
In GoTo we trust
 
 
 
#22
19.05.2018 17:47:42
Цитата
tolstak написал:
Вы часом не знаете ресурс, где можно было бы ознакомиться детально с этой темой (и разницей 32 и 64 версий)?
Коллега, есть типовые шаблоны для новых, начиная с 2010, версий Excel. Ссылка на скачку. Можно не устанавливать, а по Ctrl+PgDown в Double Commander войти дважды и извлечь выше указанный файл.
Странно почему сработало. По описанию
pCaller A pointer to the controlling IUnknown, то есть в 64бит должен быть 64 битным целым.
Аналогично lpfnCB A pointer to the IBindStatusCallback interface of the caller.
Может что для этих целей Microsoft под шаманила.
Цитата
tolstak написал:
где можно было бы ознакомиться детально с этой темой (и разницей 32 и 64 версий)?
Например, тут.
Успехов.
 
 
 
#23
19.05.2018 18:24:41
Андрей VG, спасибо!
In GoTo we trust
 
 
 
#24
19.05.2018 19:25:31
Tolstak, Андрей VG, спасибо вам большое за помощь!  :*  
 
 
 
#25
19.05.2018 20:25:13
Здравствуйте, коллеги! Подозреваю, что правильно так
Код
#If VBA7 Then   ' для Excel 2010+
Public Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As LongPtr, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As LongPtr) As Long
#Else           ' для Excel до 2007
Public Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#End If
А вообще, нужно всегда использовать Unicode-версии API.
Код
#If VBA7 Then   ' для Excel 2010+
Public Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileW" (ByVal pCaller As LongPtr, ByVal szURL As LongPtr, ByVal szFileName As LongPtr, ByVal dwReserved As Long, ByVal lpfnCB As LongPtr) As Long
#Else           ' для Excel до 2007
Public Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileW" (ByVal pCaller As Long, ByVal szURL As Long, ByVal szFileName As Long, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#End If
При этом строка вызова выглядит так:
Код
URLDownloadToFile 0, StrPtr(RequestAddr), StrPtr(fileTmpPath), 0, 0
Изменено: sokol92 - 20.05.2018 18:13:30
Владимир
 
 
 
#26
19.05.2018 20:34:28
Цитата
sokol92 написал:
Подозреваю, что правильно так
Привет, Владимир.
Спасибо. Хотя есть у меня сомнения, что это правильно ByVal dwReserved As LongPtr, учитывая по описанию, что dwReserved имеет тип DWORD. Тут пишут, что
Код
On any machine, be it 16, 32, or 64 bits, a DWORD[B] is always 32 bits long[/B]
 
 
 
#27
19.05.2018 20:39:00
Здравствуйте, Андрей! Насчет dwReserved просмотрел, хотя проверить сложно (этот параметр не задействован). Сейчас исправлю. Добавил также Unicode версии.
Владимир
 
 
 
#28
19.05.2018 22:33:20
Цитата
Андрей VG написал:
Может что для этих целей Microsoft под шаманила.
Все проще, указанные параметры не были задействованы при вызове функции - а то бы вылетело со свистом.
Изменено: sokol92 - 19.05.2018 22:34:09
Владимир
 
 
 
Страницы: 1
Наверх