Discussion :

[philben]

bonjour jmaulin et merci pour votre message.

une solution ici pour le géocodage inversé.

Bonne continuation,

Philippe

[ronpub]

Je me posais la question suivante:
Quelle serait la meilleurs stratégie pour intégrer une carte google maps avec des POI dans un état?
C'est très beau une carte sur l'écran mais un rapport avec une carte ça permet de mieux synthétiser quand même surtout quand on est offline.

[philben]

bonjour,

je ne connais pas d'autre solution que d'imprimer le formulaire de la carte ou d'utiliser des API pour créer une image de la carte puis de la charger dans un état.

Mes recherches sur le web ne m'ont pas donné de solutions "propres".

Cordialement,

Philippe

[ronpub]

je ne connais pas d'autre solution que d'imprimer le formulaire de la carte ou d'utiliser des API pour créer une image de la carte puis de la charger dans un état.

Mes recherches sur le web ne m'ont pas donné de solutions "propres".

C'est ce que je craignais mais je n'en étais pas sure car je pensais quand même qu'en 2010-2011, il était possible d'avoir une carte dans un état de façon simple.
Merci.

[ronpub]

bonjour,

je ne connais pas d'autre solution que d'imprimer le formulaire de la carte ou d'utiliser des API pour créer une image de la carte puis de la charger dans un état.

Mes recherches sur le web ne m'ont pas donné de solutions "propres".

Cordialement,

Philippe

Je me suis lancé finalement.
J'ai utilisé l'API GDIplus pour créer tout les PNG nécessaires. Ils ont comme nom l'Id de la table. Ensuite les les fait afficher dans un controle image du rapport.
Je mettrais posterai ici ce que j'ai fais. C'est pas tres propres (de mon niveau quoi).
Le plus dur aura été de trouver des sources pour manipuler GDIplus.

[philben]

Bonjour,

Dans un post précédent, j'ai écrit :

je ne connais pas d'autre solution que d'imprimer le formulaire de la carte ou d'utiliser des API pour créer une image de la carte puis de la charger dans un état.

En effet, avec les <Static maps API>, on peut facilement enregistrer sur disque une image (format png par défaut) de la carte puis l'intégrer dans un rapport Access ou l'imprimer directement.

