probleme pour traitement de fichier xml en vba, lenteurs

Version imprimable

Voir 40 message(s) de cette discussion en une page

1 pièce(s) jointe(s)

probleme pour traitement de fichier xml en vba, lenteurs

Bonjour,
voici mon pbm :
je dois importer plusieurs fichiers xml, ( selecetion des valeurs pour les balises voules puis mise en forme dans des feuilles excel).
j'arrive à les importer mais le pbm est que le temps de traitement des fichiers pour qu'ils soient importer dans excel est extremement long.
pour indication je suis passer d'une minute pour extraire les données d'un fichier pour les stocker dans une feuille excel à 3 secondes.
mais le pbm est que c tj long plus je rajoute des fichiers + c long.
j'ai tout tenter j'ai meme essayé Xpath, les fonctions de raffraichissment de l'écran mais tj rien.

Est-ce qu'il est possible que le vba bne soit pas adapté au traitement de fichiers XML???

Quelqu'un a-til une idée? pour que le traitement s'effectue plus rapidement.
peut-être j'ai juste oublié une fonction qui va me permettre de gagner du temps.

Ou peut-etre que ce sont les if qui me font perdre du temps????

Je vous envois la fonction qui permet de l'importation( Parseur).

je vous envois des exemples de fichier XML pour voir leurs structures

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
 
 
'************************************************************************************
'********fonction pour l'importation des fichiers XML********************************
'************************************************************************************
 
Sub IMPORT_XML_File_lister(fichier As String)
 
 
 
'Déclaration des  Variables et des objets  DOMXML
 
Dim ParsDoc As MSXML2.DOMDocument
 
Dim ListeEnfants_de_md As MSXML2.IXMLDOMNodeList
Dim ListeEnfants_de_mi As MSXML2.IXMLDOMNodeList
Dim ListeEnfants_de_mv As MSXML2.IXMLDOMNodeList
Dim Liste_md As MSXML2.IXMLDOMNodeList
 
Dim Noeud_mi As MSXML2.IXMLDOMNode
Dim Noeud_mts As MSXML2.IXMLDOMNode
'Dim Noeud_gp As MSXML2.IXMLDOMNode
Dim Noeud_mt As MSXML2.IXMLDOMNode
Dim Noeud_mv As MSXML2.IXMLDOMNode
Dim Noeud_moid As MSXML2.IXMLDOMNode
Dim Noeud_r As MSXML2.IXMLDOMNode
Dim Noeud_md As MSXML2.IXMLDOMNode
 
'**********noeud de la ligne 3***************
'Dim Noeud_line3   As String
'Dim Noeud3 As MSXML2.IXMLDOMDocumentType
'Dim Noeud3 As MSXML2.IXMLDOMNotation
 
'Dim N3 As MSXML2.IXMLDOMNode
'*****************************************
 
 
 
 
 
Dim Enfants_de_md As MSXML2.IXMLDOMNode
Dim Enfants_de_mi As MSXML2.IXMLDOMNode
Dim Enfants_de_mv As MSXML2.IXMLDOMNode
 
 
Dim racine_mdc As MSXML2.IXMLDOMNode
 
Dim Objet_Erreur As MSXML2.IXMLDOMParseError
 
Dim intI As Integer, intK, intL, intR, intMT
 
Dim date_mts As String, date_ok
 
Dim Nom_moid As String
'Dim file_xml As String
Dim objet_node As String
Dim data As String
 
'permet de ne pas voir se qui se passe
Application.ScreenUpdating = False
Application.DisplayAlerts = False
 
 
 
'Pour nettoyer les cellules à chaque renouvellement du programme
'Worksheets("IMPORT_XML").Activate
'Cells.ClearContents
 
 
'file_xml = Worksheets("Sheet3").Cells(15, 5).Value
' mettre en commentaire la ligne du dessus, puis mettre en argument de la fonction.
 
 
 
 
'Initialisation du Parseur
'la fonction permet de faire la référence entre la variable et le DOC_XML
Set ParsDoc = New MSXML2.DOMDocument
 
 
 
 
 
