< návrat zpět

MS Excel


Téma: stažení obrázku z url rss

Zaslal/a 17.6.2020 16:23

Dobrý den, mám cca 12000 řádků buněk a v tom odkaz na obrázek. potřebuji bud script do VBA který mi stáhne ze všech odkazů obrázky do nějaké složky. NEBO
mám script do powershellu který mi stáhne tyto obrázky ale potřebuji mít odkazy na url v jednom řádku a oddělené čárkou. Nemůže mi nekdo poradit?

Zaslat odpověď >

#046955
elninoslov
Narýchlo:
Takže Vy chcete stiahnuť obrázky z webu? Zdroj kódu
#If VBA7 And Win64 Then
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" ( _
ByVal pCaller As LongPtr, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As LongPtr, _
ByVal lpfnCB As LongPtr _
) As Long
Private Declare PtrSafe Function DeleteUrlCacheEntry Lib "Wininet.dll" _
Alias "DeleteUrlCacheEntryA" ( _
ByVal lpszUrlName As String _
) As Long
#Else
Private 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
Private Declare Function DeleteUrlCacheEntry Lib "Wininet.dll" _
Alias "DeleteUrlCacheEntryA" ( _
ByVal lpszUrlName As String _
) As Long
#End If

Public Const ERROR_SUCCESS As Long = 0
Public Const BINDF_GETNEWESTVERSION As Long = &H10
Public Const INTERNET_FLAG_RELOAD As Long = &H80000000

Sub downloadImages()
Dim i As Long, ret As Long, sURL As String, sSubor As String, sCesta As String

sCesta = "d:\Download\Obr\"
With Worksheets("Hárok1")
For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
sSubor = sCesta & Split(.Cells(i, 1).Value, "/")(UBound(Split(.Cells(i, 1).Value, "/")))
sURL = .Cells(i, 1).Value
ret = URLDownloadToFile(0&, sURL, sSubor, BINDF_GETNEWESTVERSION, 0&)

If ret = 0 Then
.Cells(i, 3) = "File successfully downloaded"
Else
.Cells(i, 3) = "Unable to download the file"
End If
Next i
End With

End Sub

Priložte prílohu s príkladom.
Příloha: zip46955_download-suboru-z-www.zip (13kB, staženo 24x)
citovat
#046956
elninoslov
Čítanie adresy z HL odkazu by som videl možno nejak takto (deklarácia rovnaká):
Sub downloadImages()
Dim i As Long, ret As Long, sURL As String, sSubor As String, sCesta As String
Dim aR() As Boolean, RC As Long, aUrl() As String

sCesta = "d:\Download\Obr\"

With Worksheets("Hárok1")
RC = .Cells(Rows.Count, "A").End(xlUp).Row - 1
If RC = 0 Then Exit Sub
ReDim aR(1 To RC, 1 To 1)

For Each Bunka In .Cells(2, 1).Resize(RC).Cells
i = i + 1
sURL = ""
On Error Resume Next
sURL = Bunka.Hyperlinks(1).Address
On Error GoTo 0

If sURL <> "" Then
aUrl = Split(sURL, "/")
sSubor = sCesta & aUrl(UBound(aUrl))
ret = URLDownloadToFile(0&, sURL, sSubor, BINDF_GETNEWESTVERSION, 0&)
aR(i, 1) = ret = 0
End If
Next Bunka
.Cells(2, 2).Resize(RC).Value = aR
End With
End Sub
Příloha: zip46956_download-suboru-z-www.zip (17kB, staženo 22x)
citovat
#046957
avatar
Nějak mi to nejde - pro upřesnění.
Mám excel kde bunky G2:G11297 obsahují url odkazy obrázků.
Potřebuji tyto obrazky stáhout někam do složky třeba na plochu nebo někam, cíl stažení bych si upravil.
Díky moccitovat
#046958
elninoslov
Pre upresnenie - uviedol som to tučným písmo minule - priložte prílohu. Musím vidieť tie odkazy a umiestnenie, nemôžem si byť istý, či myslíte to čo píšete.
"Nějak mi to nejde" - to je popis chyby ? Hodí to chybu? Kde? Na ktorom riadku? Nestiahne správny obr? Nestiahne žiadny? ... Aká verzia a bitová kópia Excelu ...
#If VBA7 And Win64 Then
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" ( _
ByVal pCaller As LongPtr, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As LongPtr, _
ByVal lpfnCB As LongPtr _
) As Long
#Else
Private 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

Public Const ERROR_SUCCESS As Long = 0
Public Const BINDF_GETNEWESTVERSION As Long = &H10
Public Const INTERNET_FLAG_RELOAD As Long = &H80000000

Sub downloadImages()
Dim i As Long, sURL As String, sSubor As String, sCesta As String, aUrl() As String

sCesta = "d:\Download\Obr\"

For Each Bunka In Worksheets("Hárok1").Range("G2:G11297").Cells
sURL = ""
On Error Resume Next
sURL = Bunka.Hyperlinks(1).Address
On Error GoTo 0

If sURL <> "" Then
aUrl = Split(sURL, "/")
sSubor = sCesta & aUrl(UBound(aUrl))
URLDownloadToFile 0&, sURL, sSubor, BINDF_GETNEWESTVERSION, 0&
End If
Next Bunka
End Sub
citovat

Uživatelské menu

Nejste přihlášen(a)
avatar\n

Menu

On-line nástroje

Formulář Faktura

Formulář Faktura IV

Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.

Aktivní diskuse

rozpis zápasů hráčů pro utkání dvou týmů

Anonym • 25.5. 11:54

Hromadné přepsání

elninoslov • 24.5. 10:29

Hromadné přepsání

Nomi • 24.5. 8:32

Index - každý rok začít od 1 Power Query

Alfan • 23.5. 9:17

nepřímý odkaz

elninoslov • 23.5. 0:00

nepřímý odkaz

bordov • 22.5. 18:35

vrácené hodnoty

Anonym • 22.5. 15:46