Exemple concret s'appuyant sur une fonction du tuto d'Arkham46 comme base de travail (URL, type et chemin de l'image enregistrée sont modifiés) :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
 
Function DownloadHTTP()
   Dim oWinHTTP As WinHttp.WinHttpRequest
   Dim fic As Integer
   Dim buffer() As Byte
   Set oWinHTTP = New WinHttp.WinHttpRequest
   oWinHTTP.Open "POST", "http://maps.googleapis.com/maps/api/staticmap?center=Brooklyn+Bridge,New+York,NY&zoom=14&size=512x512&maptype=roadmap&markers=color:blue%7Clabel:S%7C40.702147,-74.015794&markers=color:green%7Clabel:G%7C40.711614,-74.012318&markers=color:red%7Ccolor:red%7Clabel:C%7C40.718217,-73.998284&sensor=false", False
   oWinHTTP.send
   If oWinHTTP.Status = 200 Then
      fic = FreeFile
      Open CurrentProject.Path & "\monimage.png" For Binary As #fic
      buffer = oWinHTTP.responseBody
      Put #fic, , buffer
      Erase buffer
      Close #fic
   End If
End Function

En travaillant sur les nombreux paramètres possibles de la carte à générer, on peut arriver à un résultat pratiquement wysiwyg.

Principales limitations : 1000 requêtes/jour et longueur maxi de l'URL : 2048 caractères. Voir lien pour plus de détails.

Philippe

[Shades]

Bonjour à tous,

je travail sur une appli qui à besoin justement d'une géolocalisation, j'ai bien réussis à afficher le plan dans le formulaire mais j'ai du mal à adapter cela pour afficher le plan en relation avec les données de mon formulaire sans avoir à cliquer sur un bouton, juste avec des requery au fur et à mesure que l'on remplis les différents champs.

En choisissant un département et une ville cela donne automatiquement la valeur longitude, latitude dans des champs [seLongitude] [seLatitude] [seCodePostal] et en avançant dans le formulaire on renseigne l'adresse exacte [zdtAdresse], jusqu'à là ça va bien et cela fonctionne, mais je ne sais pas comment intégrer ces données pour l'affichage correct du plan. Avec la complication que l'adresse peut être multiple comme, adresse 1, adresse 2 adresse 3 ...

De plus j'aimerais que ce plan généré puisse être joint à un état qui devra être envoyé par la suite soit par courriel au format pdf soit faxer.

Vous l'aurez compris, je suis juste perdu dans tout cela, votre aide sera plus que le bienvenue et je vous en remerci par avance.

Cordialement,
Sylvain

[philben]

bonjour,

...adresse 1, adresse 2 adresse 3

en interceptant le current record de tes adresses ?
Pourquoi autant de requery ?
Je pense que ce sont plutot des questions à mettre dans le sous-forum IHM.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
De plus j'aimerais que ce plan généré puisse être joint à un état qui devra être envoyé par la suite soit par courriel au format pdf soit faxer.

je vais t'aider un peu sur cette partie là en fignolant la fonction du post précédent avec une base exemple.

@+

Philippe

[Shades]

le sous-forum IHM ?

[pier.antoine]

Bonjour

Oui, ici nous sommes dans le forum "Contribuez".
Si vous remontez sur le forum général "Access", vous trouverez un sous forum "IHM", "Interface Homme Machine".

Pierre

[Shades]

Bonjour Pierre, Phil et les autres,

J'ai donc créé la suite à ce post ici

J'ai ajouté l'appli dont il est question en lien car trop volumineuse pour être mise directement en PJ.

Cordialement,
Sylvain

[Shades]

Bonjour Philben

Comment aussi sauvegarder le plan affiché, de façon à s'en servir comme PJ et paraitre en page 2 d'un état ?

Cordialement,
Sylvain

[aggelon]

Je profite du up pour tout d'abord remercier philben pour l'aide que m'a apporté son code, et pour poser ma question :

Je récupère d'une table externe des adresses postales que je copie dans une table locale.
Je souhaite géocoder ces adresses pour les écrire ensuite dans un fichier texte.

J'ai donc créé une requête qui prend les adresses (ADRESSE,CP,VILLE), fait appelle au code de philben, et récupère la latitude et longitude dans un champ.

Ma fonction VBA:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
Public Function Get_GPS(Optional ByVal vAdresse As Variant = Null, _
                                 Optional ByVal vCP As Variant = Null, _
                                 Optional ByVal vCommune As Variant = Null, _
                                 Optional ByVal vDepartement As Variant = Null, _
                                 Optional ByVal sPays As Variant = "France") As String
 
Dim tGeo As tAdresseGeo
 
' J'ai coupé la partie épuration des adresses, où j'enlève les accents et ce genre de choses
 
tGeo = PostalToGeoViaGM(vAdresse, vCP, vCommune, vDepartement, sPays)
 
Get_GPS = Replace(CStr(tGeo.dLatitude), ",", ".")+","+Replace(CStr(tGeo.dLongitude), ",", ".")

Ma requete SQL:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
SELECT Get_GPS([ADR1]+" "+[ADR2],[CP],[VILLE]) AS GET_GPS FROM Adresses_Postales INTO Coordonnees_GPS

Ca marche bien... enfin presque : pour une table initiale de 2 ou 3 records, c'est bon; mais dès que je monte à plus (genre 10 ou 20), j'ai quelques latitudes ou longitudes qui restent à zéro

Si je débugue ou même fait un simple affichage, tout est bon... j'en déduis donc naïvement que l’exécution de ma requête est trop rapide par rapport à la réception de la réponse de Google ?

Comment ralentir tout cela suffisamment pour que cela marche ? (ou simplement attendre que Google réponde)

J'ai testé les classiques DoEvents et fonction de temporisation par delta de Time, mais ça ne marche pas : DoEvents ne semble avoir aucun effet tandis que la boucle WhileWend avec Time me consomme du CPU mais ne s’arrête jamais

J'ai un autre symptôme troublant, mais je ne sais pas si c'est lié : j'ai pris la précaution de stocker à la volée dans un fichier TXT de rejet toutes les adresses pour lesquelles soit la latitude soit la longitude serait à 0, et je m'aperçois que, dans ce fichier texte, les lignes de rejet sont souvent en plusieurs exemplaires à la suite au lieu d'une seule fois (mais pas toujours)...

Je m'interroge sur l'interaction et les appels entre le SQL et le VBA (je dois bien avouer ne pas être développeur, mais un simple tech de maintenance qui fait ce qu'il peut pour mener sa mission à bien, aussi me manque-t-il peut-être des notions élémentaires )

SQL -> VBA -> Google -> VBA -> SQL...
Est-il possible que le SQL n'ayant pas sa réponse suffisamment rapidement de la part du VBA (lui-même en attente de Google), il fasse des sortes de Cancel/Retry ?

Le code pour garder traces des rejets :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
phrase = "cmd /c echo " + Adresse_init + " " + CP_init + " " + Commune_init + " " + Departement_init + " " + Pays_init + " >> Q:\GPS_Rejet.txt"
Shell (phrase)

Merci de votre bienveillance et de vos lumières

Finalement, on dirait que la temporisation avec Time fonctionne, sauf que ça ralentit énormément : 1s par record ... je vais essayer d'affiner cela, peut-être avec un sleep...
Je laisse ce message qui n'attend désormais plus de réponse pour le cas où un autre tech rencontrerait le même problème

[philben]

Bonjour,

Comment ralentir tout cela suffisamment pour que cela marche ? (ou simplement attendre que Google réponde)

Google impose plusieurs limitations dont le nombre de requêtes par jour (2500 au jour d'aujourd'hui) et un délai entre deux requêtes. Personnellement j'utilise un délai de 200ms qui évite tout refus de géocodage.
5 requêtes par seconde et 2500 géocodages par jour, donc en un peu plus de 8 minutes c'est terminé !

Il existe d'autres limitations que je vous conseille de connaître. Voir le chapitre <Usage Limits> qui dit aussi que l'on n'a pas le droit d'utiliser ce service si on n'affiche pas le résultat sur une carte google...

Pour imposer un délai entre chaque requête il existe plusieurs méthodes dont l'utilisation des API (Wait, Sleep,...) ou alors en pur VBA avec la fonction Timer() qui retourne le nombre de secondes écoulées depuis minuit avec une résolution de 10ms.

Voici une petite fonction d'attente avec Timer

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
 
'Faire une pause de x.xx secondes
Public Sub Attente(Optional ByVal fSecondes As Single = 0.2)
   Dim fMax As Single
   fMax = (Timer + Abs(fSecondes)) Mod 86400
   While Timer <= fMax: DoEvents: Wend
End Sub

Deux problèmes potentiels avec Timer() :
Le premier est que Timer est lié à l'heure de Windows. Si celle-ci est ajustée (automatiquement ou manuellement) pendant la boucle d'attente, le délai d'attente sera faussé voir rentrer dans une boucle de plusieurs heures.... Depuis que j'utilise cette fonction je n'ai pas eu le problème.
La deuxième est que l'on appelle DoEvents pendant la boucle d'attente et les actions de l'utilisateurs pendant la boucle (clic sur controle, fermeture du formulaire seront pris en compte par Access. Il faut donc gérer cette possibilité.

Concernant Sleep, il suffit de déclarer l'API dans un module VBA :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Pour faire une pause de 200ms il faudra écrire entre deux envois de requêtes de geocoding à Google : Sleep(200)

Bonne continuation,

Philippe

[aggelon]

Merci pour cette réponse détaillée

Oui, effectivement, c'est ce que j'ai fait, sleep 200...

J'avoue que je n'avais pas vu ces clauses d'utilisation, comme quoi, on retombe sur le RTFM

Au départ, je pensais que 50 voire 100 ms étaient largement suffisantes, mais j'ai constatée que non, alors j'ai monté à 200 et j'ai vu que je n'avais plus de rejet...
En phase de production, j'aurai au pire quelques dizaines de requêtes réparties au long de la journée, donc rien de bien méchant, mais j'ai préféré le stress-tester un peu (de toute façon, ils me trouveront quand même des bugs, c'est sûr )

Pour la duplication, c'est corrigé aussi : j'utilisais le résultat de mon Get_GPS dans d'autres champs... je pensais qu'il travaillait avec le résultat stocké, mais en fait non, il faisait à nouveau un appel à ma fonction, et donc une requete Google...

Pour la limitation de la carte, je suis pour l'instant en mode 'cobaye', je peux donc encore changer... il existe d'autres sites ou d'autres moyens de géocoder une adresse sans cette contrainte ?

[philben]

Pour la limitation de la carte, je suis pour l'instant en mode 'cobaye', je peux donc encore changer... il existe d'autres sites ou d'autres moyens de géocoder une adresse sans cette contrainte ?

Yahoo! (API PlaceFinder) et Bing proposent des web services équivalents mais je n'ai ni testé ni regardé leurs conditions d'utilisation. En cherchant un peu sur le web, il en existe d'autres et certains se disent 'free' et/ou 'open', à voir...

Deux petites précisions :

• Le résultat d'un géocodage devrait être systématiquement vérifié, soit visuellement sur une carte soit par une autre méthode plus ou moins automatisée car on a parfois des mauvaises surprises!
• Si on utilise sleep dans une longue boucle de géocodage, il faudra faire un DoEvents de temps en temps. Pour ma part j'utilise un formulaire modal dédié qui affiche la progression.

Philippe

[aggelon]

Merci pour les infos

Le résultat d'un géocodage devrait être systématiquement vérifié, soit visuellement sur une carte soit par une autre méthode plus ou moins automatisée car on a parfois des mauvaises surprises!

Oui, comme cela avait déjà été suggéré ici, je vérifie systématiquement les résultats. Pour l'instant, je compare juste le CP rendu avec le CP initial, mais il me sera facile par la suite d'ajouter d'autres critères.
Cela me permet de gérer une liste des rejets. Ces rejets sont ensuite traités manuellement... (pour l'instant)

Si on utilise sleep dans une longue boucle de géocodage, il faudra faire un DoEvents de temps en temps. Pour ma part j'utilise un formulaire modal dédié qui affiche la progression

Ma boucle n'est pas grosse, mais j'ai effectivement déjà ajouté un DoEvents juste après l'appel à Google... faut être pris pour être appris, et comme j'ai déjà été pris, j'ai appris

Merci de ton aide !

[ronpub]

Je mettrais posterai ici ce que j'ai fais.

Voici ce que j'ai fait et qui date de 1 an et demi.
Fonctions GDIplus:
Module basCapture1-Window->Clipboard:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Compare Database
Option Explicit
 
Type RECT_Type
 
   left As Long
   top As Long
   right As Long
   bottom As Long
 
End Type
 
'The following declare statements are case sensitive.
 
Declare Function GetFocus Lib "user32" () As Long
Declare Function GetActiveWindow Lib "user32" () As Long
'Declare Function GetForegroundWindow Lib "user32" () As Long
'Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal uCmd As Long) As Long
'Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Declare Function GetDesktopWindow Lib "user32" () As Long
Declare Sub GetWindowRect Lib "user32" (ByVal hwnd As Long, _
                                    lpRect As RECT_Type)
Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) _
                                    As Long
Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc _
                                    As Long, ByVal nWidth As Long, _
                                    ByVal nHeight As Long) As Long
Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, _
                                    ByVal hObject As Long) As Long
Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, _
                                    ByVal X As Long, ByVal Y _
                                    As Long, ByVal nWidth As Long, _
                                    ByVal nHeight As Long, _
                                    ByVal hSrcDC As Long, _
                                    ByVal XSrc As Long, _
                                    ByVal YSrc As Long, _
                                    ByVal dwRop As Long) As Long
Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "user32" () As Long
Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, _
                                    ByVal hMem As Long) As Long
