Private Declare PtrSafe 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
Sub ExtractionFichier()
Dim mois As String
Dim jour As String
Dim annee As String
Dim heure As String
Dim minutes As String
Dim ladate As String
Dim fs
Dim test As Integer
Dim ligne As Integer
Dim liendoc As String
Set fs = CreateObject("Scripting.FileSystemObject")
Dim IndexFichier As Integer
Dim fichierdest As String
Dim ContenuLigne As String
Dim AnneeRea As String
Dim MoisRea As String
Dim JourRea As String
mois = Right("00" & Month(Now), 2)
jour = Right("00" & Day(Now), 2)
annee = Year(Now)
heure = Hour(Now)
minutes = Format(minute(Now), "00")
'secondes = Format(seconds(Now), "00")
ladate = Format(Now, "yyyymmdd-hh-mm-ss")
test = Len(Dir("C:\Rapportsverif", vbDirectory))
If test <= 0 Then
fs.CreateFolder ("C:\Rapportsverif")
End If
fs.CreateFolder ("C:\Rapportsverif\" & ladate)
ligne = 2
Do While Workbooks("extractionrapports v2.xlsm").Worksheets(1).Range("A" & ligne).Value <> ""
liendoc = Range("K" & ligne).Value
If liendoc <> "" And liendoc <> "0" Then
fichierdest = "C:\Rapportsverif\" & ladate & "\" & Range("A" & ligne).Value & ".html"
'fs.CopyFile liendoc, fichierdest
DownloadFile liendoc, fichierdest
IndexFichier = FreeFile()
Open fichierdest For Input As #IndexFichier
While Not EOF(IndexFichier)
Line Input #IndexFichier, ContenuLigne
If Left(ContenuLigne, 17) = "<a id=mydoc href=" Then
liendoc = "http://***.***.***.../vdocopenweb" & Right(Left(ContenuLigne, Len(ContenuLigne) - 16), Len(Left(ContenuLigne, Len(ContenuLigne) - 16)) - 20)
JourRea = Left(Range("I" & ligne).Value, 2)
MoisRea = Mid(Range("I" & ligne).Value, 4, 2)
AnneeRea = Mid(Range("I" & ligne).Value, 7, 4)
DownloadFile liendoc, "C:\Rapportsverif\" & ladate & "\" & Range("A" & ligne).Value & "-" & AnneeRea & MoisRea & JourRea & "-" & Range("M" & ligne).Value & "-" & Range("N" & ligne).Value & "-" & Range("O" & ligne).Value & ".pdf"
End If
Wend
Close #IndexFichier
Kill fichierdest
End If
ligne = ligne + 1
Loop
'
Range("K6").Select
End Sub
Sub DownloadFile(myURL As String, destination As String)
Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", myURL, False
WinHttpReq.send
If WinHttpReq.Status = 200 Then
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.responseBody
oStream.SaveToFile destination, 2 ' 1 = no overwrite, 2 = overwrite
oStream.Close
End If
End Sub
Sub DownloadPDF()
Dim strPDFLink As String
Dim strPDFFile As String
Dim doc, hcol, text As Variant
Dim ie As SHDocVw.InternetExplorer
Set ie = CreateObject("InternetExplorer.Application")
Dim FolderName As String
strPDFLink = "http://?.com/Communication%20-%20Marketing/Implantations/CARTE%20DE%20NOS%20IMPLANTATIONS.pdf"
strPDFFile = "C:\Rapportsverif\test.pdf"
ie.Visible = True
ie.Navigate (strPDFLink)
Application.Wait (Now + #12:00:02 AM#)
Result = DownloadtheFile(strPDFLink, strPDFFile)
End Sub
Function DownloadtheFile(url As String, LocalFilename As String) As Boolean
Dim lngRetVal As Long
lngRetVal = URLDownloadToFile(0, url, LocalFilename, 0, 0)
If lngRetVal = 0 Then DownloadtheFile = True
End Function
