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
|
'**********************************************************************
' File : Form_Appareil et visites
' Module : DémoForum
' DateTime : 26/01/2016
' Reviewed by : Jean-Philippe AMBROSINO
' Code from : Harvi
' Review date : 01/02/2016
' Purpose : http://www.developpez.net/forums/d1565131-nouveau/logiciels/microsoft-office/access/taux-change-ligne-automatisation-access/
'
'**********************************************************************
Option Compare Database
Option Explicit
'Clause SQL d'insertion des lignes
Private Const INSERT_CLAUSE As String = "INSERT INTO DeviseEtTaux (Devise, Taux) VALUES (#1);"
'Clause SQL de suppression des lignes
Private Const DELETE_CLAUSE As String = "DELETE * FROM DeviseEtTaux ;"
'Clause SQL de MAJ des lignes
Private Const UPDATE_CLAUSE As String = "UPDATE DeviseEtTaux SET DeviseEtTaux.Taux = Replace([Taux],'.',',');"
'Adresse HTTP du fichier XML de référence
Private Const XML_EUROFXREF As String = "http://www.ecb.europa.eu/stats/eurofxref/eurofxref-daily.xml"
Public Sub MAJTaux()
Dim oDB As DAO.Database
On Error GoTo L_ErrMAJTaux
'Instanciation de la BDD
Set oDB = CurrentDb()
'On efface la table
oDB.Execute DELETE_CLAUSE, dbFailOnError
'On exécute à la volé, l'ouverture du XML, l'insertion des taux
BrowseXMLDocument XML_EUROFXREF, oDB, INSERT_CLAUSE
'On met à jour la table selon le séparateur de décimales local
If Mid(3.5 / 2, 2, 1) = "," Then
oDB.Execute UPDATE_CLAUSE, dbFailOnError
End If
MsgBox "Mise à jour des taux terminée", vbInformation
'On ferme la BDD
oDB.Close
On Error GoTo 0
L_ExMAJTaux:
Set oDB = Nothing
Exit Sub
L_ErrMAJTaux:
MsgBox Err.Description, 48, Err.Source
Resume L_ExMAJTaux
End Sub
Private Sub BrowseChildNodes(XMLNode As IXMLDOMNode, DB As DAO.Database, ByVal ScriptSQL As String)
Const ELEMENT_NODE As Long = 1
Const ATTRIBUTE_NODE As Long = 2
Const TEXT_NODE As Long = 3
Const CDATA_SECTION_NODE As Long = 4
Const ENTITY_REFERENCE_NODE As Long = 5
Const ENTITY_NODE As Long = 6
Const PROCESSING_INSTRUCTION_NODE As Long = 7
Const COMMENT_NODE As Long = 8
Const DOCUMENT_NODE As Long = 9
Const DOCUMENT_TYPE_NODE As Long = 10
Const DOCUMENT_FRAGMENT_NODE As Long = 11
Const NOTATION_NODE As Long = 12
Dim I As Long
Dim J As Long
Dim Data As String
'Pour chaque noeud
For I = 0 To XMLNode.childNodes.Length - 1
'si le noeud n'est pas de type 3
If XMLNode.childNodes.Item(I).nodeType <> TEXT_NODE Then
'alors Data est vidé
Data = ""
For J = 0 To XMLNode.childNodes.Item(I).Attributes.Length - 1
'A la première passe on obtient la devise, à la seconde le taux
'<Cube currency='USD' rate='1.0920'/>
'Ex : Data='USD', '1.0920',
Data = Data & "'" & XMLNode.childNodes.Item(I).Attributes.Item(J).nodeValue & "', "
Next J
'Si Data contient quelque chose
If Data <> "" Then
'On épure la partie droite de la chaine (donc la virgule et l'espace)
Data = Left(Data, Len(Data) - 2)
'Si la chaine est un tableau avec 2 valeurs
If UBound(Split(Data, ",")) = 1 Then
'Alors on suppose que l'on a les deux valeurs devise et taux...
'Et on les ajoute à la table avec un remplacement du #1 par les deux valeurs
DB.Execute (Replace(ScriptSQL, "#1", Data)), dbFailOnError
End If
End If
End If
'On fait un appel récursif cette même méthode
BrowseChildNodes XMLNode.childNodes(I), DB, ScriptSQL
Next
End Sub
Private Sub BrowseXMLDocument(ByVal XMLFilename As String, DB As DAO.Database, ByVal ScriptSQL As String)
'Objet DOM Document
Dim xmlDoc As DOMDocument
'Objet élément du XML (ici la racine)
Dim xmlRoot As IXMLDOMElement
Dim I As Long
'On créé une instance DOMDoc
Set xmlDoc = New DOMDocument
'En mode synchrone
xmlDoc.async = False
'On charge le fichier
xmlDoc.Load XMLFilename
'On affecte les éléments de la racine à l'objet xmlRoot
Set xmlRoot = xmlDoc.documentElement
'S'il y a des éléments alors on appelle BrowseChildNodes pour remplir la table via la clause INSERT
If Not xmlRoot Is Nothing Then
BrowseChildNodes xmlRoot, DB, ScriptSQL
End If
'On met fin aux objets
Set xmlRoot = Nothing
Set xmlDoc = Nothing
End Sub
'Structure du XML
'----------------
'<?xml version="1.0" encoding="UTF-8"?>
'<gesmes:Envelope xmlns:gesmes="http://www.gesmes.org/xml/2002-08-01" xmlns="http://www.ecb.int/vocabulary/2002-08-01/eurofxref">
' <gesmes:subject>Reference rates</gesmes:subject>
' <gesmes:Sender>
' <gesmes:name>European Central Bank</gesmes:name>
' </gesmes:Sender>
' <Cube>
' <Cube time='2016-01-29'>
' <Cube currency='USD' rate='1.0920'/>
' <Cube currency='JPY' rate='132.25'/>
' <Cube currency='BGN' rate='1.9558'/>
' <Cube currency='CZK' rate='27.026'/> |
Taux de change en ligne et automatisation avec Access
Répondre avec citation
Envoyé par Harvi
Partager