Declare Function CloseClipboard Lib "user32" () As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, _
                                    ByVal hdc As Long) As Long
Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
 
Global Const SRCCOPY = &HCC0020
Global Const CF_BITMAP = 2
    'GetWindow constants
    'Private Const GW_CHILD = 5
    'Private Const GW_HWNDLAST = 1
    'Private Const GW_HWNDFIRST = 0
    'GetWindowLong constants
    'Private Const GWL_STYLE = (-16)
    'Private Const WS_VSCROLL = &H200000
 
 
Function ScreenDump(Optional hHwnd As Long = -1)
   Dim AccessHwnd As Long, DeskHwnd As Long, prev As Long
   Dim hdc As Long
   Dim hdcMem As Long
   Dim rect As RECT_Type
   Dim junk As Long
   Dim fwidth As Long, fheight As Long
   Dim hBitmap As Long
 
   DoCmd.Hourglass True
 
   '---------------------------------------------------
   ' Get window handle to Windows and Microsoft Access
   '---------------------------------------------------
   If hHwnd = -1 Then
        DeskHwnd = GetDesktopWindow()
        AccessHwnd = GetActiveWindow()
        'prev = GetWindow(AccessHwnd, GW_HWNDFIRST)
    Else
          'Dim lStyle As Long
          'Dim lResult As Long
          'Dim strWindowTitle As String
          'strWindowTitle = Space(260)
        'While (lResult = 0) And (hHwnd <> 0)
            'Call GetWindowText(hHwnd, strWindowTitle, 260)
            'strWindowTitle = mp_TrimNull(strWindowTitle) ' Remove extra null terminator
            'Debug.Print hHwnd & " " & strWindowTitle
            '  'hHwnd = GetWindow(hHwnd, GW_CHILD)
              'lStyle = GetWindowLong(hHwnd, GWL_STYLE)
              'lResult = lStyle And WS_VSCROLL
          'Wend
        AccessHwnd = hHwnd
    End If
 
   '---------------------------------------------------
   ' Get screen coordinates of Microsoft Access
   '---------------------------------------------------
   Call GetWindowRect(AccessHwnd, rect)
   fwidth = rect.right - rect.left
   fheight = rect.bottom - rect.top
 
   '---------------------------------------------------
   ' Get the device context of Desktop and allocate memory
   '---------------------------------------------------
   hdc = GetDC(DeskHwnd)
   hdcMem = CreateCompatibleDC(hdc)
   hBitmap = CreateCompatibleBitmap(hdc, fwidth, fheight)
 
   If hBitmap <> 0 Then
      junk = SelectObject(hdcMem, hBitmap)
 
      '---------------------------------------------
      ' Copy the Desktop bitmap to memory location
      ' based on Microsoft Access coordinates.
      '---------------------------------------------
      junk = BitBlt(hdcMem, 0, 0, fwidth, fheight, hdc, rect.left, _
                    rect.top, SRCCOPY)
 
      '---------------------------------------------
      ' Set up the Clipboard and copy bitmap
      '---------------------------------------------
      junk = OpenClipboard(DeskHwnd)
      junk = EmptyClipboard()
      junk = SetClipboardData(CF_BITMAP, hBitmap)
      junk = CloseClipboard()
   End If
 
   '---------------------------------------------
   ' Clean up handles
   '---------------------------------------------
   junk = DeleteDC(hdcMem)
   junk = ReleaseDC(DeskHwnd, hdc)
 
   DoCmd.Hourglass False
 
