Как массово извлечь по гиперссылкам фотографии на лист?

Пользователь

Сообщений: 1 Регистрация: 16.07.2018

16.07.2018 23:12:16

Доброго времени суток! Подскажите, как массово извлечь из гиперссылки фотографии и добавить их в соседние ячейки? Такое возможно? Может есть другие варианты для упрощения работы.
У меня файл в нем 400 гиперссылок на фото, эти фотографии нужно загрузить рядом в соседнюю ячейку.
Благодарю!

Изменено: Ktrinka - 16.07.2018 23:25:45

Юрий М Модератор Сообщений: 61089 Регистрация: 14.09.2012 Контакты см. в профиле	#2 16.07.2018 23:21:46 Исправил. Ktrinka, внимательнее ))

Jungl Пользователь Сообщений: 830 Регистрация: 18.01.2016	#3 16.07.2018 23:44:15 Ktrinka, добрый день! Массово никак, vba не поддерживает многопоточность. Только циклом, каждую ссылку обрабатывать.

БМВ

Модератор

Сообщений: 24612 Регистрация: 28.12.2016

Excel 2013, 2016, 2021

17.07.2018 09:27:54

Цитата
Jungl написал: Массово никак, vba не поддерживает многопоточность.

Есть некоторая разница между одновременно и массово. Многопоточность - это тоже сравнительная одновременность. Положим по мобилке люди говорят одновременно, но пакеты передаются попеременно, согласно выделенным для этого тайм слотам в канале связи.

По вопросам из тем форума, личку не читаю.

Дмитрий(The_Prist) Щербаков

Пользователь

Сообщений: 15493 Регистрация: 15.09.2012

Профессиональная разработка приложений для MS Office

17.07.2018 10:37:37

Цитата
Ktrinka написал: как массово извлечь из гиперссылки фотографии

да кто его знает, не видя как эти гиперссылки выглядят. Что там в ячейках записано? Куда они ведут? На сайт, на локальный диск, еще куда-то?
В общем: пример таблицы с гиперссылками будет?

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...

Казанский Пользователь Сообщений: 8839 Регистрация: 11.01.2013	#6 17.07.2018 10:57:42 Ktrinka, и как вставить картинки - как ссылки или внедрить в книгу? Учтите, что файл с сотнями картинок будет тормозить.

Игорь

Пользователь

Сообщений: 3695 Регистрация: 23.12.2012

17.07.2018 19:47:50

Цитата
vba не поддерживает многопоточность

неужели?
https://excelvba.ru/programmes/Parser/actions/LoadHTML_MultiThreading
вроде как чистый VBA использовал

Прикрепленные файлы

VBA_MultiThreading.jpg (25.01 КБ)

Надстройки для Excel Парсинг сайтов Мониторинг цен конкурентов

Jungl

Пользователь

Сообщений: 830 Регистрация: 18.01.2016

17.07.2018 20:20:06

Цитата
Игорь написал: неужели?

Игорь, я все это уже видел давним-давно. Приведите мне пожалуйста кусок вашего кода ИМЕННО в VBA, а не грабли вида IE, VBScript, самописные DLL/COM и прочее. Причем, я не говорю о многопоточности конкретно для скачивания файлов.
Или же вы желаете поделиться с ТС вашей "многопоточностью" для массового извлечения фотографий по ссылкам?

Цитата
БМВ написал: Есть некоторая разница между одновременно и массово. Многопоточность - это тоже сравнительная одновременность.

Еще раз, речь о VBA и его многопоточности, о чем я писал ранее.

Если у кого-то имеется желание подискутировать, прошу в личку.

БМВ

Модератор

Сообщений: 24612 Регистрация: 28.12.2016

Excel 2013, 2016, 2021

17.07.2018 20:30:03

Off

Цитата
Jungl написал: прошу в личку.

а чего так?

Цитата
Jungl написал: Еще раз, речь о VBA и его многопоточности

Еще раз, где у ТС вы встретили это загадочное слово? Вы что-то там себе придумали и написали, и на мой непросвещённый взгляд, совсем не в тему.

По вопросам из тем форума, личку не читаю.

Alemox

Пользователь

Сообщений: 2184 Регистрация: 25.02.2013

#10

17.07.2018 21:06:39

Во вложении файл с макросом, который извлекает одну картинку из интернета и вставляет её на лист.
Если вы хотите 400 картинок, то прислушайтесь

Цитата
Казанский написал: Учтите, что файл с сотнями картинок будет тормозить.

Прикрепленные файлы

Картинка на лист из интернета.xlsm (14.81 КБ)

Мастерство программиста не в том, чтобы писать программы, работающие без ошибок.
А в том, чтобы писать программы, работающие при любом количестве ошибок.

Игорь

Пользователь

Сообщений: 3695 Регистрация: 23.12.2012

#11

17.07.2018 21:29:32

Код

1	`файл с сотнями картинок будет тормозить`

в большинстве случаев, не будет
особенно, если использовать сжатие картинок (уменьшая файлы картинок до отображаемого размера, перед вставкой на лист)
но для этого нужно много winApi кода (у меня на сайте есть этот код)

Надстройки для Excel Парсинг сайтов Мониторинг цен конкурентов

bedvit

Пользователь

Сообщений: 2689 Регистрация: 02.04.2015

Виталий

#12

17.07.2018 23:48:23

Цитата
Игорь написал: использовать сжатие картинок (уменьшая файлы картинок до отображаемого размера, перед вставкой на лист)но для этого нужно много winApi кода

не обязательно. Делал загрузчик (+выгрузка) описание к номенклатурам в виде фото, срезать размер можно стандартным инструментом: вкладка "формат" - "сжать рисунки".
На VBAэто делал следующим образом - устанавливал размеры, и уменьшал размер картинки через Cut, что-то вроде:

Код

Selection.ShapeRange.LockAspectRatio = msoTrue 'сохранять пропорции
Selection.ShapeRange.Width = Ширина
Selection.ShapeRange.Height = Высота
...
Selection.Cut
ActiveSheet.PasteSpecial Format:="Рисунок (" & НужныйФормат & ")", Link:=False, DisplayAsIcon:=False

Игорь, интересная тема про многопоточность VBA, но в чистом виде нигде не видел решения (даже асинхронных функций на VBA нет), к сожалению. Если готовы поделится кусочком, было бы интересно.

Цитата
Jungl написал: желание подискутировать, прошу в личку.

я бы с удовольствием послушал бы. Зачем личка? Возможно новая тема (чтобы здесь по существу отвечать)

Изменено: bedvit - 17.07.2018 23:49:18

«Бритва Оккама» или «Принцип Калашникова»?

Игорь

Пользователь

Сообщений: 3695 Регистрация: 23.12.2012

#13

18.07.2018 05:36:12

bedvit, по многопоточности - всё просто
Вот есть компонент WinHTTPRequest, их можно наплодить несколько штук (создавая динамически) используя модули класса и события компонента WinHTTPRequest
Ключевая строка модуля класса: Public WithEvents HTTP As WinHttpRequest

у меня код сильно завязан на функции и объекты других модулей надстройки, потому, рабочий пример делать лень (много времени нужно)
можете посмотреть немного урезанный код, для понимания принципа должно хватить:

Скрытый текст

Код

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

' Пример использования (код в стандартном модуле)
 
' функция, на входе принимающая коллекцию ссылок для загрузки
' возвращающая массив загруженных веб-страниц
 
Function LoadHTML_MultiThreading(ByRef coll As Collection, Optional ByVal MaxThreads&, Optional ByVal Encoding$) As Variant
    On Error Resume Next
    Dim sender As New HTTP_Requests
    URLsAmount& = coll.Count
 
    With sender
        If Len(Encoding$) Then .Encoding = Encoding$
        If MaxThreads& > 0 Then .MaxThreads = MaxThreads&
 
        .ExecuteAll coll ' запуск загрузки
 
        If .WaitForResponse() Then
            ' Debug.Print "Загрузка завершена успешно"
        End If
 
        LoadHTML_MultiThreading = .result.Items
    End With
 
    Set coll = Nothing
    Set sender = Nothing
