bonjour jmaulin et merci pour votre message.
une solution ici pour le géocodage inversé.
Bonne continuation,
Philippe
bonjour jmaulin et merci pour votre message.
une solution ici pour le géocodage inversé.
Bonne continuation,
Philippe
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.
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.
Bonjour,
Dans un post précédent, j'ai écrit :
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.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.
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) :
En travaillant sur les nombreux paramètres possibles de la carte à générer, on peut arriver à un résultat pratiquement wysiwyg.
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
Principales limitations : 1000 requêtes/jour et longueur maxi de l'URL : 2048 caractères. Voir lien pour plus de détails.
Philippe
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
bonjour,
en interceptant le current record de tes adresses ?...adresse 1, adresse 2 adresse 3
Pourquoi autant de requery ?
Je pense que ce sont plutot des questions à mettre dans le sous-forum IHM.
je vais t'aider un peu sur cette partie là en fignolant la fonction du post précédent avec une base exemple.
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2De 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.
@+
Philippe
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
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
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
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:
Ma requete SQL:
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), ",", ".")
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
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
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 :
Merci de votre bienveillance et de vos lumières
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)
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
Bonjour,
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.Comment ralentir tout cela suffisamment pour que cela marche ? (ou simplement attendre que Google réponde)
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
Deux problèmes potentiels 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
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 :
Pour faire une pause de 200ms il faudra écrire entre deux envois de requêtes de geocoding à Google : Sleep(200)
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2 Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Bonne continuation,
Philippe
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 ?
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...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 ?
Deux petites précisions :
Philippe
- 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.
Merci pour les infos
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)
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 !
Voici ce que j'ai fait et qui date de 1 an et demi.
Fonctions GDIplus:
Module basCapture1-Window->Clipboard:
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 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 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 ' 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
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:
On peut l'appeller au travers de requetes pour generer une carte pour chaque enregistrement.
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
Ensuite dans l'état je rapelle la carte:
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.
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
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.
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
Vous avez un bloqueur de publicités installé.
Le Club Developpez.com n'affiche que des publicités IT, discrètes et non intrusives.
Afin que nous puissions continuer à vous fournir gratuitement du contenu de qualité, merci de nous soutenir en désactivant votre bloqueur de publicités sur Developpez.com.
Partager