Les Web Services pour access [Sources]

[naphta]

Un contribution pour le forum, les Web Services sous access.

Objectif: récupération de données sur une base locale à partir d’un serveur présent sur le Web (sans navigateur) capable de répondre en XML.
Phase 1 on interroge le serveur distant avec ou sans paramètres il répond via un fichier XML .
Phase 2 Récupération du fichier
Phase 3 Intégration dans la base et traitement
On a besoin de la référence shdocvw.dll ou ieframe.dll (à partir de IE7)

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
Function extractionXML(CritereInterro As String) As Boolean
 
'-------------------------------------------------------------
' Auteur : Naphta , 03-11-2005
' Notes :Requête d interrogation XML
'-------------------------------------------------------------
' Paramètre que l'on passe au serveur distant option
'-----------
' CritereInterro (String)
'-------------------------------------------------------------
 
Dim leFichier, RepDestination, URL
Dim xml
Dim ostream
Dim fs
On Error GoTo oror
 
leFichier = "resu.xml"
' ici c'est le répertoire mes documents qui a été choisi
' c'est pour des commerciaux !
 
RepDestination = fGetSpecialFolderLocation(&H5) + "\"
Set fs = CreateObject("Scripting.FileSystemObject")
 
If fs.FileExists(RepDestination & leFichier) Then
    Kill RepDestination & leFichier
End If
 
DoCmd.Hourglass True
 
' l adresse et param ici votre serveur et paramètres
URL = "http://www.votresite.fr/interro/recherche.asp?crit=BB400" + CritereInterro
 
' déclare envoi et pompe le fichier
Set xml = CreateObject("MSXML2.ServerXMLHTTP")
Set ostream = CreateObject("Adodb.Stream")
xml.Open "GET", URL, True
xml.Send
 
'Attendre un peu si pas ready 3 sec de +, à 1 minute on arrête
Dim cpt As Integer
Do Until xml.ReadyState = 4
    xml.waitForResponse 3
    cpt = cpt + 1
    If cpt = 20 Then
        xml.Abort
        MsgBox "C'est trop long, problème avec le serveur ou votre requête, arrêt.", vbCritical, "Attention"
        DoCmd.Hourglass False
        Exit Do
    End If
Loop
 
' puis sauvegarde ici les constantes sont importantes
' vous allez peut être devoir faire d'autre choix
 
Const adTypeText = 2
Const adSaveCreateOverWrite = 2
Const adSaveCreateNotExist = 1
 
ostream.Type = adTypeText
ostream.Charset = "iso-8859-1"
ostream.Open
ostream.WriteText xml.ResponseText
ostream.SaveToFile RepDestination & leFichier, adSaveCreateOverWrite
ostream.Close
Set ostream = Nothing
Set xml = Nothing
 
' La procédure import XML est facile du style Application.ImportXML avec access à partir de 2003 sinon ..
' faut importer à la balise bon courrage
' La procédure d'import répond OK alors tout est OK
If importleXML = True Then
    extractionXML = True
End If
 
 
degage:
DoCmd.Hourglass False
Exit Function
oror:
MsgBox "Une erreur lors de la tentative de demande des données.", vbCritical, "Attention"
Resume degage
End Function