XL 2013 RECUPARATION FICHIER PDF

[laurentsicli]

bonjour voici la vba comme suit :

recuperais desfichiers pdf sur un serveur HTTP d'apres un lien dans une colonne et des lignes ( donc possibilite de plusieur fichiers) un fichier XLs , puis enregistrer ce fichier dans un repertoire nomme par la date du jour, et ces fichier eux meme renomer suivant une ou plusieur Cellules du meme fichier. j'ai deja fait un VBA qui fonctionne jusqu'a la creation du nous repertoire mais n'ecris pas les fichiers pdf . je vous joint la VBA deja realiser :

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 cellule du liens
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://IP du stockage /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


apprement l'erreur 3004 est la a l'enregistrement
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

voir le repertoire d'enregistrement

merc ia vous

 

[Staple1600]

Bonsoir le fil

Inutile de doublonner
On pouvait rester dans le fil initial

https://www.excel-downloads.com/threads/probleme-de-macro-recuperation-pdf.20040260/#post-20287821

 

[laurentsicli]

oui je voulais completer le post et j'ai doubler .
desole