Option Explicit
‘test si la connexion internet est active
Private Declare Function InternetGetConnectedState Lib "wininet.dll" _
(ByRef lpdwFlags As Long, _
ByVal dwReserved As Long) As Long
Private Sub testi(onglet, URL, numdelalign)
Dim testconnexion As Boolean
testconnexion = ConnexionInternetActive ' appel la fonction ConnexionInternetActive
Dim plagedecotations As String
If testconnexion = True Then
Call ecritdsfichieriqy(URL)
Call metdslonglet(plagedecotations, onglet, numdelalign)
Else
MsgBox "Il faut d'abord se connecter à internet pour le programme fonctionne correctement"
End If
End Sub
Private Function ConnexionInternetActive() As Boolean
ConnexionInternetActive = InternetGetConnectedState(0&, 0&)
End Function
Sub ecritdsfichieriqy(URL)
Dim Status As Boolean
Dim FileNumber
Status = False
FileNumber = FreeFile 'FreeFile est une fonction importante
Open "C:\Program Files\Microsoft Office\Office\Queries\Cotations.iqy" For Output As #FileNumber
Print #FileNumber, "WEB"
Print #FileNumber, "1"
Print #FileNumber, URL
Close #FileNumber
Status = True
End Sub
Private Sub metdslonglet(plagedecotations, onglet, numdelalign)
'cette routine sert a coller les colonnne OHLCV dans l'onglet
Dim connectionstring As String
connectionstring = "FINDER;C:\Program Files\Microsoft Office\Office\Queries\Cotations.iqy"
Dim qt As QueryTable
Set qt = Sheets(onglet.Name).QueryTables.Add(connectionstring, Destination:=Sheets(onglet.Name).Range("A1"))
On Error Resume Next
With qt
.BackgroundQuery = True
.TablesOnlyFromHTML = True
.AdjustColumnWidth = True
.Refresh BackgroundQuery:=False
.SaveData = True
End With
Dim r As Range
Set r = Sheets(onglet.Name).Range("A:A")
'Ci dessous hélas cela creer un décalage
r.TextToColumns Destination:=Sheets(onglet.Name).Range("A1"), comma:=True 'ici ça fonctionne sans les parenthèses
Set r = Nothing
Call inserlign(onglet, numdelalign) ' appelle inserlign pour ajouter la ligne de cotation du jour courant cad temps réél ou différé de 15 min
End Sub
Private Sub inserlign(nomaction, numdelalign)
'insere une ligne vierge en A2 et ensuite y colle les cotations de la journée celle qui sont à 15 minutes près éventuellement
ThisWorkbook.Worksheets(nomaction).Range("A2").EntireRow.Insert
Dim URLinternet, tag, cotationLAST As String
Dim HttpReq As Variant
Dim result As String
result = ThisWorkbook.Worksheets("Base").Range("A" & numdelalign)
Dim i As Integer
Dim montableau As Variant
montableau = Array("o", "h", "g", "l1", "v")
ThisWorkbook.Worksheets(nomaction).Cells(2, 1) = Date
For i = 1 To 5
URLinternet = "http://finance.yahoo.com/d/quotes.csv?s=" & result & "&f=" & CStr(montableau(i)) 'cette amorce de lien permet de ne retirer q'une
' et une seule cotation (pas l'historique tout entier)
Set HttpReq = CreateObject("MSXML2.ServerXMLHTTP")
HttpReq.Open "GET", URLinternet, False
HttpReq.Send "" ' Attention il ne fallait pas oublier les guillemets vides ""
cotationLAST = Trim(HttpReq.responsetext)
cotationLAST = Replace(cotationLAST, Chr$(13), "") 'manipule la string pour enlever les retours chariots
cotationLAST = Replace(cotationLAST, Chr$(10), "")
ThisWorkbook.Worksheets(nomaction).Cells(2, i + 1) = cotationLAST
Set HttpReq = Nothing
Next
End Sub