'Chargement du Document de manière synchrone
ParsDoc.async = False
 
 
 'pour que le fichier xml soit charger correctement
 'on  définit qu'il ne va pas valider la structure des données
 ' mettre le DTD dans le même répertoire que les fichiers XML.
 ParsDoc.validateOnParse = False
 
'on charge le document en mémoire
 
'***********************pour ne pas avoir le msgbox***************
ParsDoc.Load (fichier)
'*****************************************************************
 
 
'If ParsDoc.Load(fichier) Then
 
        'MsgBox "Document XML correctement chargé"
   ' Else
 
'****************************supression de la ligne 3 des XML Files*************************
'MsgBox "Erreur de lecture du document XML"
 
'Dim line3 As String
'Dim nbcaracline3 As Long
'Dim remplace As String
'Dim l3 As String
 
 
 
 
 '********************************TRAITEMENT DU FICHIER XML*********************************
 
 Set racine_mdc = ParsDoc.documentElement
 
 
 For Each Noeud_md In racine_mdc.childNodes
 
  If Noeud_md.nodeName = "md" Then
 
 Set ListeEnfants_de_md = Noeud_md.childNodes
 
 
            For Each Noeud_mi In ListeEnfants_de_md
            If Noeud_mi.nodeName = "mi" Then
            '*******************************Création d'une nouvelle feuille******************
            Worksheets.Add After:=Worksheets("IMPORT_XML")
           '****************************************************************************
           ActiveSheet.Cells(4, 1) = "Measurement Times"
           ActiveSheet.Cells(4, 2) = "Suspect values"
 
            ActiveSheet.Cells(4, 3) = "MOID"
            ActiveSheet.Cells(4, 4) = "COMPTEURS"
 
           Range("A4").Font.Bold = True
           Range("B4").Font.Bold = True
           Range("B4").Font.ColorIndex = 3
           Range("C4").Font.Bold = True
           Range("D4").Font.Bold = True
 
 intI = 7
 intK = 4
 intL = 7
 intR = 4
 intMT = 5
 
 'intrr = 6
 
 
 
 
 
 
            Set ListeEnfants_de_mi = Noeud_mi.childNodes
 
                    For Each Enfants_de_mi In ListeEnfants_de_mi
            'je peux incrémenter intR ici
            'intR = 3
                        If Enfants_de_mi.nodeName = "mts" Then
                        'ActiveSheet.Cells(intI, 1).Value = Enfants_de_mi.nodeTypedValue
                        date_mts = Enfants_de_mi.nodeTypedValue
                        date_ok = Mid(date_mts, 1, 8) + " " + Mid(date_mts, 9, 2) + "h" + Mid(date_mts, 11, 2) + "mn"
                        ActiveSheet.Cells(intI, 1).Value = date_ok
 
                        End If
 
                        If Enfants_de_mi.nodeName = "mt" Then
                         ActiveSheet.Cells(intMT, intK).Value = Enfants_de_mi.nodeTypedValue
                        intK = intK + 1
                        End If
 
                    'mettre en commentaire la fonction du dessous me fait gagner 5 sec/feuille xml
                      'ActiveSheet.Columns.AutoFit
 
                                If Enfants_de_mi.nodeName = "mv" Then
 
                                Set Noeud_mv = Enfants_de_mi
 
                                Set ListeEnfants_de_mv = Noeud_mv.childNodes
 
                               '******************************************
 
                                    For Each Enfants_de_mv In ListeEnfants_de_mv
 
                                            If Enfants_de_mv.nodeName = "moid" Then
                                             ActiveSheet.Cells(intL, 3).Value = Enfants_de_mv.nodeTypedValue
                                             'intL = intL + 4
                                             intL = intL + 1
 
                                            End If
 
                                            If Enfants_de_mv.nodeName = "r" Then
                                            'ActiveSheet.Cells(intL - 4, intR).Value = Enfants_de_mv.nodeTypedValue
                                            ActiveSheet.Cells(intL - 1, intR).Value = Enfants_de_mv.nodeTypedValue
                                            intR = intR + 1
                                            End If
 
                                    '**************balise indiquant un fichier faux************
                                    If Enfants_de_mv.nodeName = "sf" Then
                                    'ActiveSheet.Cells(intL - 4, 1).Value = Enfants_de_mv.nodeTypedValue
                                    ActiveSheet.Cells(intL - 1, 2).Value = Enfants_de_mv.nodeTypedValue
                                    Cells(intL - 1, 2).Font.ColorIndex = 3
                                    'Rows(intL).Interior.Color = 3
 
                                    End If
                                    '****************************************************************
                                'mettre en commentaire la fonction du dessous me fait gagner 5 sec/feuille xml
                                   'ActiveSheet.Columns.AutoFit
 
                                    Next Enfants_de_mv
 
                                    '**********on reset  intR sur la ligne du dessous***********
                                    intR = 4
                                    '***************************************************************
                                End If
 
                    'pb quand on a fini la boucle dans les noeudenfant_mv on reste toujours sur le meme noeud_mi
                    Next Enfants_de_mi
 
                    intMT = intMT + 1
 
            End If
            Next Noeud_mi
 
 
    End If
 
    '*************test 1 du moid pour créer les feuilles avec le moname****************
 
