Добрый день, всем! Я ни на минуточку не программист, но на этом сайте нашла макрос Николая. Это то, что мне нужно! Все сделала по инструкции, даже отредактировала диапазоны и запустила макрос (не смейтесь, для меня это достижение ))) Но выдается ошибка, в чем дело не понимаю http://take.ms/xSKhdv Буду очень благодарна за помощь.
eliina, попробуйте сохранить картинки на компьютер (и изменить соответственно пути в колонках J:K). Кажется, этот макрос не может скачивать картинки из интернета.
Спасибо большое за ответ, tolstak! Можно ли доработать этот макрос, чтобы он скачивал картинку? Мне нужно в экселевский файл вставить картинки. Если я сохраню картинки на компьютер, то как я их потом привяжу к нужным моделям? Их много, очень много.
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, за то, что помогаете мне! Макрос на что-то ругнулся, скрин здесь: http://take.ms/umnjD. Мне надо что-то переустановить, чтобы заработало? А если в какой-то строчке картинки не будет? Он перейдет к следующей или зависнет?
Я вижу, что у меня не получается. У меня задача - отобразить картинки в экселе. Я это делаю поштучно и трачу на это уйму сил и времени. На этом замечательном сайте нашла Макрос Николая, который делает то, что мне нужно. Я хотела вставлять картинки в ячейки, но потом мне объяснили, что сложно масштабировать картинки, поэтому их проще вставить в примечания.
Отличие в том, что мои картинки находятся в интернете. А я сама программировать не умею совсем. Могу немного поправить диапазон, сделать еще какие-то простейшие вещи (чаще методом тыка), когда есть примечания к команде.
Tolstak помогает мне, за что ему огромное спасибо.
пробовала даже с помощью переводчика перевела. А что делать дальше не поняла. Если надо что-то переустановить, то подскажите, пожалуйста. Я сделаю, как надо.
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, видимо, воспользуюсь Вашей добротой еще раз. У меня есть второй формат файла. Я надеялась, что сама адаптирую Ваш макрос. Не получилось... Я картинку использую из столбца J.
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
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 версий)?
Здравствуйте, коллеги! Подозреваю, что правильно так
Код
#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
Привет, Владимир. Спасибо. Хотя есть у меня сомнения, что это правильно 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]
Здравствуйте, Андрей! Насчет dwReserved просмотрел, хотя проверить сложно (этот параметр не задействован). Сейчас исправлю. Добавил также Unicode версии.