Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal DirPath$) As Boolean
Sub Demo1()
Dim P$, V, R&, S$(), H$, B() As Byte, F%
P = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\new folder\"
If MakeSureDirectoryPathExists(P) = False Then Beep: Exit Sub
V = [A1].CurrentRegion.Value2
With CreateObject("WinHttp.WinHttpRequest.5.1")
Application.Cursor = 2
On Error Resume Next
For R = 2 To UBound(V)
S = Split(V(R, 1), "?id="): If UBound(S) = 0 Then S = Split(V(R, 1), "&id=")
If UBound(S) = 1 Then
Application.StatusBar = " Downloading : " & Split(S(1), "&")(0)
If R Mod 9 = 0 Then DoEvents
Err.Clear
.Open "GET", V(R, 1), False
.SetRequestHeader "DNT", "1"
.Send
If Err.Number = 0 Then
H = .GetResponseHeader("Content-Disposition")
If Err.Number Then
S = Split(.ResponseText, "location.href=""")
If UBound(S) = 1 Then
V(R, 1) = Left(V(R, 1), InStrRev(V(R, 1), "/")) & Split(S(1), """")(0)
R = R - 1
End If
ElseIf H Like "inline; filename=""*""*" Then
B = .ResponseBody
F = FreeFile(1)
Open P & Split(H, """")(1) For Binary As #F
Put #F, , B
Close #F
End If
End If
End If
Next
End With
Application.StatusBar = False
Application.Cursor = xlDefault
ThisWorkbook.FollowHyperlink P
End Sub