Set ParsDoc = Nothing
 
'Set racine_mdc = Nothing
'Set ListeEnfants_de_md = Nothing
'Set ListeEnfants_de_mi = Nothing
'Set ListeEnfants_de_mv = Nothing
'Set Liste_md = Nothing
'Set Enfants_de_md = Nothing
'Set Enfants_de_mi = Nothing
'Set Enfants_de_mv = Nothing
 
'Set Objet_Erreur = Nothing
 
'Set Noeud_md = Nothing
'Set Noeud_mi = Nothing
'Set Noeud_mts = Nothing
'Set Noeud_gp = Nothing
'Set Noeud_mt = Nothing
'Set Noeud_mv = Nothing
'Set Noeud_moid = Nothing
'Set Noeud_r = Nothing
 
 Next Noeud_md
 
 '******************test 2 du moid pour créer les feuilles avec le moname**************
 
 
 
'********************************FIN TRAITEMENT FICHIER XML*****************************
 
'****************Fonctions permettant de décharger les objets instanciés****************
 
 
 
 
 
'****************normalement pour vider la memoire des dom xml c'est ici
' j'ai modifié pour l'optim
 
 
'Set Noeud_line3 = Nothing
 
' on reactive la méthode
'Application.ScreenUpdating = True
Application.DisplayAlerts = True
 
End Sub

04/09/2008, 17h12
Godzestla
Salut,

j'ai juste survolé, car je ne connais rien au xml.

Ton code peux déjà tourné plus vite si tu remplaces certains if par select

Ex :
Code:

1 2 3 4 5 6 7 8 If Enfants_de_mi.nodeName = "mts" Then .. Endif If Enfants_de_mi.nodeName = "mt" Then .. Endif
Mieux vaut :
Code:

1 2 3 4 5 Select case Enfant_de_mi.nodeName case "mts" case "mt" end select
Avec select le test s'arrete au premier matching, donc moins de test.
Mais idéalement, il faut placer les tests dans l'ordre décroissant de probabilité.

Bon amusement.

Bonjour, j'ai finalement changé le code
et j'obtient de moins bonne performance.

j'ai tester les deux codes en important 1 fichiers XML

La méthode avec le If me donne des résultats en 67 sec celle avec le case me donne des reslutats en 83 sec.

