Résolu [vba] Parser un document XML en asynchrone.

[tantal_fr]

Bonjour,

J'ai le code VBA suivant qui me permet d'obtenir une URL à partir d'un fichier xml. Le code fonctionne bien en synchrone, mais excel se bloque le temps de récupérer le ficher xml ; j'essaie donc de faire la même chose en asynchrone en utilisant un gestionnaire d'événements. Voici le code :

Option Explicit


Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private xmlDoc As MSXML2.DOMDocument30

Private Function xmlDoc_onreadystatechange()
    Dim objNodeList As IXMLDOMNodeList
    Dim objNode As IXMLDOMNode
    Dim hwnd As Long
    Dim URL As String

    If (xmlDoc.readyState = 4) Then
            If (xmlDoc.parseError.ErrorCode = 0) Then
                xmlDoc.setProperty "SelectionNamespaces", "xmlns:xsl='http://www.w3.org/1999/XSL/Transform'"
                xmlDoc.setProperty "SelectionLanguage", "XPath"
                        
                Set objNodeList = xmlDoc.DocumentElement.getElementsByTagName("PartFormURL")
    
        
                For Each objNode In objNodeList
                    URL = Left(objNode.Text, Len(objNode.Text) - 9) & "Locale=fr_fr&ViewType=Service&Extend=.html"
                Next objNode
            
                ShellExecute hwnd, "open", URL, "", "", vbNormalFocus
            End If
    End If
End Function

Private Function isValidPart(part As String)
    
    isValidPart = (Left(part, 3) = "std")

End Function

Public Sub OPEN_URL(part As String)    
    xmlDoc.async = True  

    If isValidPart(part) Then
        
         Set xmlDoc = New MSXML2.DOMDocument30
        xmlDoc.Load " http://www.[adresseintranet].com/xmlQuery/xmlQuery?action=ficheArticle&code=" & UCase(Left(part, 13))
        xmlDoc.onreadystatechange = xmlDoc_onreadystatechange
                
    End If

End Sub

Le code fonctionne en mode pas à pas car la requête a le temps de s'exécuter, cependant, en fonctionnement normal xmlDoc.readyState est bien égal à 4 alors que ce n'est pas encore prêt, donc fin de la macro.

 

[tantal_fr]

Bonjour,

J'ai résolu mon problème : il faut mettre une boucle qui traite les événements car le la macros se termine avant la fin du traitement:

Do
   DoEvents
Loop Until xmlDoc.readyState = 4

Voici le code, je l'ai remanié pour trouver le problème et j'ai créé un classe :

Option Explicit

' Variable gobale contennant la ref.
Dim pParts As String

' Déclaration fonction externe pour lancer le navigateur
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

' Déclaration objet xmlDoc avec gestion des évenements
Private WithEvents xmlDoc As MSXML2.DOMDocument30

' Lecture de la propriété Part
Public Property Get Part() As String
 Part = pParts
End Property

' Ecriture de la propriété Part
Public Property Let Part(Value As String)
 pParts = Value
End Property

' Initialisation
Private Sub Class_Initialize()
     Set xmlDoc = New MSXML2.DOMDocument30
    xmlDoc.async = True
End Sub

' Gestion de l'évenement on readystate
Private Sub xmlDoc_onreadystatechange()
    Dim objNodeList As IXMLDOMNodeList
    Dim objNode As IXMLDOMNode
    Dim hwnd As Long
    Dim URL As String
    Debug.Print xmlDoc.readyState
    
    ' Readystate = 4 => le traitement est terminé
    If (xmlDoc.readyState = 4) Then
            If (xmlDoc.parseError.ErrorCode = 0) Then   ' pas d'erreur dans le fichier xml
                xmlDoc.setProperty "SelectionNamespaces", "xmlns:xsl='http://www.w3.org/1999/XSL/Transform'"
                xmlDoc.setProperty "SelectionLanguage", "XPath"
                        
                ' récuperation de l'URL de la fiche article
                Set objNodeList = xmlDoc.DocumentElement.getElementsByTagName("PartFormURL")
                                
                For Each objNode In objNodeList
                    ' mise en forme de l'URL
                    URL = Left(objNode.Text, Len(objNode.Text) - 9) & "PLF&Locale=fr_fr&ViewType=Service&Extend=.html"
                Next objNode
                
                ' lancement navigateur
                ShellExecute hwnd, "open", URL, "", "", vbNormalFocus
            End If
    End If
End Sub

' verification de  la validité de la mise en forme de du code article
Private Function isValidPart(Part As String)
    isValidPart = (Left(Part, 3) = "std")
End Function


Public Sub Open_url()
    If isValidPart(pParts) Then
        ' chargement du du fichier XML
         xmlDoc.Load " http://iww.[obsucation]xmlQuery/xmlQuery?action=ficheArticle&code=" & UCase(Left(pParts, 13))
         
         ' boucle principale pour traiter les evenement excel le temps que le traitement XML soit finis
         Do
            DoEvents
         Loop Until xmlDoc.readyState = 4
    End If
End Sub

Merci à moi et au grand ternet.