End Function
 
 
 
' ===========================================
' первый модуль класса: HTTP_Requests
' ===========================================
 
'---------------------------------------------------------------------------------------
' Class Module        : HTTP_Requests              Version: 1.1
' Author        : Igor Vakhnenko                   Date: 13.06.2016
' Professional application development for Microsoft Excel
' https://excelvba.ru/programmes/Parser
'---------------------------------------------------------------------------------------
 
Option Compare Text: Option Explicit
 
Dim Requests As New Dictionary
Dim SourceURLs As New Collection
Public result As New Dictionary
Public SourceURLsAmount As Long
 
Public Encoding As String        ' кодировка страниц
Public MaxThreads As Long        ' количество потоков
Public Timeout As Long        ' таймаут в секундах
Public HTML_Filters As String        ' фильтры для пост-обработки ответа сервера
 
Public pi As ProgressIndicatorNew
' текущее состояние
Public RequestStarted As Long        ' сколько запросов в работе
Public RequestFrozen As Long        ' запрос подвис, истек таймаут
Public RequestFinished As Long        ' сколько запросов завершено
Public RequestStatusOK As Long        ' код ответа 2xx или 3xx
Public RequestStatusFailed As Long        ' код ответа 4xx или 5xx
 
Private Sub Class_Initialize()
    Me.MaxThreads = 50
    Me.Timeout = DEFAULT_QUERY_TIMEOUT&
End Sub
 
Private Sub Class_Terminate()
    On Error Resume Next
    Dim h As New HTTP_Request
    For Each h In Requests
        Set h = Nothing
    Next
    Set Requests = Nothing
    Set SourceURLs = Nothing
    Set result = Nothing
End Sub
 
Function ExecuteAll(ByVal coll As Collection) As Variant
    On Error Resume Next
    Dim i&
    ' заносим все исходные ссылки в список загрузок - коллекцию SourceURLs
    Set SourceURLs = coll
    SourceURLsAmount = SourceURLs.Count
 
    pi.ShowExtraBar "Многопоточная загрузка страниц (" & SourceURLsAmount & " URL,  потоков: " & Me.MaxThreads & ",  таймаут: " & Timeout & " сек.)", False
 
    ' запускаем максимальное количество потоков
    For i = 1 To Application.Min(Me.MaxThreads, SourceURLs.Count)
        'Debug.Print "ind=" & i&, Now
        ExecuteNext
        DoEvents
        UpdateProgressBar
    Next
End Function
 
Function WaitForResponse(Optional ByVal Timeout&) As Boolean
    On Error Resume Next
    If Timeout& <= 0 Then Timeout& = (SourceURLsAmount / Me.MaxThreads * 1.2 + 2) * Me.Timeout
    Dim i&, TimeStamp As Double: TimeStamp = CDbl(Now) * 86400
    While (Me.RequestFinished < SourceURLsAmount) And (CDbl(Now) * 86400 - TimeStamp < Timeout&)
        If StopMacro Then pi.HideExtraBar: Exit Function
        For i = 1 To 100: DoEvents: Next
        UpdateProgressBar
    Wend
    'UpdateProgressBar
    For i = 1 To 100: DoEvents: Next
     
    'WaitForResponse = Me.RequestFinished = SourceURLsAmount
    WaitForResponse = (Me.RequestFrozen + Me.RequestStatusFailed) = 0
     
    pi.HideExtraBar
End Function
 
Sub UpdateProgressBar()
    On Error Resume Next
    Static LastPercent&, LastUpdateTime As Date
    If Now - LastUpdateTime < 0.1 / 86400 Then Exit Sub
 
    ' ...
 
    For Each k In Requests.Keys
        Set h = Requests.Item(CStr(k))
        If h.IsFrosen(Timeout) Then
            Me.RequestFrozen = Me.RequestFrozen + 1
            Me.Finished h
        End If
    Next
    Set h = Nothing
    ' ...
    LastUpdateTime = Now
    DoEvents