voici le code avec la méthode select case

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
 
 
 Set racine_mdc = ParsDoc.documentElement
 
 
 For Each Noeud_md In racine_mdc.childNodes
 
  '***If Noeud_md.nodeName = "md" Then
 
  Select Case Noeud_md.nodeName
                Case "md"
 
 Set ListeEnfants_de_md = Noeud_md.childNodes
 
 
            For Each Noeud_mi In ListeEnfants_de_md
            '***If Noeud_mi.nodeName = "mi" Then
                Select Case Noeud_mi.nodeName
                        Case "mi"
            '*******************************Création d'une nouvelle feuille******************
            Worksheets.Add After:=Worksheets("IMPORT_XML")
           '****************************************************************************
           ActiveSheet.Cells(4, 1) = "Measurement Times"
           ActiveSheet.Cells(4, 2) = "Suspect values"
 
            ActiveSheet.Cells(4, 3) = "MOID"
            ActiveSheet.Cells(4, 4) = "COMPTEURS"
 
           Range("A4").Font.Bold = True
           Range("B4").Font.Bold = True
           Range("B4").Font.ColorIndex = 3
           Range("C4").Font.Bold = True
           Range("D4").Font.Bold = True
 
 intI = 7
 intK = 4
 intL = 7
 intR = 4
 intMT = 5
 
 'intrr = 6
 
             Set ListeEnfants_de_mi = Noeud_mi.childNodes
 
                    For Each Enfants_de_mi In ListeEnfants_de_mi
           ''' 'je peux incrémenter intR ici
            '''intR = 3
                        'If Enfants_de_mi.nodeName = "mts" Then
 
                        'date_mts = Enfants_de_mi.nodeTypedValue
                        'date_ok = Mid(date_mts, 1, 8) + " " + Mid(date_mts, 9, 2) + "h" + Mid(date_mts, 11, 2) + "mn"
                        'ActiveSheet.Cells(intI, 1).Value = date_ok
 
                        'End If
 
                       '***********partie  avec select***************
 
                    Select Case Enfants_de_mi.nodeName
 
                        Case "mts"
                                date_mts = Enfants_de_mi.nodeTypedValue
                                date_ok = Mid(date_mts, 1, 8) + " " + Mid(date_mts, 9, 2) + "h" + Mid(date_mts, 11, 2) + "mn"
                                ActiveSheet.Cells(intI, 1).Value = date_ok
 
                        Case "mt"
                            ActiveSheet.Cells(intMT, intK).Value = Enfants_de_mi.nodeTypedValue
                            intK = intK + 1
                     End Select
 
 
                        '*********************************************
 
 
                       ' If Enfants_de_mi.nodeName = "mt" Then
                       '  ActiveSheet.Cells(intMT, intK).Value = Enfants_de_mi.nodeTypedValue
                       ' intK = intK + 1
                      '  End If
 
                    'mettre en commentaire la fonction du dessous me fait gagner 5 sec/feuille xml
                      'ActiveSheet.Columns.AutoFit
 
                                '***If Enfants_de_mi.nodeName = "mv" Then
 
                                Select Case Enfants_de_mi.nodeName
 
                                            Case "mv"
 
                                Set Noeud_mv = Enfants_de_mi
 
                                Set ListeEnfants_de_mv = Noeud_mv.childNodes
 
                               '******************************************
 
                                    For Each Enfants_de_mv In ListeEnfants_de_mv
 
                                            '***If Enfants_de_mv.nodeName = "moid" Then
                                             '****ActiveSheet.Cells(intL, 3).Value = Enfants_de_mv.nodeTypedValue
                                             '***intL = intL + 1
                                             '****End If
 
                                             Select Case Enfants_de_mv.nodeName
 
                                                Case "moid"
                                                    ActiveSheet.Cells(intL, 3).Value = Enfants_de_mv.nodeTypedValue
                                                    intL = intL + 1
 
 
                                            '***If Enfants_de_mv.nodeName = "r" Then
                                            '***ActiveSheet.Cells(intL - 1, intR).Value = Enfants_de_mv.nodeTypedValue
                                            '***intR = intR + 1
                                            '***End If
 
                                                Case "r"
                                                    ActiveSheet.Cells(intL - 1, intR).Value = Enfants_de_mv.nodeTypedValue
                                                    intR = intR + 1
 
 
 
                                    '**************balise indiquant un fichier faux************
                                    '***If Enfants_de_mv.nodeName = "sf" Then
                                    '***ActiveSheet.Cells(intL - 1, 2).Value = Enfants_de_mv.nodeTypedValue
                                    '***Cells(intL - 1, 2).Font.ColorIndex = 3
                                    '***End If
                                    '****************************************************************
                                                Case "sf"
                                                    ActiveSheet.Cells(intL - 1, 2).Value = Enfants_de_mv.nodeTypedValue
                                                    Cells(intL - 1, 2).Font.ColorIndex = 3
 
                                    'mettre en commentaire la fonction du dessous me fait gagner 5 sec/feuille xml si desactivée
                                   'ActiveSheet.Columns.AutoFit
 
                                             End Select
 
                                    Next Enfants_de_mv
 
                                    '**********on reset  intR sur la ligne du dessous***********
                                    intR = 4
                                    '***************************************************************
                                '****End If
                            End Select
                    'pb quand on a fini la boucle dans les noeudenfant_mv on reste toujours sur le meme noeud_mi
                    Next Enfants_de_mi
 
 
 
                    intMT = intMT + 1
 
           '**** End If
           '***** le END IF du dessus c'est pour le noeud mi
                    End Select
            Next Noeud_mi
 
 
    '*** End If
    '*********pour le End If du dessus c'set pour le Noeud md
 
    '*************test 1 du moid pour créer les feuilles avec le moname****************
 
 
 
