Citazione di: Il Mitico™ il 08 Lug 2011, 14:58
Come si salvano le foto del trigoriere?
Option Explicit
Call Main
Sub Main()
Dim i, f, d, url, filename
On Error Resume Next
'**
'** delete al content in the .\data folder
'**************************************************************************
DeleteAllFolderContent ".\tmp"
'**
'** download 100 images
'**************************************************************************
d = CStr(InputBox("codice directory:"))
For i=0 To 99
f = CStr(i)
If i < 10 Then f = "0" & f
url = "
http://www.corrieredellosport.it/images/" & f & "/C_3_Media_" & d & f & "_immagine_obig.jpg"
filename = d & "-" & f & ".jpg"
DownloadFile url, ".\tmp", filename
Next
MsgBox "images successfully downloaded..", vbOkOnly + vbInformation, "Info: "
End Sub
Sub DeleteAllFolderContent(ByVal strFolderPath)
Dim objFSO
Dim objFolder
Dim objFile
Dim objSubFolder
'**
'** loads the Scripting.FileSystemObject object
'**************************************************************************
Set objFSO = Createobject("Scripting.FileSystemObject")
'**
'** checks if the folder exists
'**************************************************************************
If objFSO.FolderExists(strFolderPath) Then
Set objFolder = objFSO.GetFolder(strFolderPath)
'**
'** delete all the files in the folder
'**********************************************************************
For Each objFile In objFolder.Files
objFile.Delete
Next
'**
'** delete all the subfolders (and their content)
'**********************************************************************
For Each objSubFolder In objFolder.SubFolders
DeleteAllFolderContent(objSubFolder.Path)
objSubFolder.Delete
Next
End If
'**
'** unloads the Scripting.FileSystemObject object
'**************************************************************************
Set objFSO = Nothing
End Sub
Function DownloadFile(ByVal strFileURL, ByVal strLocalFolder, ByVal strLocalFileName)
Dim blnReturnedValue : blnReturnedValue = False
Dim strFilePath
Dim objXmlHttp
Dim objADOStream
Dim objFSO
'**
'** requests for the file to download
'**************************************************************************
Set objXmlHttp = CreateObject("msxml2.xmlhttp.3.0")
objXmlHttp.open "GET", strFileURL, False
objXmlHttp.send()
'**
'** if the server reponse is OK
'**************************************************************************
If objXmlHttp.Status = 200 Then
'**
'** opens a binary stream
'**********************************************************************
Set objADOStream = CreateObject("ADODB.Stream")
objADOStream.Open objADOStream.Type = 1 'adTypeBinary
'**
'** saves the server response as binary stream
'**********************************************************************
objADOStream.Write objXmlHttp.ResponseBody
objADOStream.Position = 0 'Set the stream position to the start
'**
'** builds the local file path and name
'**********************************************************************
If Mid(strLocalFolder, Len(strLocalFolder)) = "\" Then
strLocalFolder = Mid(strLocalFolder,1, Len(strLocalFolder)-1)
End If
strFilePath = strLocalFolder & "\" & strLocalFileName
'**
'** checks if the file already exists and eventually deletes it
'**********************************************************************
Set objFSO = Createobject("Scripting.FileSystemObject")
If objFSO.FileExists(strFilePath) Then objFSO.DeleteFile strFilePath
'**
'** saves the binary stream as file
'**********************************************************************
objADOStream.SaveToFile strFilePath
objADOStream.Close
'**
'** removes from the memory the objects
'**********************************************************************
Set objFSO = Nothing
Set objADOStream = Nothing
'**
'** sets the to be returned value to TRUE
'**********************************************************************
blnReturnedValue = True
'**
'** if the server response is a fault
'**************************************************************************
Else
' MsgBox "DownloadFile function in error: " & objXmlHttp.statusText, _
' vbOKOnly + vbCritical, _
' "Error: "
End If
'**
'** removes from the memory the object
'**************************************************************************
Set objXmlHttp = Nothing
'**
'** returns TRUE if OK, FALSE if KO
'**************************************************************************
DownloadFile = blnReturnedValue
End Function