End Sub
 
Sub ExecuteNext()
    If StopMacro Then Exit Sub
    If SourceURLs.Count = 0 Then Exit Sub
    On Error Resume Next
 
    Dim h As New HTTP_Request, ind&
    ind& = SourceURLsAmount - SourceURLs.Count + 1
    With h
        Set .Parent = Me
        h.ThreadID = CStr(ind&)
        h.Encoding = Me.Encoding
        h.URL = SourceURLs(1&)
        If h.URL Like "*[А-Яа-яЁё]*" Then h.URL = ConvertURLtoPunycode(h.URL)
         
        h.StartTime = Now
    End With
    SourceURLs.Remove 1&
    Requests.Add h.ThreadID, h
 
    With h.HTTP
        .SetTimeouts Me.Timeout * 1000, Me.Timeout * 1000, Me.Timeout * 1000, Me.Timeout * 1000
        .Open "GET", h.URL, True
        If RunningParser.Options.UseClientCertificate Then .SetClientCertificate RunningParser.Options.ClientCertificateName
        PageLoadRequested h.URL
        AddRequestHeadersFromStore h.HTTP
        If Not CookiesStore Is Nothing Then .SetRequestHeader "Cookie", GetCookiesFromStore
        .Send
    End With
End Sub
 
Sub Finished(ByRef h As HTTP_Request)        ' срабатывает по окончании загрузки очередного запроса
    On Error Resume Next: Dim ThreadID$, InfoTag$
    ThreadID$ = h.ThreadID
 
    With h
        If .Encoding = "utf-8" Then .Response = DecodeUTF8(.Response)
        InfoTag$ = "<info id='parser multithreading' status='" & .Status & "' encoding='" & .Encoding & "' href='" & .URL & "'></info>"
 
        If Len(Me.HTML_Filters) Then
            .Response = InfoTag$ & vbNewLine & ApplyHTMLFilters(.Response, Me.HTML_Filters)
        Else
            .Response = Replace(.Response, "</head>", vbNewLine & InfoTag$ & vbNewLine & "</head>", , 1)
        End If
         
        ' если не добавился - добавляем в самое начало ответа сервера
        If InStr(1, .Response, InfoTag$, vbTextCompare) = 0 Then .Response = InfoTag$ & vbNewLine & .Response
 
        result.Add ThreadID$, .Response
    End With
 
    Set h = Nothing
    Me.RequestFinished = Me.RequestFinished + 1
    Requests.Remove ThreadID$
    'Debug.Print "ThreadID " & ThreadID$ & " destroyed"
    ExecuteNext
End Sub
 
 
' ===========================================
' второй модуль класса: HTTP_Request
' ===========================================
'---------------------------------------------------------------------------------------
' Class Module  : HTTP_Request                     Version: 1.1
' Author        : Igor Vakhnenko                   Date: 14.06.2016
' Professional application development for Microsoft Excel
' https://excelvba.ru/programmes/Parser
'---------------------------------------------------------------------------------------
 
Option Compare Text: Option Explicit
Public WithEvents HTTP As WinHttpRequest
 
Public Parent As HTTP_Requests
Public ThreadID As String
Public URL As String
Public Response As String
Public Encoding As String
Public Status As Long
Public StartTime As Date
 
Private Sub Class_Initialize()
    Set HTTP = New WinHttpRequest
End Sub
 
Private Sub Class_Terminate()
    'Debug.Print "ThreadID " & ThreadID & " destroyed"
    Set HTTP = Nothing
    Set Parent = Nothing
End Sub
 
Function IsFrosen(ByRef Timeout As Long) As Boolean
    IsFrosen = ((Now - StartTime) * 86400 >= (Timeout * 1))
End Function
 