'Set racine_mdc = Nothing
'Set ListeEnfants_de_md = Nothing
'Set ListeEnfants_de_mi = Nothing
'Set ListeEnfants_de_mv = Nothing
'Set Liste_md = Nothing
'Set Enfants_de_md = Nothing
'Set Enfants_de_mi = Nothing
'Set Enfants_de_mv = Nothing
 
'Set Objet_Erreur = Nothing
 
'Set Noeud_md = Nothing
'Set Noeud_mi = Nothing
'Set Noeud_mts = Nothing
'Set Noeud_gp = Nothing
'Set Noeud_mt = Nothing
'Set Noeud_mv = Nothing
'Set Noeud_moid = Nothing
'Set Noeud_r = Nothing
 
     End Select
 Next Noeud_md
 
 
 Set ParsDoc = Nothing
 
 '******************test 2 du moid pour créer les feuilles avec le moname**************
 
 
 
'********************************FIN TRAITEMENT FICHIER XML*****************************
 
'****************Fonctions permettant de décharger les objets instanciés****************
 
 
'****************normalement pour vider la memoire des dom xml c'est ici
' j'ai modifié pour l'optim
 
 
'Set Noeud_line3 = Nothing
 
' on reactive la méthode
'Application.ScreenUpdating = True
Application.DisplayAlerts = True
 
End Sub

Je poursuit mes recherches mais si quelqu'un a une piste pour moi je suis preneur.

05/09/2008, 11h51
Godzestla

Si meme le Select est pire que le If, le monde va mal. :aie:

Sans déconner, si ton code fait des mises à jour nombreuses sur tes cellules et des réaffichage, tu peux aussi gagner du temps en bloquant le réaffichage et le recalcul pendant ta routine.

Mais bon, ce ne sera pas le Pérou.
05/09/2008, 13h22
newcodeur

Bloquer le ré affichage et le recalcule ????

comment on fait je c pas si je le fait deja avec les methodes suivantes :

Application.DisplayAlerts

Application.ScreenUpdating

Application.StatusBar

qui sont toutes false .

est-ce de cela dont tu voulé parler???
05/09/2008, 13h33
Godzestla
Oui, absolument

Et aussi ceci :
Code:

1 2 3 4 With Application .Calculation = xlManual End With
et après remettre à xlAutomatic
05/09/2008, 13h58
newcodeur

excuse-moi mais je dois inséré ou la procédure ????

Au debut de ton code ceci :

Code:

1
2
3
4
 
    With Application
        .Calculation = xlManual
    End With

a la fin le contraire :

Code:

1
2
3
4
 
    With Application
        .Calculation = xlAutomatic
    End With

05/09/2008, 14h16
newcodeur

Merci j'ai essayé mais sa ne donne toujours rien ...

:oops:

peut etre est-ce du au fait que les fichiers XML sont trop volumineux (546ko) ou c'est le vba qui n'est pas adapté ou tout simplement mon code????
8O

bon je poursuis mes investigations...
Merci quand même.:king:
08/09/2008, 11h10
newcodeur

Et-il possible a partir de vba d'utiliser un autre langage ( java , C++) pour faire l'importation , c'est a dire créer un module qui n'utilise pas le vba mais un autre langage de programation
08/09/2008, 14h10
neupont

