1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110
| Private Declare Function InternetGetConnectedState Lib "wininet.dll" (ByRef lpdwFlags As Long, ByVal dwReserved As Long) As Long
Public Function ConnectéInternet() As Boolean
ConnectéInternet = IIf(InternetGetConnectedState(0&, 0&) = 1, True, False)
End Function
Sub IMPORTATIONCOURSBCT()
Application.ScreenUpdating = False
Sheets("COURS").Cells.Clear
If ConnectéInternet = Faux Then
MsgBox "Echec de Connexion à Inetrnet : cours de devise ne sont pas à jour"
Exit Sub
Else
Dim ReQ, shap, mémorisation, CodeHtMl
'requette EUR/DOLLAR
Set ReQ = CreateObject("WinHttp.WinHttpRequest.5.1")
With ReQ
lResolve = 5000 'delay pour la resolution des erreurs eventuelles
lConnect = 5000 'delay pour la connection
lSend = 5000 'delay pour vba pour envoyer
lReceive = 150000 'delay pour attendre les données
ReQ.setTimeOuts lResolve, lConnect, lSend, lReceive
.Open "post", "http://www.fxstreet.fr/rates/forex-rates", False: .send
If .Status = 200 Then
CodeHtMl = ReQ.responsetext
With CreateObject("htmlfile")
.body.innerhtml = CodeHtMl
mémorisation = .parentwindow.clipboardData.SetData("Text", .getelementsbytagname("TABLE")(0).outerhtml)
With Sheets("COURS")
.Activate
.Cells(1, 12).Select
.Paste
' netoyage des shapes vides qui seront de toute facon vide daans le sheets
For Each shap In .Shapes
If shap.Name Like "*Auto*" Then shap.Delete
Next
End With
End With
Else
MsgBox "Problème de Connexion au site www.fxstreet.fr"
End If
End With
' requte 1 : cours de devise
Dim ReQ1, shap1, mémorisation1, CodeHtMl1
Set ReQ1 = CreateObject("WinHttp.WinHttpRequest.5.1") 'setTimeOuts
With ReQ1
lResolve = 12000000 'delay pour la resolution des erreurs eventuelles
lConnect = 120000000 'delay pour la connection
lSend = 5000000 'delay pour vba pour envoyer
lReceive = 150000000 'delay pour attendre les données
ReQ1.setTimeOuts lResolve, lConnect, lSend, lReceive
.Open "post", "https://www.bct.gov.tn/bct/siteprod/cours.jsp", False: .send
If .Status = 200 Then
CodeHtMl1 = ReQ1.responsetext
With CreateObject("htmlfile")
.body.innerhtml = CodeHtMl
mémorisation1 = .parentwindow.clipboardData.SetData("Text", .getelementsbytagname("TABLE")(0).outerhtml)
With Sheets("COURS")
.Activate
.Cells(1, 1).Select
.Paste
' netoyage des shapes vides qui seront de toute facon vide daans le sheets
For Each shap1 In .Shapes
If shap1.Name Like "*Auto*" Then shap1.Delete
Next
End With
End With
Else
MsgBox "Problème de Connexion au site www.bct.gov.tn"
End If
End With
'requete 2 : cours à terme
Dim ReQ2, shap2, mémorisation2, CodeHtMl2
Set ReQ2 = CreateObject("WinHttp.WinHttpRequest.5.1") 'setTimeOuts
With ReQ2
lResolve = 1200000 'delay pour la resolution des erreurs eventuelles
lConnect = 1200000 'delay pour la connection
lSend = 5000000 'delay pour vba pour envoyer
lReceive = 150000000 'delay pour attendre les données
ReQ.setTimeOuts lResolve, lConnect, lSend, lReceive
.Open "post", "https://www.bct.gov.tn/bct/siteprod/cours.jsp", False: .send
If .Status = 200 Then
CodeHtMl2 = ReQ2.responsetext
With CreateObject("htmlfile")
.body.innerhtml = CodeHtMl2
mémorisation2 = .parentwindow.clipboardData.SetData("Text", .getelementsbytagname("TABLE")(2).outerhtml)
With Sheets("COURS")
.Activate
.Cells(1, 7).Select
.Paste
' netoyage des shapes vides qui seront de toute facon vide daans le sheets
For Each shap2 In .Shapes
If shap2.Name Like "*Auto*" Then shap2.Delete
Next
End With
End With
Else
MsgBox "Problème de Connexion au site www.bct.gov.tn"
End If
End With
End If
Application.ScreenUpdating = True
End Sub |
Partager