Private Sub http_OnResponseDataAvailable(data() As Byte)
    On Error Resume Next
    'Debug.Print "ThreadID=" & ThreadID, "DataAvailable", "size=" & UBound(Data)
    Response = Response & StrConv(data, vbUnicode)
End Sub
 
Private Sub http_OnResponseFinished()
    On Error Resume Next
    Me.Parent.Finished Me
End Sub
 
Private Sub http_OnResponseStart(ByVal Status As Long, ByVal ContentType As String)
    On Error Resume Next
    If Me.Encoding = "" Then
        If ContentType Like "*=utf-8*" Then Me.Encoding = "utf-8"
        If ContentType Like "*1251*" Then Me.Encoding = "windows-1251"
    End If
    Me.Status = Status
    With Me.Parent
        .RequestStarted = .RequestStarted + 1
        Select Case Status
            Case 200 To 399: .RequestStatusOK = .RequestStatusOK + 1
            Case 400 To 599: .RequestStatusFailed = .RequestStatusFailed + 1
            Case Else: Debug.Print "Unsupported Status=" & Status
        End Select
    End With
    'Debug.Print "ThreadID=" & ThreadID, "Status=" & Status, "ContentType=" & ContentType
End Sub

количество потоков от сайта зависит
на быстрых сайтах и 200 потоков работает (если больше - Excel глючит), обычно использую 20-40 потоков

Изменено: Игорь - 18.07.2018 05:51:36

Надстройки для Excel Парсинг сайтов Мониторинг цен конкурентов

bedvit

Пользователь

Сообщений: 2689 Регистрация: 02.04.2015

Виталий

#14

23.07.2018 20:30:07

Игорь, немного появилось времени, посмотрел код (времени было мало, поэтому извиняюсь, если где не точен или вообще мимо).
Насколько я понял: потоки запускаются циклом в функции "ExecuteAll".
Запускается процедура ExecuteNext.
В этой процедуре создается объект HTTP_Request (класс)
В этом классе создается COM-объект - WinHttpRequest.
Далее парралельность достигается тем, что этот объект позволяет запускать асинхронные методы (даже свойство у него есть:WaitForResponse - Задает время ожидания в секундах для завершения асинхронного метода отправки с дополнительным значением тайм-аута).
Верно?

«Бритва Оккама» или «Принцип Калашникова»?

Игорь

Пользователь

Сообщений: 3695 Регистрация: 23.12.2012

#15

24.07.2018 02:01:43

да, всё верно
по мере завершения загрузок, когда потоки освобождаются (число загрузок становится меньше заданного числа потоков),
автоматом отрабатывает ExecuteNext, запуская следующую загрузку

Изменено: Игорь - 24.07.2018 02:03:25

Надстройки для Excel Парсинг сайтов Мониторинг цен конкурентов

bedvit

Пользователь

Сообщений: 2689 Регистрация: 02.04.2015

Виталий

#16

24.07.2018 20:56:12

Игорь, все же, если быть буквоедом, это не чистая параллельность VBA. Это просто у вас прокачка настолько высока (знания, опыт), что вы с помощью VBA, используете ассинхронные вызовы методов объекта WinHttpRequest. Сам VBA делает это вполне последовательно и синхронно в цикле

К примеру таким способом, не разделить по потокам числодробилку (делал как-то программулину на другом языке с вычислением всех натуральных делителей числа в 8 потоках-по числу логический ядер процессора) или параллельное/ассинхронное выполнение функций листа Excel. Могу ошибаться, но пока не соображу как это можно реализовать в VBA (хотя в принципе это возможно, но на другом языке). Материал действительно интересен. Спасибо вам за информацию. Интересная концепция.

Изменено: bedvit - 24.07.2018 21:07:04

«Бритва Оккама» или «Принцип Калашникова»?

ardak78 Пользователь Сообщений: 3 Регистрация: 15.10.2019	#17 22.06.2020 12:12:45 Друзья не знаю где уже искать. Нужно с фото на листе вытащить гиперссылку (фото очень много))

Читают тему