téléchargement des cours / des codes reuters-sico-isin...

Zone d'échange de sources C, C++, Java, VB, VBA et autres...

Modérateur : webmaster

Avatar du membre
webmaster
Messages : 769
Enregistré le : 14/06/2003 15:21
Contact :

Message par webmaster » 03/07/2009 23:04

Bonsoir,

Mise à jour du code VBA pour répondre à une question sur un autre fil :

Code : Tout sélectionner

'******************************************************************************
'*                                 Module Cours                               *
'******************************************************************************
'*                                                                            *
'* DESCRIPTION. : Ensemble de macros et fonctions permettant de recuperer des *
'*               cours de valeurs mobilieres sur Internet.                    *
'*                                                                            *
'* AUTEUR...... : webmaster 'La Bourse pour les nains'                        *
'*                http://www.bnains.org/                                      *
'*                                                                            *
'* VERSION..... : 0.1                                                         *
'*                                                                            *
'* ENVIRONNEMENT: Win32. Necessite Wininet. Compatible Excel et OpenOffice (a *
'*                verifier).                                                  *
'*                                                                            *
'* MACROS EXPORTEES :                                                         *
'*   telechargeCours = provoque la creation d'une feuille 'valeurs' a la fin  *
'*                     du classeur courant et y colle les cours des valeurs   *
'*                     de cinq marches, telecharges depuis le site d'Euronext *
'*                                                                            *
'* FONCTIONS EXPORTEES :                                                      *
'*   getCoursValeur ( szCodeISIN ) = renvoie le cours de cloture de la valeur *
'*                                   dont le code ISIN est passe en parametre.*
'*                                                                            *
'******************************************************************************
'* MODIFIE LE : 13/06/2004 PAR Webmaster http://www.bnains.org/               *
'* DESCRIPTION DE LA MODIFICATION :                                           *
'* Adaptation des fonctions telechargeCours() et recupereCours() suite à      *
'* modification du site Euronext (fermeture site SBF remplacé par site        *
'* Euronext).                                                                 *
'*                                                                            *
'* MODIFIE LE : ../../.... PAR ...............                                *
'* DESCRIPTION DE LA MODIFICATION :                                           *
'*                                                                            *
'******************************************************************************

Option Explicit
'==============================================================================
' Import
'==============================================================================
Public Declare Function InternetOpenA Lib "wininet" _
    (ByVal sAgent As String, ByVal lAccessType As Long, _
    ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
    
Public Declare Function InternetCloseHandle Lib "wininet" _
    (ByVal hInet As Long) As Integer
    
Public Declare Function InternetOpenUrlA Lib "wininet" _
    (ByVal hInternetSession As Long, ByVal lpszUrl As String, _
    ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, _
    ByVal dwContext As Long) As Long
    
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Public Declare Function InternetReadFile Lib "wininet" _
    (ByVal hFile As Long, ByVal sBuffer As String, _
    ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer

'==============================================================================
' Déclarations de constantes
'==============================================================================
Public Const INTERNET_OPEN_TYPE_DIRECT = 1
Public Const INTERNET_FLAG_RELOAD = &H80000000

Public Const COLONNE_COURS_CLOTURE = 3
Public Const COLONNE_CODE_ISIN = 1


'******************************************************************************
'*                         Macro telechargerCours                             *
'******************************************************************************
'*                                                                            *
'* Description : cette macro cree une feuille 'Valeurs' a la fin du classeur  *
'*               courant, puis recupere les cours de differents marches.      *
'*                                                                            *
'******************************************************************************
Sub telechargeCours()
' ----- On efface le contenu de la feuille des valeurs -----
Dim bValeurs As Boolean
Dim i As Integer
Dim s As Worksheet

bValeurs = False
For i = 1 To Sheets.Count
  If (Sheets(i).Name = "Valeurs") Then
    bValeurs = True
  End If
Next i

Application.DisplayAlerts = False
If (bValeurs = True) Then
  Worksheets("Valeurs").Delete
End If
Set s = Sheets.Add(After:=Worksheets(Worksheets.Count))
s.Name = "Valeurs"
Application.DisplayAlerts = True

Dim iPage As Integer

'Toutes actions Euronext
iPage = 1
While &#40;iPage <> -1&#41;
  iPage = recupereCours&#40;"http&#58;//www.euronext.com/trader/priceslists/priceslists-1800-FR.html?pageIndex=" + Format&#40;iPage&#41;, iPage&#41;
Wend

' Alternext
iPage = 1
While &#40;iPage <> -1&#41;
  iPage = recupereCours&#40;"http&#58;//www.euronext.com/alternext/pricelist/pricelist-4340-FR.html?pageIndex=" + Format&#40;iPage&#41;, iPage&#41;
Wend

' Marche Libre
iPage = 1
While &#40;iPage <> -1&#41;
  iPage = recupereCours&#40;"http&#58;//www.euronext.com/trader/priceslists/priceslists-1800-FR.html?filter=1&eligibilityList=&mep=8629&belongsToList=market_MC&economicGroupList=&investmentList=&pageIndex=" + Format&#40;iPage&#41;, iPage&#41;
Wend

' Trackers
iPage = 1
While &#40;iPage <> -1&#41;
  iPage = recupereCours&#40;"http&#58;//www.euronext.com/trader/priceslists/pricesliststrackers-1821-FR.html?productFamily=&exposure=&sector=&requestComesFromSearchBoxParameter=true&securityType=401&matchpattern=&instrumentType=4&underlyingType=&indexFamily=", iPage&#41;
Wend


End Sub

'******************************************************************************
'*                         Fonction recupereCours                             *
'******************************************************************************
'*                                                                            *
'* Description &#58; cette fonction recupere une page sur le site Euronext, en    *
'*               extrait les intitulés, codes et cours des valeurs et renvoie *
'*               eventuellement la page suivante si il y en a une.            *
'*               Les intitulés, codes et cours des valeurs sont ajoutées dans *
'*               la feuille 'valeurs' du classeur courant.                    *
'*                                                                            *
'* Entree &#58; URL des donnees a recuperer.                                      *
'*                                                                            *
'* Sortie &#58; ajout de lignes dans la feuille 'Valeurs' du classeur.            *
'*                                                                            *
'* Retour &#58; numero de la page suivante &#40;parametre 'pageIndex' Euronext&#41;.      *
'*                                                                            *
'******************************************************************************
Function recupereCours&#40;szUrl As String, iPage As Integer&#41; As Integer
  Dim hInternetSession As Long     ' handle de la session internet
  Dim hPage As Long                ' handle de la page
  Dim i As Integer
  Dim iPageSuivante As Integer

  '------ On ouvre une connexion -----
  hInternetSession = InternetOpenA&#40;"Wininet", 1, vbNullString, vbNullString, 0&#41;
  If &#40;hInternetSession <> 0&#41; Then
    ' ----- On ouvre la page demandee -----
    hPage = InternetOpenUrlA&#40;hInternetSession, szUrl, vbNullString, 0, _
                             INTERNET_FLAG_RELOAD, 0&#41;
    If &#40;hPage <> 0&#41; Then
      Dim szBuffer As String * 32000   ' Buffer pour lecture de la page
      Dim lNbOctLus As Long            ' Pour recevoir le nombre d'octets lus
      Dim lTaillePage As Long          ' Pour stocker la taille de la page
      Dim bRet As Boolean              ' Pour le code de retour de la lecture
      Dim iLigne As Integer
      Dim iColonne As Integer
      Dim szPage As String
      
      ' ----- On cherche la premiere ligne vide -----
      iLigne = 1
      iColonne = 1
      While &#40;Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, iColonne&#41;.Value <> ""&#41;
        iLigne = iLigne + 1
      Wend
      
      ' ----- On lit le contenu de la page -----
      szPage = vbNullString
      lTaillePage = 0
      Do
        szBuffer = vbNullString
        lNbOctLus = 0
        bRet = InternetReadFile&#40;hPage, szBuffer, 32000, lNbOctLus&#41;
        If &#40;bRet = True And lNbOctLus > 0&#41; Then
          szPage = szPage & Mid$&#40;szBuffer, 1, lNbOctLus&#41;
          lTaillePage = lTaillePage + lNbOctLus
        End If
      Loop While &#40;bRet = True And lNbOctLus <> 0&#41;
          
      ' ----- On ferme le handle de la page -----
      CloseHandle &#40;hPage&#41;
    
      ' ----- On sauve la page pour trace -----
      Open "c&#58;\temp\trackers.htm" For Output As #1
        Write #1, szPage
      Close #1
      
      
      Dim iDeb As Long    ' pointeur dans la page
      iDeb = 1
            
      ' ----- On cherche le debut des donnees qui nous interessent -----
      ' deb = InStr&#40;iDeb, szPage, "<td class=" + Chr&#40;34&#41; + "tableHeader" + Chr&#40;34&#41; + " colspan=" + Chr&#40;34&#41; + "3" + Chr&#40;34&#41; + ">Libellé</td>"&#41;
      
      'While &#40;InStr&#40;iDeb, szPage, "<td class=" + Chr&#40;34&#41; + "tableBgColor2" + Chr&#40;34&#41; + "><span class=" + _
      '                           Chr&#40;34&#41; + "tableValueName" + Chr&#40;34&#41; + ">"&#41; _
      '       And _
      '       InStr&#40;iDeb, szPage, "?isinCode="&#41;&#41;
      While &#40;InStr&#40;iDeb, szPage, "<a href=" + Chr&#40;34&#41; + "/trader/summarizedmarket/summarizedmarketRoot.jsp?"&#41; <> 0 _
             And _
             &#40;InStr&#40;iDeb, szPage, "&amp;isinCode="&#41; <> 0 Or InStr&#40;iDeb, szPage, "&isinCode="&#41; <> 0&#41;&#41;
        Dim deb As Long
        Dim deb1 As Long
        Dim fin As Long
        Dim szCodeISIN As String
        Dim szNom As String
        Dim szCours As String
        Dim bAmpCourt As Boolean
              
        deb = InStr&#40;iDeb, szPage, "<a href=" + Chr&#40;34&#41; + "/trader/summarizedmarket/summarizedmarketRoot.jsp?"&#41;
        If &#40;deb <> 0&#41; Then
          iDeb = deb + Len&#40;"<a href=" + Chr&#40;34&#41; + "/trader/summarizedmarket/summarizedmarketRoot.jsp?"&#41;
        End If
        bAmpCourt = False
        deb = InStr&#40;iDeb, szPage, "&amp;isinCode="&#41;
        If deb = 0 Then
          deb = InStr&#40;iDeb, szPage, "&isinCode="&#41;
          bAmpCourt = True
        End If
        If &#40;deb <> 0&#41; Then
          ' Code ISIN
          If bAmpCourt = True Then deb = deb + Len&#40;"&isinCode="&#41; Else deb = deb + Len&#40;"&amp;isinCode="&#41;
          'fin = InStr&#40;deb, szPage, Chr&#40;34&#41; + ">"&#41;
          fin = deb + 12
          szCodeISIN = Mid$&#40;szPage, deb, fin - deb&#41;
          Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, iColonne&#41;.Value = szCodeISIN
          iColonne = iColonne + 1
          iDeb = fin
          ' Nom
          deb = InStr&#40;iDeb, szPage, ">"&#41;
          deb = deb + 1
          fin = InStr&#40;deb, szPage, "</a>"&#41;
          szNom = Mid$&#40;szPage, deb, fin - deb&#41;
          Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, iColonne&#41;.Value = szNom
          iColonne = iColonne + 1
          iDeb = fin
          ' Cours
          deb = InStr&#40;iDeb, szPage, "class=" + Chr&#40;34&#41; + "tableValueNumRight" + Chr&#40;34&#41; + ">"&#41;
          If deb <> 0 Then
            deb = deb + Len&#40;"class=" + Chr&#40;34&#41; + "tableValueNumRight" + Chr&#40;34&#41; + ">"&#41;
          End If
          deb1 = InStr&#40;deb, szPage, "<a class=" + Chr&#40;34&#41; + "fc1" + Chr&#40;34&#41; + " title="&#41;
          If deb1 <> 0 Then
            deb1 = deb1 + Len&#40;"<a class=" + Chr&#40;34&#41; + "fc1" + Chr&#40;34&#41; + "title="&#41;
            While Mid$&#40;szPage, deb1, 1&#41; <> ">"
              deb1 = deb1 + 1
            Wend
            deb = deb1 + 1
          End If
          szCours = vbNullString
          While &#40;&#40;Mid$&#40;szPage, deb, 1&#41; >= "0" And Mid$&#40;szPage, deb, 1&#41; <= "9"&#41; Or Mid$&#40;szPage, deb, 1&#41; = "."&#41;
            szCours = szCours & Mid$&#40;szPage, deb, 1&#41;
            deb = deb + 1
          Wend
          Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, iColonne&#41;.Value = szCours
          iDeb = fin
          ' Ligne suivante
          iColonne = 1
          iLigne = iLigne + 1
        End If
      Wend
            
    End If
      
    ' ----- Et on regarde si il y a une page suivante -----
    Dim SZ_PAGE_INDEX As String
    SZ_PAGE_INDEX = "pageIndex="

    iPageSuivante = -1
    If &#40;InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41;&#41; Then
      While &#40;InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41; And iPageSuivante <= iPage&#41;
        ' On va chercher le nombre situé après "pageIndex="
        i = 0
        iPageSuivante = 0
        While &#40;Mid$&#40;szPage, InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41; + Len&#40;SZ_PAGE_INDEX&#41; + i, 1&#41; >= "0" And Mid$&#40;szPage, InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41; + Len&#40;SZ_PAGE_INDEX&#41; + i, 1&#41; <= "9"&#41;
          iPageSuivante = iPageSuivante * 10 + Mid$&#40;szPage, InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41; + Len&#40;SZ_PAGE_INDEX&#41; + i, 1&#41;
          i = i + 1
        Wend
        'iPageSuivante = Mid$&#40;szPage, InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41; + Len&#40;SZ_PAGE_INDEX&#41;, InStr&#40;InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41;, szPage, "&"&#41; - &#40;InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41; + Len&#40;SZ_PAGE_INDEX&#41;&#41;&#41;
        iDeb = InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41; + Len&#40;SZ_PAGE_INDEX&#41; + i
      Wend
      If iPageSuivante <= iPage Then iPageSuivante = -1          ' Au cas où...
    End If
      
      
    ' ----- On ferme la connexion -----
    InternetCloseHandle &#40;hInternetSession&#41;
  End If
  
  ' On fixe le code retour
  recupereCours = iPageSuivante

End Function

'******************************************************************************
'*                         Fonction getCoursValeur                            *
'******************************************************************************
'*                                                                            *
'* Description &#58; cette fonction renvoie le cours de cloture d'une valeur en   *
'*               fonction de son code ISIN. Pour ce faire, elle cherche la    *
'*               valeur dans la feuille 'Valeurs' du classeur courant.        *
'*                                                                            *
'* Entree &#58; szCodeISIN = code ISIN de la valeur dont on souhaite connaitre le *
'*                       cours de cloture.                                    *
'*                                                                            *
'* Sortie &#58; Neant.                                                            *
'*                                                                            *
'* Retour &#58; cours de cloture ou '?' si valeur non trouvee.                    *
'*                                                                            *
'******************************************************************************
Function getCoursValeur&#40;szCodeISIN As String&#41; As Double
' On cherche le code dans la feuille 'Valeurs'
Dim iLigne As Integer

iLigne = 1
While &#40;Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, COLONNE_CODE_ISIN&#41;.Value <> "" And _
        Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, COLONNE_CODE_ISIN&#41;.Value <> szCodeISIN&#41;
  iLigne = iLigne + 1
Wend

If Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, COLONNE_CODE_ISIN&#41;.Value = "" Then
  getCoursValeur = "?"
  Exit Function
End If

getCoursValeur = Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, COLONNE_COURS_CLOTURE&#41;.Value

End Function
Pour le mode d'emploi du code, voir plus haut dans le même fil de discussion.

Webmaster

minoux
Messages : 1
Enregistré le : 07/08/2009 16:25

Message par minoux » 07/08/2009 16:36

Bonjour,

Encore merci pour cette macro.
J'ai essayé de la modifier pour l'utiliser derrière un proxy mais sans succès. La variable "bRet" de la commande bRet = InternetReadFile(hPage, szBuffer, 32000, lNbOctLus) reste toujours à "faux".
Si un expert VB pouvait m'indiquer ce qui ne va pas dans le code suivant je lui en serais très reconnaissant :

'******************************************************************************
'* Fonction recupereCours *
'******************************************************************************
'* *
'* Description : cette fonction recupere une page sur le site Euronext, en *
'* extrait les intitulés, codes et cours des valeurs et renvoie *
'* eventuellement la page suivante si il y en a une. *
'* Les intitulés, codes et cours des valeurs sont ajoutées dans *
'* la feuille 'valeurs' du classeur courant. *
'* *
'* Entree : URL des donnees a recuperer. *
'* *
'* Sortie : ajout de lignes dans la feuille 'Valeurs' du classeur. *
'* *
'* Retour : numero de la page suivante (parametre 'pageIndex' Euronext). *
'* *
'******************************************************************************


Function recupereCours(szUrl As String, iPage As Integer) As Integer
Dim hInternetOpen As Long ' handle de la session internet
Dim hInternetConnect As Long ' handle de la connection internet
Dim hHttpOpenRequest As Long ' handle de la connection internet
Dim Hsetoption As Long ' handle de la connection internet
Dim sOptionBuffer As String
Dim optGet As String
Dim iRetVal As Integer
Dim lOptionBufferLen As Long
Dim dwSecFlag As Long
Dim lblContentType As Long
Dim hPage As Long ' handle de la page
Dim i As Integer
Dim iPageSuivante As Integer


'Ouvre session internet - OK si valeur renvoyé<>0
hInternetOpen = InternetOpen("cours", INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
'Connection au serveur HTTP - OK si valeur renvoyé<>0
hInternetConnect = InternetConnect(hInternetOpen, "http://nom_du_proxy", INTERNET_DEFAULT_HTTP_PORT, vbNullString, "HTTP/1.0", INTERNET_SERVICE_HTTP, 0, 0)
' Prépare requête HTTP - OK si valeur renvoyé <>0
hHttpOpenRequest = HttpOpenRequest(hInternetConnect, "GET", szUrl, "HTTP/1.1", 0, 0, INTERNET_FLAG_KEEP_CONNECTION, 0)
' Envoie Requête HTTP - OK valeur renvoyée 1
hPage = HttpSendRequest(hHttpOpenRequest, 0, 0, 0, 0)
hPage = InternetSetOption(hHttpOpenRequest, INTERNET_OPTION_PROXY_USERNAME, "mon_login", Len("mon_login") + 1)
hPage = InternetSetOption(hHttpOpenRequest, INTERNET_OPTION_PROXY_PASSWORD, "mon_password", Len("mon_password") + 1)


If (hPage <> 0) Then
Dim szBuffer As String * 32000 ' Buffer pour lecture de la page
Dim lNbOctLus As Long ' Pour recevoir le nombre d'octets lus
Dim lTaillePage As Long ' Pour stocker la taille de la page
Dim bRet As Boolean ' Pour le code de retour de la lecture
Dim iLigne As Integer
Dim iColonne As Integer
Dim szPage As String

' ----- On cherche la premiere ligne vide -----
iLigne = 1
iColonne = 1
While (Worksheets("Valeurs").Cells(iLigne, iColonne).Value <> "")
iLigne = iLigne + 1
Wend

' ----- On lit le contenu de la page -----
szPage = vbNullString
lTaillePage = 0
Do
szBuffer = vbNullString
lNbOctLus = 0
bRet = InternetReadFile(hPage, szBuffer, 32000, lNbOctLus)
If (bRet = True And lNbOctLus > 0) Then
szPage = szPage & Mid$(szBuffer, 1, lNbOctLus)
lTaillePage = lTaillePage + lNbOctLus
End If
Loop While (bRet = True And lNbOctLus <> 0)

' ----- On ferme le handle de la page -----
CloseHandle (hPage)

' ----- On sauve la page pour trace -----
Open "c:\temp\trackers.htm" For Output As #1
Write #1, szPage
Close #1


Dim iDeb As Long ' pointeur dans la page
iDeb = 1

' ----- On cherche le debut des donnees qui nous interessent -----
' deb = InStr(iDeb, szPage, "<td class=" + Chr(34) + "tableHeader" + Chr(34) + " colspan=" + Chr(34) + "3" + Chr(34) + ">Libellé</td>")

'While (InStr(iDeb, szPage, "<td class=" + Chr(34) + "tableBgColor2" + Chr(34) + "><span class=" + _
' Chr(34) + "tableValueName" + Chr(34) + ">") _
' And _
' InStr(iDeb, szPage, "?isinCode="))
While (InStr(iDeb, szPage, "<a href=" + Chr(34) + "/trader/summarizedmarket/summarizedmarketRoot.jsp?") <> 0 _
And _
(InStr(iDeb, szPage, "&amp;isinCode=") <> 0 Or InStr(iDeb, szPage, "&isinCode=") <> 0))
Dim deb As Long
Dim deb1 As Long
Dim fin As Long
Dim szCodeISIN As String
Dim szNom As String
Dim szCours As String
Dim bAmpCourt As Boolean

deb = InStr(iDeb, szPage, "<a href=" + Chr(34) + "/trader/summarizedmarket/summarizedmarketRoot.jsp?")
If (deb <> 0) Then
iDeb = deb + Len("<a href=" + Chr(34) + "/trader/summarizedmarket/summarizedmarketRoot.jsp?")
End If
bAmpCourt = False
deb = InStr(iDeb, szPage, "&amp;isinCode=")
If deb = 0 Then
deb = InStr(iDeb, szPage, "&isinCode=")
bAmpCourt = True
End If
If (deb <> 0) Then
' Code ISIN
If bAmpCourt = True Then deb = deb + Len("&isinCode=") Else deb = deb + Len("&amp;isinCode=")
'fin = InStr(deb, szPage, Chr(34) + ">")
fin = deb + 12
szCodeISIN = Mid$(szPage, deb, fin - deb)
Worksheets("Valeurs").Cells(iLigne, iColonne).Value = szCodeISIN
iColonne = iColonne + 1
iDeb = fin
' Nom
deb = InStr(iDeb, szPage, ">")
deb = deb + 1
fin = InStr(deb, szPage, "</a>")
szNom = Mid$(szPage, deb, fin - deb)
Worksheets("Valeurs").Cells(iLigne, iColonne).Value = szNom
iColonne = iColonne + 1
iDeb = fin
' Cours
deb = InStr(iDeb, szPage, "class=" + Chr(34) + "tableValueNumRight" + Chr(34) + ">")
If deb <> 0 Then
deb = deb + Len("class=" + Chr(34) + "tableValueNumRight" + Chr(34) + ">")
End If
deb1 = InStr(deb, szPage, "<a class=" + Chr(34) + "fc1" + Chr(34) + " title=")
If deb1 <> 0 Then
deb1 = deb1 + Len("<a class=" + Chr(34) + "fc1" + Chr(34) + "title=")
While Mid$(szPage, deb1, 1) <> ">"
deb1 = deb1 + 1
Wend
deb = deb1 + 1
End If
szCours = vbNullString
While ((Mid$(szPage, deb, 1) >= "0" And Mid$(szPage, deb, 1) <= "9") Or Mid$(szPage, deb, 1) = ".")
szCours = szCours & Mid$(szPage, deb, 1)
deb = deb + 1
Wend
Worksheets("Valeurs").Cells(iLigne, iColonne).Value = szCours
iDeb = fin
' Ligne suivante
iColonne = 1
iLigne = iLigne + 1
End If
Wend

End If

' ----- Et on regarde si il y a une page suivante -----
Dim SZ_PAGE_INDEX As String
SZ_PAGE_INDEX = "pageIndex="

iPageSuivante = -1
If (InStr(iDeb, szPage, SZ_PAGE_INDEX)) Then
While (InStr(iDeb, szPage, SZ_PAGE_INDEX) And iPageSuivante <= iPage)
' On va chercher le nombre situé après "pageIndex="
i = 0
iPageSuivante = 0
While (Mid$(szPage, InStr(iDeb, szPage, SZ_PAGE_INDEX) + Len(SZ_PAGE_INDEX) + i, 1) >= "0" And Mid$(szPage, InStr(iDeb, szPage, SZ_PAGE_INDEX) + Len(SZ_PAGE_INDEX) + i, 1) <= "9")
iPageSuivante = iPageSuivante * 10 + Mid$(szPage, InStr(iDeb, szPage, SZ_PAGE_INDEX) + Len(SZ_PAGE_INDEX) + i, 1)
i = i + 1
Wend
'iPageSuivante = Mid$(szPage, InStr(iDeb, szPage, SZ_PAGE_INDEX) + Len(SZ_PAGE_INDEX), InStr(InStr(iDeb, szPage, SZ_PAGE_INDEX), szPage, "&") - (InStr(iDeb, szPage, SZ_PAGE_INDEX) + Len(SZ_PAGE_INDEX)))
iDeb = InStr(iDeb, szPage, SZ_PAGE_INDEX) + Len(SZ_PAGE_INDEX) + i
Wend
If iPageSuivante <= iPage Then iPageSuivante = -1 ' Au cas où...
End If

CloseHandle (hPage) 'Ferme Fichier Local
InternetCloseHandle hHttpOpenRequest 'Ferme handle requête HTTP
InternetCloseHandle hInternetConnect 'Ferme Connection Internet
InternetCloseHandle hInternetOpen 'Ferme Session internet

End If

' On fixe le code retour
recupereCours = iPageSuivante

End Function

Merci pour vos réponses.

Avatar du membre
webmaster
Messages : 769
Enregistré le : 14/06/2003 15:21
Contact :

Message par webmaster » 10/08/2009 12:02

Bonjour,

Pour que ça fonctionne je pense qu'il faut appeler InternetSetOption() avant d'envoyer la requête HTTP par HttpSendRequest().

Webmaster

Micromini
Messages : 3
Enregistré le : 06/01/2010 15:16

Message par Micromini » 06/01/2010 16:33

Bonjour,

Avant d'accéder au vif du sujet, et comme il s'agit de mon premier post, je commencerai par un petit cirage de pompe comme il se doit ... Bref, merci pour la qualité de ce superbe site et de ce forum qui sont une vrai mine d'informations et qui m'aident beaucoup à me sentir un peu moins petit.

Ceci dit, mon intervention porte sur la mise à jour du code VBA du 03/07/2009. Celle-ci n'a fonctionné qu'après avoir effectué quelques petits changements.

J'avais un problème de caractère non reconnu ( & changé en ?) qui impliquait une valeur toujours égale à 0 et donc un non remplissage de la feuille "Valeurs".

J'avais aussi des valeurs non collectées à cause de la construction booléen (bAmpCourt) et double "comptage/recherche" (deb) qui faisaient sauter des valeurs.

Au final, le fichier Valeurs comprends un peu plus de 2100 valeurs.
' ----- On cherche le debut des donnees qui nous interessent -----
' deb = InStr(iDeb, szPage, "<td class=" + Chr(34) + "tableHeader" + Chr(34) + " colspan=" + Chr(34) + "3" + Chr(34) + ">Libellé</td>")

'While (InStr(iDeb, szPage, "<td class=" + Chr(34) + "tableBgColor2" + Chr(34) + "><span class=" + _
' Chr(34) + "tableValueName" + Chr(34) + ">") _
' And _
' InStr(iDeb, szPage, "?isinCode="))
While (InStr(iDeb, szPage, "<a href=" + Chr(34) + "/trader/summarizedmarket/summarizedmarketRoot.jsp?") <> 0 _
And _
(InStr(iDeb, szPage, "&amp;isinCode=") <> 0 Or InStr(iDeb, szPage, "?isinCode=") <> 0))
Dim deb As Long
Dim deb1 As Long
Dim fin As Long
Dim szCodeISIN As String
Dim szNom As String
Dim szCours As String
Dim bAmpCourt As Boolean

deb = InStr(iDeb, szPage, "<a href=" + Chr(34) + "/trader/summarizedmarket/summarizedmarketRoot.jsp?")
If (deb <> 0) Then
iDeb = deb + Len("<a href=" + Chr(34) + "/trader/summarizedmarket/summarizedmarketRoot.jsp?")
End If
bAmpCourt = False
deb = InStr(iDeb, szPage, "&amp;isinCode=")
If deb = 0 Then
deb = iDeb - 1
bAmpCourt = True
End If
If (deb <> 0) Then
' Code ISIN
If bAmpCourt = True Then deb = deb + Len("?isinCode=") Else deb = deb + Len("&amp;isinCode=")
'fin = InStr(deb, szPage, Chr(34) + ">")
fin = deb + 12
szCodeISIN = Mid$(szPage, deb, fin - deb)
Worksheets("Valeurs").Cells(iLigne, iColonne).Value = szCodeISIN
iColonne = iColonne + 1
iDeb = fin
' Nom
deb = InStr(iDeb, szPage, ">")
deb = deb + 1
fin = InStr(deb, szPage, "</a>")
szNom = Mid$(szPage, deb, fin - deb)
Worksheets("Valeurs").Cells(iLigne, iColonne).Value = szNom
iColonne = iColonne + 1
iDeb = fin

Avatar du membre
webmaster
Messages : 769
Enregistré le : 14/06/2003 15:21
Contact :

Message par webmaster » 06/01/2010 21:26

Bonsoir,

Merci pour votre message. Effectivement la macro a légèrement évolué il y a quelques temps suite à un changement de codage HTML des pages Euronext, mais j'ai oublié de la remettre en ligne. Voici la version complète qui donne effectivement un peu plus de 2100 valeurs :

Code : Tout sélectionner

'******************************************************************************
'*                                 Module Cours                               *
'******************************************************************************
'*                                                                            *
'* DESCRIPTION. &#58; Ensemble de macros et fonctions permettant de recuperer des *
'*               cours de valeurs mobilieres sur Internet.                    *
'*                                                                            *
'* AUTEUR...... &#58; webmaster 'La Bourse pour les nains'                        *
'*                http&#58;//www.bnains.org/                                      *
'*                                                                            *
'* VERSION..... &#58; 0.1                                                         *
'*                                                                            *
'* ENVIRONNEMENT&#58; Win32. Necessite Wininet. Compatible Excel et OpenOffice &#40;a *
'*                verifier&#41;.                                                  *
'*                                                                            *
'* MACROS EXPORTEES &#58;                                                         *
'*   telechargeCours = provoque la creation d'une feuille 'valeurs' a la fin  *
'*                     du classeur courant et y colle les cours des valeurs   *
'*                     de cinq marches, telecharges depuis le site d'Euronext *
'*                                                                            *
'* FONCTIONS EXPORTEES &#58;                                                      *
'*   getCoursValeur &#40; szCodeISIN &#41; = renvoie le cours de cloture de la valeur *
'*                                   dont le code ISIN est passe en parametre.*
'*                                                                            *
'******************************************************************************

Option Explicit
'==============================================================================
' Import
'==============================================================================
Public Declare Function InternetOpenA Lib "wininet" _
    &#40;ByVal sAgent As String, ByVal lAccessType As Long, _
    ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long&#41; As Long
    
Public Declare Function InternetCloseHandle Lib "wininet" _
    &#40;ByVal hInet As Long&#41; As Integer
    
Public Declare Function InternetOpenUrlA Lib "wininet" _
    &#40;ByVal hInternetSession As Long, ByVal lpszUrl As String, _
    ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, _
    ByVal dwContext As Long&#41; As Long
    
Public Declare Function CloseHandle Lib "kernel32" &#40;ByVal hObject As Long&#41; As Long

Public Declare Function InternetReadFile Lib "wininet" _
    &#40;ByVal hFile As Long, ByVal sBuffer As String, _
    ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long&#41; As Integer

'==============================================================================
' Déclarations de constantes
'==============================================================================
Public Const INTERNET_OPEN_TYPE_DIRECT = 1
Public Const INTERNET_FLAG_RELOAD = &H80000000

Public Const COLONNE_COURS_CLOTURE = 3
Public Const COLONNE_CODE_ISIN = 1

'******************************************************************************
'*                         Fonction getCoursValeur                            *
'******************************************************************************
'*                                                                            *
'* Description &#58; cette fonction renvoie le cours de cloture d'une valeur en   *
'*               fonction de son code ISIN. Pour ce faire, elle cherche la    *
'*               valeur dans la feuille 'Valeurs' du classeur courant.        *
'*                                                                            *
'* Entree &#58; szCodeISIN = code ISIN de la valeur dont on souhaite connaitre le *
'*                       cours de cloture.                                    *
'*                                                                            *
'* Sortie &#58; Neant.                                                            *
'*                                                                            *
'* Retour &#58; cours de cloture ou '?' si valeur non trouvee.                    *
'*                                                                            *
'******************************************************************************
Function getCoursValeur&#40;szCodeISIN As String&#41; As Double
' On cherche le code dans la feuille 'Valeurs'
Dim iLigne As Integer

iLigne = 1
While &#40;Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, COLONNE_CODE_ISIN&#41;.Value <> "" And _
        Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, COLONNE_CODE_ISIN&#41;.Value <> szCodeISIN&#41;
  iLigne = iLigne + 1
Wend

If Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, COLONNE_CODE_ISIN&#41;.Value = "" Then
  getCoursValeur = "?"
  Exit Function
End If

getCoursValeur = Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, COLONNE_COURS_CLOTURE&#41;.Value

End Function


'******************************************************************************
'*                         Macro telechargerCours                             *
'******************************************************************************
'*                                                                            *
'* Description &#58; cette macro cree une feuille 'Valeurs' a la fin du classeur  *
'*               courant, puis recupere les cours de differents marches.      *
'*                                                                            *
'******************************************************************************
Sub telechargeCours&#40;&#41;
' ----- On efface le contenu de la feuille des valeurs -----
Dim bValeurs As Boolean
Dim i As Integer
Dim s As Worksheet

bValeurs = False
For i = 1 To Sheets.Count
  If &#40;Sheets&#40;i&#41;.Name = "Valeurs"&#41; Then
    bValeurs = True
  End If
Next i

Application.DisplayAlerts = False
If &#40;bValeurs = True&#41; Then
  Worksheets&#40;"Valeurs"&#41;.Delete
End If
Set s = Sheets.Add&#40;After&#58;=Worksheets&#40;Worksheets.Count&#41;&#41;
s.Name = "Valeurs"
Application.DisplayAlerts = True

Dim iPage As Integer

'Toutes actions Euronext
iPage = 1
While &#40;iPage <> -1&#41;
  iPage = recupereCours&#40;"http&#58;//www.euronext.com/trader/priceslists/priceslists-1800-FR.html?pageIndex=" + Format&#40;iPage&#41;, iPage&#41;
Wend

' Alternext
iPage = 1
While &#40;iPage <> -1&#41;
  iPage = recupereCours&#40;"http&#58;//www.euronext.com/alternext/pricelist/pricelist-4340-FR.html?pageIndex=" + Format&#40;iPage&#41;, iPage&#41;
Wend

' Marche Libre
iPage = 1
While &#40;iPage <> -1&#41;
  iPage = recupereCours&#40;"http&#58;//www.euronext.com/trader/priceslists/priceslists-1800-FR.html?filter=1&eligibilityList=&mep=8629&belongsToList=market_MC&economicGroupList=&investmentList=&pageIndex=" + Format&#40;iPage&#41;, iPage&#41;
Wend

' Trackers
iPage = 1
While &#40;iPage <> -1&#41;
  iPage = recupereCours&#40;"http&#58;//www.euronext.com/trader/priceslists/pricesliststrackers-1821-FR.html?productFamily=&exposure=&sector=&requestComesFromSearchBoxParameter=true&securityType=401&matchpattern=&instrumentType=4&underlyingType=&indexFamily=", iPage&#41;
Wend

End Sub


'******************************************************************************
'*                         Fonction recupereCours                             *
'******************************************************************************
'*                                                                            *
'* Description &#58; cette fonction recupere une page sur le site Euronext, en    *
'*               extrait les intitulés, codes et cours des valeurs et renvoie *
'*               eventuellement la page suivante si il y en a une.            *
'*               Les intitulés, codes et cours des valeurs sont ajoutées dans *
'*               la feuille 'valeurs' du classeur courant.                    *
'*                                                                            *
'* Entree &#58; URL des donnees a recuperer.                                      *
'*                                                                            *
'* Sortie &#58; ajout de lignes dans la feuille 'Valeurs' du classeur.            *
'*                                                                            *
'* Retour &#58; numero de la page suivante &#40;parametre 'pageIndex' Euronext&#41;.      *
'*                                                                            *
'******************************************************************************
Function recupereCours&#40;szUrl As String, iPage As Integer&#41; As Integer
  Dim hInternetSession As Long     ' handle de la session internet
  Dim hPage As Long                ' handle de la page
  Dim i As Integer
  Dim iPageSuivante As Integer

  '------ On ouvre une connexion -----
  hInternetSession = InternetOpenA&#40;"Wininet", 1, vbNullString, vbNullString, 0&#41;
  If &#40;hInternetSession <> 0&#41; Then
    ' ----- On ouvre la page demandee -----
    hPage = InternetOpenUrlA&#40;hInternetSession, szUrl, vbNullString, 0, _
                             INTERNET_FLAG_RELOAD, 0&#41;
    If &#40;hPage <> 0&#41; Then
      Dim szBuffer As String * 32000   ' Buffer pour lecture de la page
      Dim lNbOctLus As Long            ' Pour recevoir le nombre d'octets lus
      Dim lTaillePage As Long          ' Pour stocker la taille de la page
      Dim bRet As Boolean              ' Pour le code de retour de la lecture
      Dim iLigne As Integer
      Dim iColonne As Integer
      Dim szPage As String
      
      ' ----- On cherche la premiere ligne vide -----
      iLigne = 1
      iColonne = 1
      While &#40;Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, iColonne&#41;.Value <> ""&#41;
        iLigne = iLigne + 1
      Wend
      
      ' ----- On lit le contenu de la page -----
      szPage = vbNullString
      lTaillePage = 0
      Do
        szBuffer = vbNullString
        lNbOctLus = 0
        bRet = InternetReadFile&#40;hPage, szBuffer, 32000, lNbOctLus&#41;
        If &#40;bRet = True And lNbOctLus > 0&#41; Then
          szPage = szPage & Mid$&#40;szBuffer, 1, lNbOctLus&#41;
          lTaillePage = lTaillePage + lNbOctLus
        End If
      Loop While &#40;bRet = True And lNbOctLus <> 0&#41;
          
      ' ----- On ferme le handle de la page -----
      CloseHandle &#40;hPage&#41;
    
      ' ----- On sauve la page pour trace -----
      Open "c&#58;\temp\trackers.htm" For Output As #1
        Write #1, szPage
      Close #1
      
      
      Dim iDeb As Long    ' pointeur dans la page
      iDeb = 1
            
      ' ----- On cherche le debut des donnees qui nous interessent -----
      ' deb = InStr&#40;iDeb, szPage, "<td class=" + Chr&#40;34&#41; + "tableHeader" + Chr&#40;34&#41; + " colspan=" + Chr&#40;34&#41; + "3" + Chr&#40;34&#41; + ">Libellé</td>"&#41;
      
      'While &#40;InStr&#40;iDeb, szPage, "<td class=" + Chr&#40;34&#41; + "tableBgColor2" + Chr&#40;34&#41; + "><span class=" + _
      '                           Chr&#40;34&#41; + "tableValueName" + Chr&#40;34&#41; + ">"&#41; _
      '       And _
      '       InStr&#40;iDeb, szPage, "?isinCode="&#41;&#41;
      While &#40;InStr&#40;iDeb, szPage, "<a href=" + Chr&#40;34&#41; + "/trader/summarizedmarket/summarizedmarketRoot.jsp?"&#41; <> 0 _
             And _
             &#40;InStr&#40;iDeb, szPage, "&amp;isinCode="&#41; <> 0 Or InStr&#40;iDeb, szPage, "&isinCode="&#41; <> 0 Or InStr&#40;iDeb, szPage, "?isinCode="&#41; <> 0&#41;&#41;
        Dim deb As Long
        Dim deb1 As Long
        Dim fin As Long
        Dim szCodeISIN As String
        Dim szNom As String
        Dim szCours As String
        Dim bAmpCourt As Boolean
              
        deb = InStr&#40;iDeb, szPage, "<a href=" + Chr&#40;34&#41; + "/trader/summarizedmarket/summarizedmarketRoot.jsp?"&#41;
        If &#40;deb <> 0&#41; Then
          iDeb = deb + Len&#40;"<a href=" + Chr&#40;34&#41; + "/trader/summarizedmarket/summarizedmarketRoot.jsp?"&#41; - 1
        End If
        bAmpCourt = False
        deb = InStr&#40;iDeb, szPage, "&amp;isinCode="&#41;
        If deb = 0 Then
          deb = InStr&#40;iDeb, szPage, "&isinCode="&#41;
          bAmpCourt = True
        End If
        If deb = 0 Then
          deb = InStr&#40;iDeb, szPage, "?isinCode="&#41;
          bAmpCourt = True
        End If
        If &#40;deb <> 0&#41; Then
          ' Code ISIN
          If bAmpCourt = True Then deb = deb + Len&#40;"&isinCode="&#41; Else deb = deb + Len&#40;"&amp;isinCode="&#41;
          'fin = InStr&#40;deb, szPage, Chr&#40;34&#41; + ">"&#41;
          fin = deb + 12
          szCodeISIN = Mid$&#40;szPage, deb, fin - deb&#41;
          Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, iColonne&#41;.Value = szCodeISIN
          iColonne = iColonne + 1
          iDeb = fin
          ' Nom
          deb = InStr&#40;iDeb, szPage, ">"&#41;
          deb = deb + 1
          fin = InStr&#40;deb, szPage, "</a>"&#41;
          szNom = Mid$&#40;szPage, deb, fin - deb&#41;
          Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, iColonne&#41;.Value = szNom
          iColonne = iColonne + 1
          iDeb = fin
          ' Cours
          deb = InStr&#40;iDeb, szPage, "class=" + Chr&#40;34&#41; + "tableValueNumRight" + Chr&#40;34&#41; + ">"&#41;
          If deb <> 0 Then
            deb = deb + Len&#40;"class=" + Chr&#40;34&#41; + "tableValueNumRight" + Chr&#40;34&#41; + ">"&#41;
          End If
          deb1 = InStr&#40;deb, szPage, "<a class=" + Chr&#40;34&#41; + "fc1" + Chr&#40;34&#41; + " title="&#41;
          If deb1 <> 0 Then
            deb1 = deb1 + Len&#40;"<a class=" + Chr&#40;34&#41; + "fc1" + Chr&#40;34&#41; + "title="&#41;
            While Mid$&#40;szPage, deb1, 1&#41; <> ">"
              deb1 = deb1 + 1
            Wend
            deb = deb1 + 1
          End If
          szCours = vbNullString
          While &#40;&#40;Mid$&#40;szPage, deb, 1&#41; >= "0" And Mid$&#40;szPage, deb, 1&#41; <= "9"&#41; Or Mid$&#40;szPage, deb, 1&#41; = "."&#41;
            szCours = szCours & Mid$&#40;szPage, deb, 1&#41;
            deb = deb + 1
          Wend
          Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, iColonne&#41;.Value = szCours
          iDeb = fin
          ' Ligne suivante
          iColonne = 1
          iLigne = iLigne + 1
        End If
      Wend
            
    End If
      
    ' ----- Et on regarde si il y a une page suivante -----
    Dim SZ_PAGE_INDEX As String
    SZ_PAGE_INDEX = "pageIndex="

    iPageSuivante = -1
    If &#40;InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41;&#41; Then
      While &#40;InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41; And iPageSuivante <= iPage&#41;
        ' On va chercher le nombre situé après "pageIndex="
        i = 0
        iPageSuivante = 0
        While &#40;Mid$&#40;szPage, InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41; + Len&#40;SZ_PAGE_INDEX&#41; + i, 1&#41; >= "0" And Mid$&#40;szPage, InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41; + Len&#40;SZ_PAGE_INDEX&#41; + i, 1&#41; <= "9"&#41;
          iPageSuivante = iPageSuivante * 10 + Mid$&#40;szPage, InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41; + Len&#40;SZ_PAGE_INDEX&#41; + i, 1&#41;
          i = i + 1
        Wend
        'iPageSuivante = Mid$&#40;szPage, InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41; + Len&#40;SZ_PAGE_INDEX&#41;, InStr&#40;InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41;, szPage, "&"&#41; - &#40;InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41; + Len&#40;SZ_PAGE_INDEX&#41;&#41;&#41;
        iDeb = InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41; + Len&#40;SZ_PAGE_INDEX&#41; + i
      Wend
      If iPageSuivante <= iPage Then iPageSuivante = -1          ' Au cas où...
    End If
      
      
    ' ----- On ferme la connexion -----
    InternetCloseHandle &#40;hInternetSession&#41;
  End If
  
  ' On fixe le code retour
  recupereCours = iPageSuivante

End Function

Webmaster

Micromini
Messages : 3
Enregistré le : 06/01/2010 15:16

Message par Micromini » 13/01/2010 11:00

Merci Webmaster pour cette nouvelle mouture.

zamislirea
Messages : 1
Enregistré le : 22/02/2010 23:18

Signalisation d'un petit bug

Message par zamislirea » 22/02/2010 23:27

Bonjour,

Cette macro marche très bien chez moi dans la dernière version ci-dessus et je remercie chaudement l'auteur.

Toutefois à la première utilisation le code m'a retrouné une erreur comme quoi le chemin/path n'existait pas (ligne du code concernée : Open "c:\temp\trackers.htm" For Output As #1).

Si cela vous arrive, il suffit de créer un répertoire/dossier "Temp" à la racine de C: et le problème est réglé (moi je n'avais pas ce répertoire dans ma config).

Pas besoin d'intervenir sur le code.

Merci et a+

Avatar du membre
webmaster
Messages : 769
Enregistré le : 14/06/2003 15:21
Contact :

Message par webmaster » 03/03/2010 01:32

Bonsoir,

Oui, très juste, j'ai oublié de mettre en commentaires les lignes qui stockent la page téléchargée à des fins de trace pour analyse en cas de problème de récupération des cours. On peut aussi mettre en commentaires les lignes :
Open "c:\temp\trackers.htm" For Output As #1
Write #1, szPage
Close #1
pour éviter d'avoir à créer le répertoire c:\temp.

Une méthode plus propre consisterait à demander un nom de fichier temporaire à l'aide des API GetTempFileName() et GetTempPath() qui sont faites pour ça. Ce sera pour la prochaine version :wink: !

Webmaster

andromedor
Messages : 1
Enregistré le : 04/03/2010 16:39

Message par andromedor » 04/03/2010 16:55

Bonjour,

Quelle formidable travail en équipe sur ce même code qui fît son appartion sur ce post plusieurs années auparavant. Je l´ai testé, il fonctionne très bien. Félicitation a webmaster!

Je suis nouveau dans le monde de la bourse et je suis en train d´apprendre. Je souhaiterais créer un petit outils d´analyse technique pour pouvoir investir de façon un peu plus intelligente que ce que j´ai fait jusqu´à présent. Je recherche en particulier un code pour pouvoir télécharger l´historique d´une action données sur Euronext (peut-être avec possibilité de pouvoir choisir la période de temps entre 2 valeurs consécutives). Savez-vous si ce code existe déja? Si oui où puis-je le trouver. Sinon avez-vous des idées pour la création de ce code toujours en VBA Excel.

Merci à tous

fx.z
Messages : 7
Enregistré le : 21/06/2011 14:37

Onglet Valeur Vide

Message par fx.z » 21/06/2011 15:42

Bonjour

tout d'abord merci pour cette macro très utile
Malheureusement après de nombreux essais, je n'arrive pas à importer la moindre valeur.

Chaque execution de la macro ne fait qu'apparaitre l'onglet valeur vide

Merci

Avatar du membre
webmaster
Messages : 769
Enregistré le : 14/06/2003 15:21
Contact :

Message par webmaster » 09/07/2011 22:31

Bonjour,

Pouvez-vous nous dire si vous avez un message d'erreur lors de l'exécution de la macro telechargeCours ? Et si oui lequel ?

Webmaster

fx.z
Messages : 7
Enregistré le : 21/06/2011 14:37

Message par fx.z » 11/07/2011 15:21

C'est bien ça le problème...
La macro à l'air de bien s'exécuter mais malheureusement aucune valeur n'apparait???
Bizarre???

Avatar du membre
webmaster
Messages : 769
Enregistré le : 14/06/2003 15:21
Contact :

Message par webmaster » 12/07/2011 21:04

Bonjour,

Pouvez-vous essayer avec la version suivante du module ?

Code : Tout sélectionner

'******************************************************************************
'*                                 Module Cours                               *
'******************************************************************************
'*                                                                            *
'* DESCRIPTION. &#58; Ensemble de macros et fonctions permettant de recuperer des *
'*               cours de valeurs mobilieres sur Internet.                    *
'*                                                                            *
'* AUTEUR...... &#58; webmaster 'La Bourse pour les nains'                        *
'*                http&#58;//www.bnains.org/                                      *
'*                                                                            *
'* VERSION..... &#58; 0.2                                                         *
'*                                                                            *
'* ENVIRONNEMENT&#58; Win32. Necessite Wininet. Compatible Excel et OpenOffice &#40;a *
'*                verifier&#41;.                                                  *
'*                                                                            *
'* MACROS EXPORTEES &#58;                                                         *
'*   telechargeCours = provoque la creation d'une feuille 'valeurs' a la fin  *
'*                     du classeur courant et y colle les cours des valeurs   *
'*                     de cinq marches, telecharges depuis le site d'Euronext *
'*                                                                            *
'* FONCTIONS EXPORTEES &#58;                                                      *
'*   getCoursValeur &#40; szCodeISIN &#41; = renvoie le cours de cloture de la valeur *
'*                                   dont le code ISIN est passe en parametre.*
'*                                                                            *
'******************************************************************************
'* MODIFIE LE &#58; 13/06/2004 PAR Webmaster http&#58;//www.bnains.org/               *
'* DESCRIPTION DE LA MODIFICATION &#58;                                           *
'* Adaptation des fonctions telechargeCours&#40;&#41; et recupereCours&#40;&#41; suite à      *
'* modification du site Euronext &#40;fermeture site SBF remplacé par site        *
'* Euronext&#41;.                                                                 *
'*                                                                            *
'* MODIFIE LE &#58; 12/07/2011 PAR Webmaster http&#58;//www.bnains.org/               *
'* DESCRIPTION DE LA MODIFICATION &#58;                                           *
'* Ajout du recalcul automatique du classeur apres telechargement des cours.  *
'* Ajout traitement des erreurs de connexion et de recuperation de pages      *
'* HTML.                                                                      *
'*                                                                            *
'* MODIFIE LE &#58; ../../.... PAR ................................               *
'* DESCRIPTION DE LA MODIFICATION &#58;                                           *
'*                                                                            *
'******************************************************************************

Option Explicit

'==============================================================================
' Import des fonction Wininet et Kernel32 necessaires
'==============================================================================
Public Declare Function InternetOpenA Lib "wininet" _
    &#40;ByVal sAgent As String, ByVal lAccessType As Long, _
    ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long&#41; As Long
    
Public Declare Function InternetCloseHandle Lib "wininet" _
    &#40;ByVal hInet As Long&#41; As Integer
    
Public Declare Function InternetOpenUrlA Lib "wininet" _
    &#40;ByVal hInternetSession As Long, ByVal lpszUrl As String, _
    ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, _
    ByVal dwContext As Long&#41; As Long
    
Public Declare Function CloseHandle Lib "kernel32" &#40;ByVal hObject As Long&#41; As Long

Public Declare Function InternetReadFile Lib "wininet" _
    &#40;ByVal hFile As Long, ByVal sBuffer As String, _
    ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long&#41; As Integer

 Public Declare Function InternetGetLastResponseInfo Lib "wininet.dll" Alias "InternetGetLastResponseInfoA" _
    &#40;lpdwError As Long, ByVal lpszBuffer As String, _
        lpdwBufferLength As Long&#41; As Boolean


'==============================================================================
' Déclarations de constantes
'==============================================================================
Public Const INTERNET_OPEN_TYPE_DIRECT = 1
Public Const INTERNET_FLAG_RELOAD = &H80000000

Public Const COLONNE_COURS_CLOTURE = 3
Public Const COLONNE_CODE_ISIN = 1


'******************************************************************************
'*                         Macro telechargerCours                             *
'******************************************************************************
'*                                                                            *
'* Description &#58; cette macro cree une feuille 'Valeurs' a la fin du classeur  *
'*               courant, puis recupere les cours de differents marches.      *
'*                                                                            *
'******************************************************************************
Sub telechargeCours&#40;&#41;
' ----- On efface le contenu de la feuille des valeurs -----
Dim bValeurs As Boolean
Dim i As Integer
Dim s As Worksheet

bValeurs = False
For i = 1 To Sheets.Count
  If &#40;Sheets&#40;i&#41;.Name = "Valeurs"&#41; Then
    bValeurs = True
  End If
Next i

Application.DisplayAlerts = False
If &#40;bValeurs = True&#41; Then
  Worksheets&#40;"Valeurs"&#41;.Delete
End If
Set s = Sheets.Add&#40;After&#58;=Worksheets&#40;Worksheets.Count&#41;&#41;
s.Name = "Valeurs"
Application.DisplayAlerts = True

Dim iPage As Integer

'Toutes actions Euronext
iPage = 1
While &#40;iPage <> -1&#41;
  iPage = recupereCours&#40;"http&#58;//www.euronext.com/trader/priceslists/priceslists-1800-FR.html?pageIndex=" + Format&#40;iPage&#41;, iPage&#41;
Wend

' Alternext
iPage = 1
While &#40;iPage <> -1&#41;
  iPage = recupereCours&#40;"http&#58;//www.euronext.com/alternext/pricelist/pricelist-4340-FR.html?pageIndex=" + Format&#40;iPage&#41;, iPage&#41;
Wend

' Marche Libre
iPage = 1
While &#40;iPage <> -1&#41;
  iPage = recupereCours&#40;"http&#58;//www.euronext.com/trader/priceslists/priceslists-1800-FR.html?filter=1&eligibilityList=&mep=8629&belongsToList=market_MC&economicGroupList=&investmentList=&pageIndex=" + Format&#40;iPage&#41;, iPage&#41;
Wend

' Trackers
iPage = 1
While &#40;iPage <> -1&#41;
  iPage = recupereCours&#40;"http&#58;//www.euronext.com/trader/priceslists/pricesliststrackers-1821-FR.html?productFamily=&exposure=&sector=&requestComesFromSearchBoxParameter=true&securityType=401&matchpattern=&instrumentType=4&underlyingType=&indexFamily=", iPage&#41;
Wend

' Provoquer le recalcul de l'ensemble du classeur pour prise en compte des nouveaux cours
Application.CalculateFull

End Sub





'******************************************************************************
'*                         Fonction getCoursValeur                            *
'******************************************************************************
'*                                                                            *
'* Description &#58; cette fonction renvoie le cours de cloture d'une valeur en   *
'*               fonction de son code ISIN. Pour ce faire, elle cherche la    *
'*               valeur dans la feuille 'Valeurs' du classeur courant.        *
'*                                                                            *
'* Entree &#58; szCodeISIN = code ISIN de la valeur dont on souhaite connaitre le *
'*                       cours de cloture.                                    *
'*                                                                            *
'* Sortie &#58; Neant.                                                            *
'*                                                                            *
'* Retour &#58; cours de cloture ou '?' si valeur non trouvee.                    *
'*                                                                            *
'******************************************************************************
Function getCoursValeur&#40;szCodeISIN As String&#41; As Double
' On cherche le code dans la feuille 'Valeurs'
Dim iLigne As Integer

iLigne = 1
While &#40;Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, COLONNE_CODE_ISIN&#41;.Value <> "" And _
        Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, COLONNE_CODE_ISIN&#41;.Value <> szCodeISIN&#41;
  iLigne = iLigne + 1
Wend

If Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, COLONNE_CODE_ISIN&#41;.Value = "" Then
  getCoursValeur = "?"
  Exit Function
End If

getCoursValeur = Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, COLONNE_COURS_CLOTURE&#41;.Value

End Function


'******************************************************************************
'*                         Fonction recupereCours                             *
'******************************************************************************
'*                                                                            *
'* Description &#58; cette fonction recupere une page sur le site Euronext, en    *
'*               extrait les intitulés, codes et cours des valeurs et renvoie *
'*               eventuellement la page suivante si il y en a une.            *
'*               Les intitulés, codes et cours des valeurs sont ajoutées dans *
'*               la feuille 'valeurs' du classeur courant.                    *
'*                                                                            *
'* Entree &#58; URL des donnees a recuperer.                                      *
'*                                                                            *
'* Sortie &#58; ajout de lignes dans la feuille 'Valeurs' du classeur.            *
'*                                                                            *
'* Retour &#58; numero de la page suivante &#40;parametre 'pageIndex' Euronext&#41;.      *
'*                                                                            *
'******************************************************************************
Function recupereCours&#40;szUrl As String, iPage As Integer&#41; As Integer
  Dim hInternetSession As Long     ' handle de la session internet
  Dim hPage As Long                ' handle de la page
  Dim i As Integer
  Dim iPageSuivante As Integer

  '------ On ouvre une connexion -----
  hInternetSession = InternetOpenA&#40;"Wininet", 1, vbNullString, vbNullString, 0&#41;
  If &#40;hInternetSession <> 0&#41; Then
    ' ----- On ouvre la page demandee -----
    hPage = InternetOpenUrlA&#40;hInternetSession, szUrl, vbNullString, 0, _
                             INTERNET_FLAG_RELOAD, 0&#41;
    If &#40;hPage <> 0&#41; Then
      Dim szBuffer As String * 32000   ' Buffer pour lecture de la page
      Dim lNbOctLus As Long            ' Pour recevoir le nombre d'octets lus
      Dim lTaillePage As Long          ' Pour stocker la taille de la page
      Dim bRet As Boolean              ' Pour le code de retour de la lecture
      Dim iLigne As Integer
      Dim iColonne As Integer
      Dim szPage As String
      
      ' ----- On cherche la premiere ligne vide -----
      iLigne = 1
      iColonne = 1
      While &#40;Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, iColonne&#41;.Value <> ""&#41;
        iLigne = iLigne + 1
      Wend
      
      ' ----- On lit le contenu de la page -----
      szPage = vbNullString
      lTaillePage = 0
      Do
        szBuffer = vbNullString
        lNbOctLus = 0
        bRet = InternetReadFile&#40;hPage, szBuffer, 32000, lNbOctLus&#41;
        If &#40;bRet = True And lNbOctLus > 0&#41; Then
          szPage = szPage & Mid$&#40;szBuffer, 1, lNbOctLus&#41;
          lTaillePage = lTaillePage + lNbOctLus
        Else
          If bRet = False Then
            AfficheErreurInternet
          End If
        End If
      Loop While &#40;bRet = True And lNbOctLus <> 0&#41;
          
      ' ----- On ferme le handle de la page -----
      CloseHandle &#40;hPage&#41;
    
      ' ----- On sauve la page pour trace -----
      ' Open "c&#58;\temp\trackers.htm" For Output As #1
      '  Write #1, szPage
      ' Close #1
      
      
      Dim iDeb As Long    ' pointeur dans la page
      iDeb = 1
            
      ' ----- On cherche le debut des donnees qui nous interessent -----
      ' deb = InStr&#40;iDeb, szPage, "<td class=" + Chr&#40;34&#41; + "tableHeader" + Chr&#40;34&#41; + " colspan=" + Chr&#40;34&#41; + "3" + Chr&#40;34&#41; + ">Libellé</td>"&#41;
      
      'While &#40;InStr&#40;iDeb, szPage, "<td class=" + Chr&#40;34&#41; + "tableBgColor2" + Chr&#40;34&#41; + "><span class=" + _
      '                           Chr&#40;34&#41; + "tableValueName" + Chr&#40;34&#41; + ">"&#41; _
      '       And _
      '       InStr&#40;iDeb, szPage, "?isinCode="&#41;&#41;
      While &#40;InStr&#40;iDeb, szPage, "<a href=" + Chr&#40;34&#41; + "/trader/summarizedmarket/summarizedmarketRoot.jsp?"&#41; <> 0 _
             And _
             &#40;InStr&#40;iDeb, szPage, "&amp;isinCode="&#41; <> 0 Or InStr&#40;iDeb, szPage, "&isinCode="&#41; <> 0 Or InStr&#40;iDeb, szPage, "?isinCode="&#41; <> 0&#41;&#41;
        Dim deb As Long
        Dim deb1 As Long
        Dim fin As Long
        Dim szCodeISIN As String
        Dim szNom As String
        Dim szCours As String
        Dim bAmpCourt As Boolean
              
        deb = InStr&#40;iDeb, szPage, "<a href=" + Chr&#40;34&#41; + "/trader/summarizedmarket/summarizedmarketRoot.jsp?"&#41;
        If &#40;deb <> 0&#41; Then
          iDeb = deb + Len&#40;"<a href=" + Chr&#40;34&#41; + "/trader/summarizedmarket/summarizedmarketRoot.jsp?"&#41; - 1
        End If
        bAmpCourt = False
        deb = InStr&#40;iDeb, szPage, "&amp;isinCode="&#41;
        If deb = 0 Then
          deb = InStr&#40;iDeb, szPage, "&isinCode="&#41;
          bAmpCourt = True
        End If
        If deb = 0 Then
          deb = InStr&#40;iDeb, szPage, "?isinCode="&#41;
          bAmpCourt = True
        End If
        If &#40;deb <> 0&#41; Then
          ' Code ISIN
          If bAmpCourt = True Then deb = deb + Len&#40;"&isinCode="&#41; Else deb = deb + Len&#40;"&amp;isinCode="&#41;
          'fin = InStr&#40;deb, szPage, Chr&#40;34&#41; + ">"&#41;
          fin = deb + 12
          szCodeISIN = Mid$&#40;szPage, deb, fin - deb&#41;
          Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, iColonne&#41;.Value = szCodeISIN
          iColonne = iColonne + 1
          iDeb = fin
          ' Nom
          deb = InStr&#40;iDeb, szPage, ">"&#41;
          deb = deb + 1
          fin = InStr&#40;deb, szPage, "</a>"&#41;
          szNom = Mid$&#40;szPage, deb, fin - deb&#41;
          Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, iColonne&#41;.Value = szNom
          iColonne = iColonne + 1
          iDeb = fin
          ' Cours
          deb = InStr&#40;iDeb, szPage, "class=" + Chr&#40;34&#41; + "tableValueNumRight" + Chr&#40;34&#41; + ">"&#41;
          If deb <> 0 Then
            deb = deb + Len&#40;"class=" + Chr&#40;34&#41; + "tableValueNumRight" + Chr&#40;34&#41; + ">"&#41;
          End If
          deb1 = InStr&#40;deb, szPage, "<a class=" + Chr&#40;34&#41; + "fc1" + Chr&#40;34&#41; + " title="&#41;
          If deb1 <> 0 Then
            deb1 = deb1 + Len&#40;"<a class=" + Chr&#40;34&#41; + "fc1" + Chr&#40;34&#41; + "title="&#41;
            While Mid$&#40;szPage, deb1, 1&#41; <> ">"
              deb1 = deb1 + 1
            Wend
            deb = deb1 + 1
          End If
          szCours = vbNullString
          While &#40;&#40;Mid$&#40;szPage, deb, 1&#41; >= "0" And Mid$&#40;szPage, deb, 1&#41; <= "9"&#41; Or Mid$&#40;szPage, deb, 1&#41; = "."&#41;
            szCours = szCours & Mid$&#40;szPage, deb, 1&#41;
            deb = deb + 1
          Wend
          Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, iColonne&#41;.Value = szCours
          iDeb = fin
          ' Ligne suivante
          iColonne = 1
          iLigne = iLigne + 1
        End If
      Wend
      
    Else
      AfficheErreurInternet
    End If
      
    ' ----- Et on regarde si il y a une page suivante -----
    Dim SZ_PAGE_INDEX As String
    SZ_PAGE_INDEX = "pageIndex="

    iPageSuivante = -1
    If &#40;InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41;&#41; Then
      While &#40;InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41; And iPageSuivante <= iPage&#41;
        ' On va chercher le nombre situé après "pageIndex="
        i = 0
        iPageSuivante = 0
        While &#40;Mid$&#40;szPage, InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41; + Len&#40;SZ_PAGE_INDEX&#41; + i, 1&#41; >= "0" And Mid$&#40;szPage, InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41; + Len&#40;SZ_PAGE_INDEX&#41; + i, 1&#41; <= "9"&#41;
          iPageSuivante = iPageSuivante * 10 + Mid$&#40;szPage, InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41; + Len&#40;SZ_PAGE_INDEX&#41; + i, 1&#41;
          i = i + 1
        Wend
        'iPageSuivante = Mid$&#40;szPage, InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41; + Len&#40;SZ_PAGE_INDEX&#41;, InStr&#40;InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41;, szPage, "&"&#41; - &#40;InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41; + Len&#40;SZ_PAGE_INDEX&#41;&#41;&#41;
        iDeb = InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41; + Len&#40;SZ_PAGE_INDEX&#41; + i
      Wend
      If iPageSuivante <= iPage Then iPageSuivante = -1          ' Au cas où...
    End If
      
      
    ' ----- On ferme la connexion -----
    InternetCloseHandle &#40;hInternetSession&#41;
    
  Else
    AfficheErreurInternet
  End If
  
  ' On fixe le code retour
  recupereCours = iPageSuivante

End Function

'******************************************************************************
'*                      Fonction AfficheErreurInternet                        *
'******************************************************************************
'*                                                                            *
'* Description &#58; cette fonction recupere l'origine d'une erreur de l'API      *
'*               Wininet et affiche le message d'erreur correspondant.        *
'*                                                                            *
'* Entree &#58; neant.                                                            *
'*                                                                            *
'* Sortie &#58; neant.                                                            *
'*                                                                            *
'* Retour &#58; neant.                                                            *
'*                                                                            *
'******************************************************************************

Sub AfficheErreurInternet&#40;&#41;

  Dim lErr As Long, sErr As String, lenBuf As Long

  ' On recupere la taille du buffer necessaire pour le message d'erreur
  InternetGetLastResponseInfo lErr, sErr, lenBuf
  
  ' On cree le buffer
  sErr = String&#40;lenBuf, 0&#41;
  
  ' On recupere la derniere erreur avec le message correspondant
  InternetGetLastResponseInfo lErr, sErr, lenBuf
  
  ' On affiche l'erreur
  MsgBox "Erreur " + CStr&#40;lErr&#41; + "&#58; " + sErr, vbOKOnly + vbCritical
  
End Sub
J'ai ajouté des affichages d'erreurs sur les fonctions d'accès internet.

Est-ce qu'un message d'erreur s'affiche ? Si oui, lequel ?

Question subsidiaire : que contient le fichier c:\temp\trackers.htm ?

Accessoirement et au cas où : essayez-vous d'utiliser la macro de téléchargement depuis une connexion internet nécessitant le passage par un proxy qui vous demande une identification/authentification ?

Webmaster

fx.z
Messages : 7
Enregistré le : 21/06/2011 14:37

Message par fx.z » 18/07/2011 10:52

Merci pour cette aide
l erreur renvoyée est Erreur 0
je n'ai pas accès au répertoire c je suis derriere un serveur citrix...j'ai donc crée un dossier temps dans un repertoire et j'ai une aurtorisation d'écriture (sans fichier trackers)

Avatar du membre
webmaster
Messages : 769
Enregistré le : 14/06/2003 15:21
Contact :

Message par webmaster » 18/07/2011 22:29

Bonjour,

Pouvez-vous essayez la nouvelle version ci-dessous et m'indiquer le message d'erreur ?

Par ailleurs, êtes-vous certain de ne pas être derrière un proxy ? Lorsque vous accéder à internet avec votre navigateur, est-ce qu'un identifiant et un mot de passe indépendants du site que vous essayez d'atteindre vous sont demandés par votre navigateur ?

Code : Tout sélectionner

'******************************************************************************
'*                                 Module Cours                               *
'******************************************************************************
'*                                                                            *
'* DESCRIPTION. &#58; Ensemble de macros et fonctions permettant de recuperer des *
'*               cours de valeurs mobilieres sur Internet.                    *
'*                                                                            *
'* AUTEUR...... &#58; webmaster 'La Bourse pour les nains'                        *
'*                http&#58;//www.bnains.org/                                      *
'*                                                                            *
'* VERSION..... &#58; 0.2                                                         *
'*                                                                            *
'* ENVIRONNEMENT&#58; Win32. Necessite Wininet. Compatible Excel et OpenOffice &#40;a *
'*                verifier&#41;.                                                  *
'*                                                                            *
'* MACROS EXPORTEES &#58;                                                         *
'*   telechargeCours = provoque la creation d'une feuille 'valeurs' a la fin  *
'*                     du classeur courant et y colle les cours des valeurs   *
'*                     de cinq marches, telecharges depuis le site d'Euronext *
'*                                                                            *
'* FONCTIONS EXPORTEES &#58;                                                      *
'*   getCoursValeur &#40; szCodeISIN &#41; = renvoie le cours de cloture de la valeur *
'*                                   dont le code ISIN est passe en parametre.*
'*                                                                            *
'******************************************************************************
'* MODIFIE LE &#58; 13/06/2004 PAR Webmaster http&#58;//www.bnains.org/               *
'* DESCRIPTION DE LA MODIFICATION &#58;                                           *
'* Adaptation des fonctions telechargeCours&#40;&#41; et recupereCours&#40;&#41; suite à      *
'* modification du site Euronext &#40;fermeture site SBF remplacé par site        *
'* Euronext&#41;.                                                                 *
'*                                                                            *
'* MODIFIE LE &#58; 12/07/2011 PAR Webmaster http&#58;//www.bnains.org/               *
'* DESCRIPTION DE LA MODIFICATION &#58;                                           *
'* Ajout du recalcul automatique du classeur apres telechargement des cours.  *
'* Ajout traitement des erreurs de connexion et de recuperation de pages      *
'* HTML.                                                                      *
'*                                                                            *
'* MODIFIE LE &#58; 18/07/2011 PAR Webmaster http&#58;//www.bnains.org/               *
'* DESCRIPTION DE LA MODIFICATION &#58;                                           *
'* Modification traitement des erreurs de connexion et de recuperation de     *
'* pages HTML.                                                                *
'*                                                                            *
'******************************************************************************

Option Explicit

'==============================================================================
' Import des fonction Wininet et Kernel32 necessaires
'==============================================================================
Public Declare Function InternetOpen Lib "wininet" Alias "InternetOpenA" _
    &#40;ByVal sAgent As String, ByVal lAccessType As Long, _
    ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long&#41; As Long
    
Public Declare Function InternetCloseHandle Lib "wininet" _
    &#40;ByVal hInet As Long&#41; As Integer
    
Public Declare Function InternetOpenUrl Lib "wininet" Alias "InternetOpenUrlA" _
    &#40;ByVal hInternetSession As Long, ByVal lpszUrl As String, _
    ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, _
    ByVal dwContext As Long&#41; As Long
    
Public Declare Function CloseHandle Lib "kernel32" &#40;ByVal hObject As Long&#41; As Long

Public Declare Function InternetReadFile Lib "wininet" _
    &#40;ByVal hFile As Long, ByVal sBuffer As String, _
    ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long&#41; As Integer

Public Declare Function InternetGetLastResponseInfo Lib "wininet.dll" Alias "InternetGetLastResponseInfoA" _
    &#40;lpdwError As Long, ByVal lpszBuffer As String, _
        lpdwBufferLength As Long&#41; As Boolean

Public Declare Function GetLastError Lib "kernel32" &#40;&#41; As Long

Public Declare Function FormatMessage Lib "kernel32" _
    Alias "FormatMessageA" &#40; _
    ByVal dwFlags As Long, _
    ByVal lpSource As Any, _
    ByVal dwMessageId As Long, _
    ByVal dwLanguageId As Long, _
    ByVal lpBuffer As String, _
    ByVal nSize As Long, _
    ByRef Arguments As Long&#41; As Long

'==============================================================================
' Déclarations de constantes
'==============================================================================
Public Const INTERNET_OPEN_TYPE_DIRECT = 1
Public Const INTERNET_FLAG_RELOAD = &H80000000

Public Const COLONNE_COURS_CLOTURE = 3
Public Const COLONNE_CODE_ISIN = 1

' ----- Constantes utiles pour FormatMessage -----
Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER As Long = &H100
Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY  As Long = &H2000
Private Const FORMAT_MESSAGE_FROM_HMODULE  As Long = &H800
Private Const FORMAT_MESSAGE_FROM_STRING  As Long = &H400
Private Const FORMAT_MESSAGE_FROM_SYSTEM  As Long = &H1000
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK  As Long = &HFF
Private Const FORMAT_MESSAGE_IGNORE_INSERTS  As Long = &H200
Private Const FORMAT_MESSAGE_TEXT_LEN  As Long = &HA0


'******************************************************************************
'*                         Macro telechargerCours                             *
'******************************************************************************
'*                                                                            *
'* Description &#58; cette macro cree une feuille 'Valeurs' a la fin du classeur  *
'*               courant, puis recupere les cours de differents marches.      *
'*                                                                            *
'******************************************************************************
Sub telechargeCours&#40;&#41;
' ----- On efface le contenu de la feuille des valeurs -----
Dim bValeurs As Boolean
Dim i As Integer
Dim s As Worksheet

bValeurs = False
For i = 1 To Sheets.Count
  If &#40;Sheets&#40;i&#41;.Name = "Valeurs"&#41; Then
    bValeurs = True
  End If
Next i

Application.DisplayAlerts = False
If &#40;bValeurs = True&#41; Then
  Worksheets&#40;"Valeurs"&#41;.Delete
End If
Set s = Sheets.Add&#40;After&#58;=Worksheets&#40;Worksheets.Count&#41;&#41;
s.Name = "Valeurs"
Application.DisplayAlerts = True

Dim iPage As Integer

'Toutes actions Euronext
iPage = 1
While &#40;iPage <> -1&#41;
  iPage = recupereCours&#40;"http&#58;//www.euronext.com/trader/priceslists/priceslists-1800-FR.html?pageIndex=" + Format&#40;iPage&#41;, iPage&#41;
Wend

' Alternext
iPage = 1
While &#40;iPage <> -1&#41;
  iPage = recupereCours&#40;"http&#58;//www.euronext.com/alternext/pricelist/pricelist-4340-FR.html?pageIndex=" + Format&#40;iPage&#41;, iPage&#41;
Wend

' Marche Libre
iPage = 1
While &#40;iPage <> -1&#41;
  iPage = recupereCours&#40;"http&#58;//www.euronext.com/trader/priceslists/priceslists-1800-FR.html?filter=1&eligibilityList=&mep=8629&belongsToList=market_MC&economicGroupList=&investmentList=&pageIndex=" + Format&#40;iPage&#41;, iPage&#41;
Wend

' Trackers
iPage = 1
While &#40;iPage <> -1&#41;
  iPage = recupereCours&#40;"http&#58;//www.euronext.com/trader/priceslists/pricesliststrackers-1821-FR.html?productFamily=&exposure=&sector=&requestComesFromSearchBoxParameter=true&securityType=401&matchpattern=&instrumentType=4&underlyingType=&indexFamily=", iPage&#41;
Wend

' Provoquer le recalcul de l'ensemble du classeur pour prise en compte des nouveaux cours
Application.CalculateFull

End Sub





'******************************************************************************
'*                         Fonction getCoursValeur                            *
'******************************************************************************
'*                                                                            *
'* Description &#58; cette fonction renvoie le cours de cloture d'une valeur en   *
'*               fonction de son code ISIN. Pour ce faire, elle cherche la    *
'*               valeur dans la feuille 'Valeurs' du classeur courant.        *
'*                                                                            *
'* Entree &#58; szCodeISIN = code ISIN de la valeur dont on souhaite connaitre le *
'*                       cours de cloture.                                    *
'*                                                                            *
'* Sortie &#58; Neant.                                                            *
'*                                                                            *
'* Retour &#58; cours de cloture ou '?' si valeur non trouvee.                    *
'*                                                                            *
'******************************************************************************
Function getCoursValeur&#40;szCodeISIN As String&#41; As Double
' On cherche le code dans la feuille 'Valeurs'
Dim iLigne As Integer

iLigne = 1
While &#40;Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, COLONNE_CODE_ISIN&#41;.Value <> "" And _
        Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, COLONNE_CODE_ISIN&#41;.Value <> szCodeISIN&#41;
  iLigne = iLigne + 1
Wend

If Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, COLONNE_CODE_ISIN&#41;.Value = "" Then
  getCoursValeur = "?"
  Exit Function
End If

getCoursValeur = Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, COLONNE_COURS_CLOTURE&#41;.Value

End Function


'******************************************************************************
'*                         Fonction recupereCours                             *
'******************************************************************************
'*                                                                            *
'* Description &#58; cette fonction recupere une page sur le site Euronext, en    *
'*               extrait les intitulés, codes et cours des valeurs et renvoie *
'*               eventuellement la page suivante si il y en a une.            *
'*               Les intitulés, codes et cours des valeurs sont ajoutées dans *
'*               la feuille 'valeurs' du classeur courant.                    *
'*                                                                            *
'* Entree &#58; URL des donnees a recuperer.                                      *
'*                                                                            *
'* Sortie &#58; ajout de lignes dans la feuille 'Valeurs' du classeur.            *
'*                                                                            *
'* Retour &#58; numero de la page suivante &#40;parametre 'pageIndex' Euronext&#41;.      *
'*                                                                            *
'******************************************************************************
Function recupereCours&#40;szUrl As String, iPage As Integer&#41; As Integer
  Dim hInternetSession As Long     ' handle de la session internet
  Dim hPage As Long                ' handle de la page
  Dim i As Integer
  Dim iPageSuivante As Integer

  '------ On ouvre une connexion -----
  hInternetSession = InternetOpen&#40;"Wininet", 1, vbNullString, vbNullString, 0&#41;
  If &#40;hInternetSession <> 0&#41; Then
    ' ----- On ouvre la page demandee -----
    hPage = InternetOpenUrl&#40;hInternetSession, szUrl, vbNullString, 0, _
                            INTERNET_FLAG_RELOAD, 0&#41;
    If &#40;hPage <> 0&#41; Then
      Dim szBuffer As String * 32000   ' Buffer pour lecture de la page
      Dim lNbOctLus As Long            ' Pour recevoir le nombre d'octets lus
      Dim lTaillePage As Long          ' Pour stocker la taille de la page
      Dim bRet As Boolean              ' Pour le code de retour de la lecture
      Dim iLigne As Integer
      Dim iColonne As Integer
      Dim szPage As String
      
      ' ----- On cherche la premiere ligne vide -----
      iLigne = 1
      iColonne = 1
      While &#40;Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, iColonne&#41;.Value <> ""&#41;
        iLigne = iLigne + 1
      Wend
      
      ' ----- On lit le contenu de la page -----
      szPage = vbNullString
      lTaillePage = 0
      Do
        szBuffer = vbNullString
        lNbOctLus = 0
        bRet = InternetReadFile&#40;hPage, szBuffer, 32000, lNbOctLus&#41;
        If &#40;bRet = True And lNbOctLus > 0&#41; Then
          szPage = szPage & Mid$&#40;szBuffer, 1, lNbOctLus&#41;
          lTaillePage = lTaillePage + lNbOctLus
        Else
          If bRet = False Then
            AfficheErreurInternet &#40;"InternetReadFile"&#41;
          End If
        End If
      Loop While &#40;bRet = True And lNbOctLus <> 0&#41;
          
      ' ----- On ferme le handle de la page -----
      CloseHandle &#40;hPage&#41;
    
      ' ----- On sauve la page pour trace -----
      ' Open "c&#58;\temp\trackers.htm" For Output As #1
      '  Write #1, szPage
      ' Close #1
      
      
      Dim iDeb As Long    ' pointeur dans la page
      iDeb = 1
            
      ' ----- On cherche le debut des donnees qui nous interessent -----
      ' deb = InStr&#40;iDeb, szPage, "<td class=" + Chr&#40;34&#41; + "tableHeader" + Chr&#40;34&#41; + " colspan=" + Chr&#40;34&#41; + "3" + Chr&#40;34&#41; + ">Libellé</td>"&#41;
      
      'While &#40;InStr&#40;iDeb, szPage, "<td class=" + Chr&#40;34&#41; + "tableBgColor2" + Chr&#40;34&#41; + "><span class=" + _
      '                           Chr&#40;34&#41; + "tableValueName" + Chr&#40;34&#41; + ">"&#41; _
      '       And _
      '       InStr&#40;iDeb, szPage, "?isinCode="&#41;&#41;
      While &#40;InStr&#40;iDeb, szPage, "<a href=" + Chr&#40;34&#41; + "/trader/summarizedmarket/summarizedmarketRoot.jsp?"&#41; <> 0 _
             And _
             &#40;InStr&#40;iDeb, szPage, "&amp;isinCode="&#41; <> 0 Or InStr&#40;iDeb, szPage, "&isinCode="&#41; <> 0 Or InStr&#40;iDeb, szPage, "?isinCode="&#41; <> 0&#41;&#41;
        Dim deb As Long
        Dim deb1 As Long
        Dim fin As Long
        Dim szCodeISIN As String
        Dim szNom As String
        Dim szCours As String
        Dim bAmpCourt As Boolean
              
        deb = InStr&#40;iDeb, szPage, "<a href=" + Chr&#40;34&#41; + "/trader/summarizedmarket/summarizedmarketRoot.jsp?"&#41;
        If &#40;deb <> 0&#41; Then
          iDeb = deb + Len&#40;"<a href=" + Chr&#40;34&#41; + "/trader/summarizedmarket/summarizedmarketRoot.jsp?"&#41; - 1
        End If
        bAmpCourt = False
        deb = InStr&#40;iDeb, szPage, "&amp;isinCode="&#41;
        If deb = 0 Then
          deb = InStr&#40;iDeb, szPage, "&isinCode="&#41;
          bAmpCourt = True
        End If
        If deb = 0 Then
          deb = InStr&#40;iDeb, szPage, "?isinCode="&#41;
          bAmpCourt = True
        End If
        If &#40;deb <> 0&#41; Then
          ' Code ISIN
          If bAmpCourt = True Then deb = deb + Len&#40;"&isinCode="&#41; Else deb = deb + Len&#40;"&amp;isinCode="&#41;
          'fin = InStr&#40;deb, szPage, Chr&#40;34&#41; + ">"&#41;
          fin = deb + 12
          szCodeISIN = Mid$&#40;szPage, deb, fin - deb&#41;
          Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, iColonne&#41;.Value = szCodeISIN
          iColonne = iColonne + 1
          iDeb = fin
          ' Nom
          deb = InStr&#40;iDeb, szPage, ">"&#41;
          deb = deb + 1
          fin = InStr&#40;deb, szPage, "</a>"&#41;
          szNom = Mid$&#40;szPage, deb, fin - deb&#41;
          Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, iColonne&#41;.Value = szNom
          iColonne = iColonne + 1
          iDeb = fin
          ' Cours
          deb = InStr&#40;iDeb, szPage, "class=" + Chr&#40;34&#41; + "tableValueNumRight" + Chr&#40;34&#41; + ">"&#41;
          If deb <> 0 Then
            deb = deb + Len&#40;"class=" + Chr&#40;34&#41; + "tableValueNumRight" + Chr&#40;34&#41; + ">"&#41;
          End If
          deb1 = InStr&#40;deb, szPage, "<a class=" + Chr&#40;34&#41; + "fc1" + Chr&#40;34&#41; + " title="&#41;
          If deb1 <> 0 Then
            deb1 = deb1 + Len&#40;"<a class=" + Chr&#40;34&#41; + "fc1" + Chr&#40;34&#41; + "title="&#41;
            While Mid$&#40;szPage, deb1, 1&#41; <> ">"
              deb1 = deb1 + 1
            Wend
            deb = deb1 + 1
          End If
          szCours = vbNullString
          While &#40;&#40;Mid$&#40;szPage, deb, 1&#41; >= "0" And Mid$&#40;szPage, deb, 1&#41; <= "9"&#41; Or Mid$&#40;szPage, deb, 1&#41; = "."&#41;
            szCours = szCours & Mid$&#40;szPage, deb, 1&#41;
            deb = deb + 1
          Wend
          Worksheets&#40;"Valeurs"&#41;.Cells&#40;iLigne, iColonne&#41;.Value = szCours
          iDeb = fin
          ' Ligne suivante
          iColonne = 1
          iLigne = iLigne + 1
        End If
      Wend
      
    Else
      AfficheErreurInternet &#40;"InternetOpenUrl"&#41;
    End If
      
    ' ----- Et on regarde si il y a une page suivante -----
    Dim SZ_PAGE_INDEX As String
    SZ_PAGE_INDEX = "pageIndex="

    iPageSuivante = -1
    If &#40;InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41;&#41; Then
      While &#40;InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41; And iPageSuivante <= iPage&#41;
        ' On va chercher le nombre situé après "pageIndex="
        i = 0
        iPageSuivante = 0
        While &#40;Mid$&#40;szPage, InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41; + Len&#40;SZ_PAGE_INDEX&#41; + i, 1&#41; >= "0" And Mid$&#40;szPage, InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41; + Len&#40;SZ_PAGE_INDEX&#41; + i, 1&#41; <= "9"&#41;
          iPageSuivante = iPageSuivante * 10 + Mid$&#40;szPage, InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41; + Len&#40;SZ_PAGE_INDEX&#41; + i, 1&#41;
          i = i + 1
        Wend
        'iPageSuivante = Mid$&#40;szPage, InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41; + Len&#40;SZ_PAGE_INDEX&#41;, InStr&#40;InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41;, szPage, "&"&#41; - &#40;InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41; + Len&#40;SZ_PAGE_INDEX&#41;&#41;&#41;
        iDeb = InStr&#40;iDeb, szPage, SZ_PAGE_INDEX&#41; + Len&#40;SZ_PAGE_INDEX&#41; + i
      Wend
      If iPageSuivante <= iPage Then iPageSuivante = -1          ' Au cas où...
    End If
      
      
    ' ----- On ferme la connexion -----
    InternetCloseHandle &#40;hInternetSession&#41;
    
  Else
    AfficheErreur &#40;"InternetOpen"&#41;
  End If
  
  ' On fixe le code retour
  recupereCours = iPageSuivante

End Function

'******************************************************************************
'*                      Fonction AfficheErreur                                *
'******************************************************************************
'*                                                                            *
'* Description &#58; cette fonction recupere l'origine d'une erreur et affiche    *
'*               le message d'erreur correspondant.                           *
'*                                                                            *
'* Entree &#58; szMsg = chaine a afficher dans le message d'erreur.               *
'*                                                                            *
'* Sortie &#58; neant.                                                            *
'*                                                                            *
'* Retour &#58; neant.                                                            *
'*                                                                            *
'******************************************************************************

Sub AfficheErreur&#40;szMsg As String&#41;

  Dim lErr As Long
  Dim sErr As String
  Dim TextLen As Long
  Dim FormatMessageResult As Long
  Dim LangID As Long

  
  LangID = 0&   ' Default language
  sErr = String$&#40;FORMAT_MESSAGE_TEXT_LEN, vbNullChar&#41;
  TextLen = FORMAT_MESSAGE_TEXT_LEN
  
  ' On recupere la derniere erreur
  lErr = GetLastError&#40;&#41;

  ' On recupere le message correspondant a l'erreur
  FormatMessageResult = FormatMessage&#40; _
                        dwFlags&#58;=FORMAT_MESSAGE_FROM_SYSTEM Or _
                                 FORMAT_MESSAGE_IGNORE_INSERTS, _
                        lpSource&#58;=0&, _
                        dwMessageId&#58;=lErr, _
                        dwLanguageId&#58;=LangID, _
                        lpBuffer&#58;=sErr, _
                        nSize&#58;=TextLen, _
                        Arguments&#58;=0&&#41;

  
  If FormatMessageResult <> 0 Then
    sErr = Left$&#40;ErrorText, FormatMessageResult&#41;
  Else
    sErr = "Erreur inconnue !"
  End If
  
  ' On affiche l'erreur
  MsgBox szMsg + vbCrLf + "Erreur " + CStr&#40;lErr&#41; + "&#58; " + ErrorText, vbOKOnly + vbCritical
  
End Sub

'******************************************************************************
'*                      Fonction AfficheErreurInternet                        *
'******************************************************************************
'*                                                                            *
'* Description &#58; cette fonction recupere l'origine d'une erreur de l'API      *
'*               Wininet et affiche le message d'erreur correspondant.        *
'*                                                                            *
'* Entree &#58; szMsg = chaine a afficher dans le message d'erreur.               *
'*                                                                            *
'* Sortie &#58; neant.                                                            *
'*                                                                            *
'* Retour &#58; neant.                                                            *
'*                                                                            *
'******************************************************************************

Sub AfficheErreurInternet&#40;szMsg As String&#41;

  Dim lErr As Long, sErr As String, lenBuf As Long

  ' On recupere la taille du buffer necessaire pour le message d'erreur
  InternetGetLastResponseInfo lErr, sErr, lenBuf
  
  ' On cree le buffer
  sErr = String&#40;lenBuf, 0&#41;
  
  ' On recupere la derniere erreur avec le message correspondant
  InternetGetLastResponseInfo lErr, sErr, lenBuf
  
  ' On affiche l'erreur
  MsgBox szMsg + vbNewLine + "Erreur " + CStr&#40;lErr&#41; + "&#58; " + sErr, vbOKOnly + vbCritical
  
End Sub

Webmaster

Répondre

Qui est en ligne

Utilisateurs parcourant ce forum : Aucun utilisateur enregistré et 2 invités