End Function

Module basCapture2-Clipboard->Image

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
' Here's the code behind the code module
 
Option Compare Database
Option Explicit
 
Private Const vbPicTypeBitmap = 1
 
Private Type IID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(7) As Byte
End Type
 
Private Type PictDesc
   size As Long
   Type As Long
   hBmp As Long
   hpal As Long
   Reserved As Long
End Type
 
'
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
   (PicDesc As PictDesc, RefIID As IID, _
    ByVal fPictureOwnsHandle As Long, _
    IPic As IPicture) As Long
 
'''Windows API Function Declarations
 
'Does the clipboard contain a bitmap/metafile?
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
 
'Open the clipboard to read
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
 
'Get a pointer to the bitmap/metafile
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As _
Integer) As Long
 
'Close the clipboard
Private Declare Function CloseClipboard Lib "user32" () As Long
 
'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates.
'Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
 
'Create our own copy of the bitmap, so it doesn't get wiped out by _
subsequent clipboard updates.
Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 _
As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
 
'The API format types we're interested in
Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const CF_ENHMETAFILE = 14
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
' Addded by SL Apr/2000
Const xlPicture = CF_BITMAP
Const xlBitmap = CF_BITMAP
 
        '*******************************************
        'DEVELOPED AND TESTED UNDER MICROSOFT ACCESS 97 VBA ONLY
        '
        'Copyright: Lebans Holdings 1999 Ltd.
        '           May not be resold in whole or part. Please feel
        '           free to use any/all of this code within your
        '           own application without cost or obligation.
        '           Please include the one line Copyright notice
        '           if you use this function in your own code.
        '
        'Name:      BitmapToPicture &
        '           GetClipBoard
        '
        'Purpose:   Provides a method to save the contents of a
        '           Bound or Unbound OLE Control to a Disk file.
        '           This version only handles BITMAP files.
        '           '
        'Author:    Stephen Lebans
        'Email:     Step...@lebans.com
        'Web Site:  www.lebans.com
        'Date:      Apr 10, 2000, 05:31:18 AM
        '
        'Called by: Any
        '
        'Inputs:    Needs a Handle to a Bitmap.
        '           This must be a 24 bit bitmap for this release.
        '
        'Credits:
        'As noted directly in Source :-)
        '
        'BUGS:
        'To keep it simple this version only works with Bitmap files of 16 or 24 bits.
        'I'll go back and add the
        'code to allow any depth bitmaps and add support for
        'metafiles as well.
        'No serious bugs notices at this point in time.
        'Please report any bugs to my email address.
        '
        'What's Missing:
        '
        '
        'HOW TO USE:
        '
        '*******************************************
 
    Public Function BitmapToPicture(ByVal hBmp As Long, _
    Optional ByVal hpal As Long = 0&) _
    As IPicture    '
 
    ' The following code is adapted from
    ' Bruce McKinney's "Hardcore Visual Basic"
    ' And Code samples from:
    ' http://www.mvps.org/vbnet/code/bitmap/printscreenole.htmv
    ' and examples posted on MSDN
 
    ' The handle to the Bitmap created by CreateDibSection
    ' cannot be passed directly as the PICTDESC.Bitmap element
    ' that get's passed to OleCreatePictureIndirect.
    ' We need to create a regular bitmap from our CreateDibSection
    'Dim hBmptemp As Long, hBmpOrig As Long
    'Dim hDCtemp As Long
 
    'Fill picture description
    Dim lngRet As Long
    Dim IPic As IPicture, picdes As PictDesc, iidIPicture As IID
 
    'hDCtemp = apiCreateCompatibleDC(0)
    'hBmptemp = apiCreateCompatibleBitmap _
    '(mhDCImage, lpBmih.bmiHeader.biWidth, _
    'lpBmih.bmiHeader.biHeight)
 
    'hBmpOrig = apiSelectObject(hDCtemp, hBmptemp)
 
   '  lngRet = apiBitBlt(hDCtemp, 0&, 0&, lpBmih.bmiHeader.biWidth, _
    '        lpBmih.bmiHeader.biHeight, mhDCImage, 0, 0, SRCCOPY)
 
    'hBmptemp = apiSelectObject(hDCtemp, hBmpOrig)
    'Call apiDeleteDC(hDCtemp)
 
    picdes.size = Len(picdes)
    picdes.Type = vbPicTypeBitmap
    picdes.hBmp = hBmp
 
    ' No palette info here
    ' Everything is 24bit for now
 
    picdes.hpal = hpal
    ' ' Fill in magic IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
    iidIPicture.Data1 = &H7BF80980
    iidIPicture.Data2 = &HBF32
    iidIPicture.Data3 = &H101A
    iidIPicture.Data4(0) = &H8B
    iidIPicture.Data4(1) = &HBB
    iidIPicture.Data4(2) = &H0
    iidIPicture.Data4(3) = &HAA
    iidIPicture.Data4(4) = &H0
    iidIPicture.Data4(5) = &H30
    iidIPicture.Data4(6) = &HC
    iidIPicture.Data4(7) = &HAB
    '' Create picture from bitmap handle
    lngRet = OleCreatePictureIndirect(picdes, iidIPicture, True, IPic)
    '' Result will be valid Picture or Nothing-either way set it
    Set BitmapToPicture = IPic
    End Function
 
Function GetClipBoard() As Long
' Adapted from original Source Code by:
'* MODULE NAME:     Paste Picture
'* AUTHOR & DATE:   STEPHEN BULLEN, Business Modelling Solutions Ltd.
'*                  15 November 1998
'*
'* CONTACT:         Step...@BMSLtd.co.uk
'* WEB SITE:        http://www.BMSLtd.co.uk
 
' Handles for graphic Objects
Dim hClipBoard As Long
Dim hBitmap As Long
Dim hBitmap2 As Long
 
'Check if the clipboard contains the required format
'hPicAvail = IsClipboardFormatAvailable(lPicType)
 
 ' Open the ClipBoard
 hClipBoard = OpenClipboard(0&)
 
 If hClipBoard <> 0 Then
    ' Get a handle to the Bitmap
    hBitmap = GetClipboardData(CF_BITMAP)
 
    If hBitmap = 0 Then GoTo exit_error
    ' Create our own copy of the image on the clipboard, in the appropriate format.
    'If lPicType = CF_BITMAP Then
        hBitmap2 = CopyImage(hBitmap, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
     '   Else
      '  hBitmap2 = CopyEnhMetaFile(hBitmap, vbNullString)
       ' End If
 
        'Release the clipboard to other programs
        hClipBoard = CloseClipboard
 
 GetClipBoard = hBitmap2
 Exit Function
 
 End If
 
exit_error:
' Return False
GetClipBoard = -1
End Function

Module basCapture3-Image->File

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
Option Compare Database
Option Explicit
 
Private Declare Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Const VK_SNAPSHOT As Long = &H2C
Private Const KEYEVENTF_KEYUP As Long = &H2
 
Private Enum GpStatus
    Ok = &H0
End Enum
 
'====
'APIs
'====
'General
Private Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal cb As Long) As Long
Private Declare Function lstrlenW Lib "kernel32" (ByVal psString As Any) As Long
'Gdi plus
Private Declare Function GdiplusStartup Lib "GdiPlus.dll" (ByRef mtoken As Long, ByRef mInput As GdiplusStartupInput, ByRef mOutput As Any) As GpStatus
Private Declare Sub GdiplusShutdown Lib "GdiPlus.dll" (ByVal mtoken As Long)
Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal image As Long, ByVal filename As String, clsidEncoder As UUID, encoderParams As Any) As GpStatus
Private Declare Function GdipGetImageEncodersSize Lib "gdiplus" (numEncoders As Long, size As Long) As GpStatus
Private Declare Function GdipGetImageEncoders Lib "gdiplus" (ByVal numEncoders As Long, ByVal size As Long, encoders As Any) As GpStatus
Private Declare Function GdipGetEncoderParameterList Lib "GdiPlus.dll" (ByVal mImage As Long, ByRef mClsidEncoder As GUID, ByVal msize As Long, ByRef mBuffer As EncoderParameters) As GpStatus
Private Declare Function GdipGetEncoderParameterListSize Lib "GdiPlus.dll" (ByVal mImage As Long, ByRef mClsidEncoder As GUID, ByRef msize As Long) As GpStatus
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GdiPlus.dll" (ByVal mHbm As Long, ByVal mhPal As Long, ByRef mBitmap As Long) As GpStatus
Private Declare Function GdipDisposeImage Lib "GdiPlus.dll" (ByVal mImage As Long) As GpStatus
 
Private Type GUID
    Data(0 To 3) As Long
End Type
 
Public Type UUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type
 
Private Type ImageCodecInfo
    ClassID           As UUID
    FormatID          As UUID
    CodecName         As Long
    DllName           As Long
    FormatDescription As Long
    FilenameExtension As Long
    MimeType          As Long
    flags             As ImageCodecFlags
    Version           As Long
    SigCount          As Long
    SigSize           As Long
    SigPattern        As Long
    SigMask           As Long
End Type
 
Private Enum ImageCodecFlags
    ImageCodecFlagsEncoder = &H1
    ImageCodecFlagsDecoder = &H2
    ImageCodecFlagsSupportBitmap = &H4
    ImageCodecFlagsSupportVector = &H8
    ImageCodecFlagsSeekableEncode = &H10
    ImageCodecFlagsBlockingDecode = &H20
    ImageCodecFlagsBuiltin = &H10000
    ImageCodecFlagsSystem = &H20000
    ImageCodecFlagsUser = &H40000
End Enum
 
Private Type GdiplusStartupInput
    GdiplusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type
 
Private Type EncoderParameter
    GUID As GUID
    lNumberOfValues As Long
    lType  As Long
    lValue As Long
End Type
 
Private Type EncoderParameters
    Count     As Long
    Parameter(4) As EncoderParameter
End Type
 
Private Const EncoderParameterValueTypeLong As Long = &H4
 
 
Public Function saveBitmapToFileAsJPEG(ByRef oPic As StdPicture, szImgPath As String) As Boolean
 
    Dim hGDIPToken As Long
    Dim udtGDIPStartup As GdiplusStartupInput
    Dim udtPngClsid As UUID
    'Dim udtJPEGEnc As GUID
    Dim udtEncParams As EncoderParameters
    Dim hImageScrShot As Long
    Dim bRet As Boolean
 
    Const OUTPUT_FORMAT As String = "image/jpeg"     'Mime type
 
    ' init ret value and GDI+ startup UDT
    bRet = False
    udtGDIPStartup.GdiplusVersion = 1
 
    If (GdiplusStartup(hGDIPToken, udtGDIPStartup, ByVal 0) = Ok) Then
 
        GetEncoderClsid OUTPUT_FORMAT, udtPngClsid
 
        'With udtJPEGEnc
        '    ' JPEG Encoder GUID: {557CF401-11D3-1A04-739A-00002EF31EF8}
        '    .Data(0) = &H557CF401
        '    .Data(1) = &H11D31A04
        '    .Data(2) = &H739A
        '    .Data(3) = &H2EF31EF8
        'End With
 
        With udtEncParams
            .Count = 1
            With .Parameter(0)
                ' EncoderQuality GUID: {1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}
                .GUID.Data(0) = &H1D5BE4B5
                .GUID.Data(1) = &HFA4A452D
                .GUID.Data(2) = &H9CDD5DB3
                .GUID.Data(3) = &H5105E7EB
 
                ' The Quality Enc Param is a Long from 1(LQ) - 100(HQ)
                .lType = EncoderParameterValueTypeLong
                ' Just this 1 "Quality" Value
                .lNumberOfValues = 1
                ' Set Quality
                .lValue = CLng(100)
            End With
        End With
 
        ' Create a GDIPlus Bitmap image based off the screen shot Picture
        If (GdipCreateBitmapFromHBITMAP(oPic.handle, 0, hImageScrShot) = Ok) Then
            ' Save it to a file and dispose of the Picture
            If (GdipSaveImageToFile(hImageScrShot, StrConv(szImgPath, vbUnicode), udtPngClsid, udtEncParams) = Ok) Then
                ' File was saved to HDD
                bRet = True
                Set oPic = Nothing
            End If
            ' Cleanup bitmap
            Call GdipDisposeImage(hImageScrShot)
        End If
        ' Shutdown GDI+
        Call GdiplusShutdown(hGDIPToken)
    End If
 
    saveBitmapToFileAsJPEG = bRet
End Function
 
Public Function saveBitmapToFileAsPNG(ByRef oPic As StdPicture, szImgPath As String) As Boolean
 
    Dim hGDIPToken As Long
    Dim udtGDIPStartup As GdiplusStartupInput
    Dim udtPngClsid As UUID
    Dim hImageScrShot As Long
    Dim bRet As Boolean
 
    Const OUTPUT_FORMAT As String = "image/png"     'Mime type
 
    ' init ret value and GDI+ startup UDT
    bRet = False
    udtGDIPStartup.GdiplusVersion = 1
 
    If (GdiplusStartup(hGDIPToken, udtGDIPStartup, ByVal 0) = Ok) Then
 
        GetEncoderClsid OUTPUT_FORMAT, udtPngClsid
 
        ' Create a GDIPlus Bitmap image based off the screen shot Picture
        If (GdipCreateBitmapFromHBITMAP(oPic.handle, 0, hImageScrShot) = Ok) Then
            ' Save it to a file and dispose of the Picture
            If (GdipSaveImageToFile(hImageScrShot, StrConv(szImgPath, vbUnicode), udtPngClsid, ByVal 0) = Ok) Then
                ' File was saved to HDD
                bRet = True
                Set oPic = Nothing
            End If
            ' Cleanup bitmap
            Call GdipDisposeImage(hImageScrShot)
        End If
        ' Shutdown GDI+
        Call GdiplusShutdown(hGDIPToken)
    End If
 
    saveBitmapToFileAsPNG = bRet
End Function
 
 
'=======================================================
'GetEncoderClsid passe en revue les encoder disponibles
'sur le système. Si il tombe sur celui dont le mime
'type est égal au mime type stocké dans la variable
'strMimeType, il récupère son CLSID et celui-ci sera
'utilisé' par GdipSaveImageToFile.
'=======================================================
 
Public Function GetEncoderClsid(strMimeType As String, ClassID As UUID) As Long
 
 
    'Déclarations
 
    Dim num As Long
    Dim size As Long
    Dim i As Long
    Dim ICI() As ImageCodecInfo
    Dim buffer() As Byte
 
 
    'Initie la valeur de retour
 
    GetEncoderClsid = -1
 
 
    'Récupère les infos des encoders du système
 
    Call GdipGetImageEncodersSize(num, size)
 
 
    'Aucun encoder trouvé : quitte la fonction
 
    If size = 0 Then Exit Function
 
 
    'Initie la taille des buffers
 
    ReDim ICI(1 To num)
    ReDim buffer(1 To size)
 
 
    'Rempli les buffers avec les caractéristiques des encoders
 
    Call GdipGetImageEncoders(num, size, buffer(1))
    Call CopyMemory(ICI(1), buffer(1), (Len(ICI(1)) * num))
 
 
    'Passe en revue la liste des encoders trouvés
 
    For i = 1 To num
 
 
        'Test si le mime type de l'encoder correspond à celui désiré
 
        If StrComp(PtrToStrW(ICI(i).MimeType), strMimeType, vbTextCompare) = 0 Then
 
 
            'Encoder trouvé : retourne sa ClassID et quitte la boucle
 
            ClassID = ICI(i).ClassID
            GetEncoderClsid = i
            Exit For
 
 
        End If
 
 
    Next
 
 
    'Détruit les buffers
 
    Erase ICI
    Erase buffer
 
 
End Function
 
 
'=============================
'Converti un pointer en chaine
'=============================
 
Public Function PtrToStrW(ByVal lpsz As Long) As String
 
 
    'Déclarations
 
    Dim sOut As String
    Dim lLen As Long
 
 
    'Récupère la taille de la chaine
 
    lLen = lstrlenW(lpsz)
 
 
    'Si la taille n'est pas nulle
 
    If (lLen > 0) Then
 
 
        'Retourne le résultat sous la forme d'une chaine
 
        sOut = StrConv(String$(lLen, vbNullChar), vbUnicode)
        Call CopyMemory(ByVal sOut, ByVal lpsz, lLen * 2)
        PtrToStrW = StrConv(sOut, vbFromUnicode)
 
 
    End If
 
 
End Function

Une fonction pour sauvegarder la carte dans le formulaire contenant le sous-formulaire de l'explorateur web:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
'
Public Function SauveCarte(Optional strNomCarte As String = "carte")
' *********************
' You must set a Reference to:
' "OLE Automation"
' for this function to work.
' Goto the Menu and select
' Tools->References
' Scroll down to:
' Ole Automation
' and click in the check box to select
' this reference.
 
    Dim lngRet As Long
    Dim lngBytes As Long
    Dim hPix As StdPicture
    Dim hBitmap As Long
 
    'Copie dans le presse-papier la fenêtre du navigateur à 50 %
    With Me.WebBrowser
        If Me.InsideWidth > 0 Then .Height = Int(Me.InsideHeight * 0.6)
        If Me.InsideWidth > 0 Then .Width = .Height
        fitMarkers
        .SetFocus
        Attendre 2000
        Call ScreenDump(GetFocus)
        If Me.InsideWidth > 0 Then .Height = Me.InsideHeight
        If Me.InsideWidth > 0 Then .Width = .Height
        fitMarkers
    End With
    'Sauve la copie du presse-papier en image
    hBitmap = GetClipBoard
    If hBitmap Then
    Set hPix = BitmapToPicture(hBitmap)
    'Debug.Print hPix.Type
    'SavePicture hPix, CurrentProject.Path & "\geocodage\" & strNomCarte & ".bmp"
    'SaveToJpg hPix, CurrentProject.Path & "\geocodage\" & strNomCarte & ".jpg"
    'saveBitmapToFileAsJPEG hPix, CurrentProject.Path & "\geocodage\" & strNomCarte & ".jpg"
    saveBitmapToFileAsPNG hPix, CurrentProject.Path & "\geocodage\" & strNomCarte & ".png"
    'libère la mémoire
    apiDeleteObject (hBitmap)
    Set hPix = Nothing
    End If
End Function

On peut l'appeller au travers de requetes pour generer une carte pour chaque enregistrement.
Ensuite dans l'état je rapelle la carte:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
Private Sub Détail_Format(Cancel As Integer, FormatCount As Integer)
    Dim strFile As String
    strFile = CurrentProject.Path & "\geocodage\" & CStr(Me.Id_tbl_Contact) & ".png"
    'Debug.Print strFile
    If FileExists(strFile) Then
        Me.ImageFrame2.Picture = strFile
    Else: Me.ImageFrame2.Picture = CurrentProject.Path & "\geocodage\blank.png"
    End If
    'Debug.Print Me.ImageFrame2.Picture
End Sub

Je n'ai pas supprimé de crédit pour le code mais je vais essayer de retrouver les originaux pour bien spécifier les crédits manquants des codes. C'est surement mieux.

[ronpub]

En effet, avec les <Static maps API>, on peut facilement enregistrer sur disque une image (format png par défaut) de la carte puis l'intégrer dans un rapport Access ou l'imprimer directement.

Exemple concret s'appuyant sur une fonction du tuto d'Arkham46 comme base de travail (URL, type et chemin de l'image enregistrée sont modifiés) :

Très sympa le code surtout pour la simplicité de la sauvegarde.
Mais j'aime tellement jouer avec l'API au travers du javascript. Et la limite des 2048 caractères est un problème pour moi.
Je ne vois pas comment exécuter ce javascript dans une page html sur un disque local avec WinHttp.

[eliotclave]

bonjour,
Merci beaucoup d'avoir partager ce fichier qui va mettre fort utilise pour l'avenir. je viens de le tester, mais lorsque je clique sur Carte, la page de la carte s'affiche bien mais je ne vois pas les points dessus ??? Avez vous une solution svp???
En vous remerciant par avance;
Eliot