Salut,
moi j'ai déjà lancé un programme java via VBA, mais c'est resté du bricolage : le VBA mettait ses paramètres dans un fichier texte, lançait le java qui allait lire ce fichier texte, faisait ses calculs puis mettait les résultats dans un autre fichier texte pour que VBA reprenne la main :aie:

Ceci dit j'avais obtenu des gains de temps spectaculaires (genre 30 fois plus rapide au minimum), mais mon java remplaçait du code VBA tapé par moi (des dizaines de millions d'itérations sur quelques boucles et conditions). Du code interprété donc, et non des fonctions déjà compilées.

Si ce sont les fonctions XML (fournies par VBA) que tu utilises qui prennent le plus de temps, et non tes boucles, tu ne vas probablement pas gagner grand-chose. A voir quoi.

Code:

1
2
3
4
5
 If Enfants_de_mv.nodeName = "moid" Then
 ActiveSheet.Cells(intL, 3).Value = Enfants_de_mv.nodeTypedValue
 'intL = intL + 4
intL = intL + 1
End If

ce type de code ralentis enormement le programme essaies pour utiliser un tabeaux comme ça tu gagne enormement de temps regarder sur mon examlpe si j'ai ramplacer le traditionnel code

Code:

ListBox1.AddItem cache(h)

par

Code:

1
2
3
4
ReDim cache(Coll.Count - 1, 0): j = 0
For Each elem In Coll
cache(j, 0) = elem: j = j + 1
Next: ListBox1.list = cache

essayer de d'utiliser ce code avec un userform

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
Option Explicit
Sub v(str As String)
With Application
        .ScreenUpdating = False
       .EnableEvents = False
End With
Dim elem As Variant
Dim Coll As New Collection
Dim h, inc, j As Long
Dim cache() As String
 
 
inc = 0
 
 
cache = Split(str, "<")
For Each elem In cache
If (InStr(1, "!?/", Mid$(elem, 1, 1)) > 0) Then
inc = inc - 1
Else
Coll.Add elem
 
inc = inc + 1
End If
 
Next
ReDim cache(Coll.Count - 1, 0): j = 0
For Each elem In Coll
cache(j, 0) = elem: j = j + 1
Next: ListBox1.list = cache
 
 
With Application
      .ScreenUpdating = True
      .EnableEvents = True
 
End With
 
 
End Sub
' Cette fonction lit le contenu du fichier szFileName et retourne
' ce contenu. En cas d'erreur, elle retourne une chaîne vide et
' renseigne le code d'erreur et la descritpion de l'erreur
'
Private Function ReadFileToBuffer(ByVal szFileName As String, _
                                 ByRef errCode As Integer, _
                                 ByRef errString As String) As String
    Dim f As Integer
    Dim Buffer As String
 
    ' trappe les erreurs
    On Error GoTo ReadFileToBuffer_ERR
 
    ' Ouverture du fichier en 'Binary'
    f = FreeFile
    Open szFileName For Binary As #f
        ' préallocation d'un buffer à la taille du fichier
        Buffer = Space$(LOF(f))
        ' lecture complète du fichier
        Get #f, , Buffer
    Close #f
    ReadFileToBuffer = Buffer
ReadFileToBuffer_END:
    Exit Function
 
ReadFileToBuffer_ERR:
    ' Gestion d'erreur
    ReadFileToBuffer = ""
    errCode = Err.Number
    errString = Err.Description
    Resume ReadFileToBuffer_END
End Function
 
Private Sub UserForm_Initialize()
 
 
    Dim fileName As String
    Dim errCode As Integer
    Dim errString As String
    Dim fileContent As String
    Dim t() As String
    Dim nbLines As Long
fileName = "C:\A.xml"
  fileContent = ReadFileToBuffer(fileName, errCode, errString)
    If errCode = 0 Then
Call v(fileContent)
        'MsgBox "Nombre de Lignes : " & fileContent
    Else
        ' Erreur rencontrée, affichage
        MsgBox "Erreur lors de la lecture. Code : " & errCode & ". Description : " & errString
    End If
End Sub

09/09/2008, 14h14
newcodeur

Merci pour ta réponse je vais tester sa et te donner de mes nouvelles

Au passage DelphiDelphi je suis un débutant en programmation d'ou mon nom :

