MS Excel

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ěď >

elninoslov(17.6.2020 17:11)#046955

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: zip

46955_download-suboru-z-www.zip (13kB, staženo 25x)

citovat

elninoslov(17.6.2020 17:53)#046956

Čí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: zip

46956_download-suboru-z-www.zip (17kB, staženo 24x)

citovat

Nevim-kudy-kam(18.6.2020 9:08)#046957

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

elninoslov(18.6.2020 9:22)#046958

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 Subcitovat

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

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje