Inputbox

[RichieL]

Onderstaand heb ik een script waarbij in een lijst van foto's van downloaden adv de URL's

Ik zo graag de FolderName = locatie van downloads (waar de foto's terecht moeten komen) willen bepalen adv een Inputbox, zonder dat ik deze in het script hoeft aan te passen.

Daarnaast en de ws.Range ("A") en ws.Range ("E") zou ik ook graag dynamisch willen maken

Kolom A: komt de benaming te staan hoe het document moet heten
Kolom E: staat de url vermeld van de foto

Ik wil graag die Kolomen invullen adv een inputbox, omdat het niet altijd om Kolom A of E gaat, het kan ook wel eens B & C zijn, vandaar.

Const FolderName As String = "P:\MyDocuments'\"

Sub downloadJPGImagesTEST()
 currentName = ActiveSheet.Name

 Set ws = ActiveWorkbook.Sheets(currentName)
 lLastRow = ws.Range("A" & Rows.Count).End(xlUp).Row

 Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP.6.0")
 Set oBinaryStream = CreateObject("ADODB.Stream")
 adTypeBinary = 1
 oBinaryStream.Type = adTypeBinary

 For i = 2 To lLastRow
  sPath = FolderName & ws.Range("A" & i).Value & ".jpg"
  sURI = ws.Range("E" & i).Value

  On Error GoTo HTTPError
  oXMLHTTP.Open "GET", sURI, False
  oXMLHTTP.Send
  aBytes = oXMLHTTP.responsebody
  On Error GoTo 0

  oBinaryStream.Open
  oBinaryStream.Write aBytes
  adSaveCreateOverWrite = 2
  oBinaryStream.SaveToFile sPath, adSaveCreateOverWrite
  oBinaryStream.Close

  ws.Range("E" & i).Value = "File successfully downloaded as JPG"

NextRow:
 Next

 Exit Sub

HTTPError:
 ws.Range("E" & i).Value = "Unable to download the file"
 Resume NextRow

End Sub

 

[edmoor]

Gebruik dit om een folder te selecteren:

With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = -1 Then
        FolderName = .SelectedItems(1)
    End If
End With

 

[RichieL]

Dankje. Krijg hem wel gedownload, maar op 1 of andere manier zet hij standaard de foto's neer in mijn afbeeldingen map, ook wanneer ik een ander locatie kies.

Hoe zou ik onderstaande het beste kunnen doen?

Daarnaast en de ws.Range ("A") en ws.Range ("E") zou ik ook graag dynamisch willen maken

Kolom A: komt de benaming te staan hoe het document moet heten
Kolom E: staat de url vermeld van de foto

 

[edmoor]

Ik kan natuurlijk niet zien wat je met de opgehaalde FolderName doet.

 

[RichieL]

Hierbij.

Maakt niet uit welke locatie ik kies hij zet standaard in de Afbeeldingen Map.

Sub downloadJPGImagesTEST()
 With Application.FileDialog(msoFileDialogFolderPicker)
 If .Show = -1 Then
  nameFolderName = .SelectedItems(1)

 currentName = ActiveSheet.Name
 
 Set ws = ActiveWorkbook.Sheets(currentName)
 lLastRow = ws.Range("A" & Rows.Count).End(xlUp).Row

 Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP.6.0")
 Set oBinaryStream = CreateObject("ADODB.Stream")
 adTypeBinary = 1
 oBinaryStream.Type = adTypeBinary

 For i = 2 To lLastRow
  sPath = FolderName & ws.Range("A" & i).Value & ".jpg"
  sURI = ws.Range("E" & i).Value

  On Error GoTo HTTPError
  oXMLHTTP.Open "GET", sURI, False
  oXMLHTTP.Send
  aBytes = oXMLHTTP.responsebody
  On Error GoTo 0

  oBinaryStream.Open
  oBinaryStream.Write aBytes
  adSaveCreateOverWrite = 2
  oBinaryStream.SaveToFile sPath, adSaveCreateOverWrite
  oBinaryStream.Close

  ws.Range("E" & i).Value = "File successfully downloaded as JPG"

NextRow:
 Next

 Exit Sub

HTTPError:
 ws.Range("E" & i).Value = "Unable to download the file"
 Resume NextRow
    
    End If
End With

End Sub

 

[edmoor]

Je vergeet wat:

sPath = FolderName [COLOR="#FF0000"]& "\"[/COLOR] & ws.Range("A" & i).Value & ".jpg"

Daarnaast vraag je nameFoldername op.

 

[RichieL]

Oef... Ja dat was m...
Thanks!

 

[snb]

Overzichtelijker:

Sub M_snb()
  sn = Cells(1).CurrentRegion
     
  With Application.FileDialog(4)
    If .Show Then c00 = .SelectedItems(1)
  End With
      
  With CreateObject("MSXML2.XMLHTTP")
    For j = 2 To UBound(sn)
      .Open "Get", sn(j, 5), False
      .send
        
      Open c00 & sn(j, 1) For Binary As #1
        Put #1, , .responseBody
      Close #1
    Next
  End With
End Sub