NEWCODEUR:king::king::king::king::king::king:

Mais ne tinkiète pas j'arrive a grand pas.....

:evilred::evilred::evilred::evilred::evilred::evilred:

:yaisse2:
09/09/2008, 19h12
Montor

Citation:

Envoyé par neupont

Salut,
moi j'ai déjà lancé un programme java via VBA, mais c'est resté du bricolage : le VBA mettait ses paramètres dans un fichier texte, lançait le java qui allait lire ce fichier texte, faisait ses calculs puis mettait les résultats dans un autre fichier texte pour que VBA reprenne la main :aie:

Ceci dit j'avais obtenu des gains de temps spectaculaires (genre 30 fois plus rapide au minimum), mais mon java remplaçait du code VBA tapé par moi (des dizaines de millions d'itérations sur quelques boucles et conditions). Du code interprété donc, et non des fonctions déjà compilées.

Si ce sont les fonctions XML (fournies par VBA) que tu utilises qui prennent le plus de temps, et non tes boucles, tu ne vas probablement pas gagner grand-chose. A voir quoi.

Oui par fois il est mieux utiliser une application externe compile avec une autre langage moi je utilise le delphi plus performant :king::king::king:
voici un example http://www.developpez.net/forums/d57...3/#post3428148
10/09/2008, 10h46
newcodeur

daccord on peut utiliser le delphi je vais jetter un oeil
Merci
11/09/2008, 11h27
newcodeur

Bonjour tout le monde !!!!

après avoir checher à gauche et a droite je pense avoir trouvé la solution, j'ai développé avec un ami une fonction qui me charge m'ilmporte etr m'écris dans des feuilles Excell le contenu voulu du fichier XML.
Et ce en un temp record moins de 10 seconde !!!!!!:king::king::king::king:

la fonction a été développé en C# .
je voudrais savoir savoir si il est possible de lancer l'application a partir de Excel car tout le reste de mon programme et codé en VBA.
Et actuellement je dois executé l'application .exe mais mon but est de tout faire a partir d'excel

Merci de votre aide

Il y a la fonction Shell pour exécuter un programme externe, mais l'inconvénient c'est que le code VBA continue à se dérouler en parallèle, pas si terrible donc.

Sinon il y a le code suivant qui présente l'avantage d'attendre que l'application appelée se ferme avant que VBA reprenne la main. Je l'ai essayé, ça marche terrible :king:

C'est pas utile de chercher à comprendre le code qui est plutôt velu (en tout cas trop pour moi). Il suffit de copier les fonctions dans un module et d'appeler la fonction ShellPatient comme on appellerait Shell.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
 
Private Type STARTUPINFO
         cb As Long
         lpReserved As String
         lpDesktop As String
         lpTitle As String
         dwX As Long
         dwY As Long
         dwXSize As Long
         dwYSize As Long
         dwXCountChars As Long
         dwYCountChars As Long
         dwFillAttribute As Long
         dwFlags As Long
         wShowWindow As Integer
         cbReserved2 As Integer
         lpReserved2 As Long
         hStdInput As Long
         hStdOutput As Long
         hStdError As Long
End Type
 
Private Type PROCESS_INFORMATION
         hProcess As Long
         hThread As Long
         dwProcessID As Long
         dwThreadID As Long
End Type
 
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal _
         hHandle As Long, ByVal dwMilliseconds As Long) As Long
 
Private Declare Function CreateProcessA Lib "kernel32" (ByVal _
         lpApplicationName As Long, ByVal lpCommandLine As String, ByVal _
         lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
         ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
         ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, _
         lpStartupInfo As STARTUPINFO, lpProcessInformation As _
         PROCESS_INFORMATION) As Long
 
Private Declare Function CloseHandle Lib "kernel32" (ByVal _
         hObject As Long) As Long
 
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&
 
Private Declare Function OpenProcess Lib "kernel32" _
    (ByVal dwDesiredAccess As Long, _
    ByVal bInheritHandle As Long, _
    ByVal dwProcessID As Long) As Long
 
Private Declare Function GetExitCodeProcess Lib "kernel32" _
    (ByVal hProcess As Long, _
    lpExitCode As Long) As Long
 
 
Public Sub ShellPatient(vCommand As String)
Dim proc As PROCESS_INFORMATION
Dim start As STARTUPINFO
Dim ReturnValue As Integer
 
 
ReturnValue = CreateProcessA(0&, vCommand, 0&, 0&, 1&, NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)
Do
    ReturnValue = WaitForSingleObject(proc.hProcess, 0)
    DoEvents
    DoEvents
Loop Until ReturnValue <> 258
 
ReturnValue = CloseHandle(proc.hProcess)
 
End Sub

ça s'utilise comme ça, très simplement (et cet exemple est la seule chose que tu aies vraiment besoin de comprendre pour l'utiliser) :

ShellPatient "C:\winnt\system32\cmd.exe"

L'essayer, c'est l'adopter :mouarf:

Excuse moi neutpont ton code ma l'air très intérressant mais je n'arrive pas à le faire fonctionner
j'ai créer un module et pense avoir suivi tes instructions mais il ne se passe rien.

j'apel la fonction shellpatient mais il n'y à rien ????
8O8O8O8O8O8O

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
 
 
 
Private Type STARTUPINFO
         cb As Long
         lpReserved As String
         lpDesktop As String
         lpTitle As String
         dwX As Long
         dwY As Long
         dwXSize As Long
         dwYSize As Long
         dwXCountChars As Long
         dwYCountChars As Long
         dwFillAttribute As Long
         dwFlags As Long
         wShowWindow As Integer
         cbReserved2 As Integer
         lpReserved2 As Long
         hStdInput As Long
         hStdOutput As Long
         hStdError As Long
End Type
 
Private Type PROCESS_INFORMATION
         hProcess As Long
         hThread As Long
         dwProcessID As Long
         dwThreadID As Long
End Type
 
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal _
         hHandle As Long, ByVal dwMilliseconds As Long) As Long
 
Private Declare Function CreateProcessA Lib "kernel32" (ByVal _
         lpApplicationName As Long, ByVal lpCommandLine As String, ByVal _
         lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
         ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
         ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, _
         lpStartupInfo As STARTUPINFO, lpProcessInformation As _
         PROCESS_INFORMATION) As Long
 
Private Declare Function CloseHandle Lib "kernel32" (ByVal _
         hObject As Long) As Long
 
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&
 
Private Declare Function OpenProcess Lib "kernel32" _
    (ByVal dwDesiredAccess As Long, _
    ByVal bInheritHandle As Long, _
    ByVal dwProcessID As Long) As Long
 
Private Declare Function GetExitCodeProcess Lib "kernel32" _
    (ByVal hProcess As Long, _
    lpExitCode As Long) As Long
 
 
Public Sub ShellPatient(vCommand As String)
Dim proc As PROCESS_INFORMATION
Dim start As STARTUPINFO
Dim ReturnValue As Integer
 
 
ReturnValue = CreateProcessA(0&, vCommand, 0&, 0&, 1&, NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)
Do
    ReturnValue = WaitForSingleObject(proc.hProcess, 0)
    DoEvents
    DoEvents
Loop Until ReturnValue <> 258
 
ReturnValue = CloseHandle(proc.hProcess)
 
End Sub
 
 
 
 
 
 
Sub IMPORTATION_aplication()
 
Call ShellPatient("C:\winnt\system32\cmd.exe")
 
 
 
 
End Sub

Alors est-ce comme ça qu'il faut procéder???

11/09/2008, 14h01
neupont

Citation:

Envoyé par newcodeur

Alors est-ce comme ça qu'il faut procéder???

Oui.
Sans doute ton répertoire Windows ne s'appelle-t-il pas "winnt" ? :mrgreen:
11/09/2008, 14h06
newcodeur

effectivement je suis sous vista le nom était :

C:\Windows\System32

WAAAAAAAAAAAAAAAAAAAAAAAAAAAA
:yaisse2::yaisse2::yaisse2::yaisse2::yaisse2::yaisse2::yaisse2:

sa fonctionne à merveille merci beaucoup !!!!

Juste uen question c'est toiq qui a fait le code :aie:
:aie::aie::aie::aie::aie::aie:

Voir 40 message(s) de cette discussion en une page