[AC-2003] Migrer outils vba en visual studio vb.net

PAR EXEMPLE .
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
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
Option Compare Database
Option Explicit
 
Public Function ve_Inc(ind As Variant) As Integer
    Static n As Integer
 
    n = ((n + 100) Mod 1000)
    ve_Inc = n
End Function
 
Public Sub ve_updateXY(idPrj, objOLE As Control)
    Dim ThisDb As database
    Dim tVisioXY As Recordset
    Dim docVisio As Visio.Document, pageVisio As Visio.page, wndVisio As Visio.window
    Dim iPage As Integer
    Dim nomPage As String
 
    Set ThisDb = CurrentDb
    Set tVisioXY = ThisDb.OpenRecordset("VisioXY", dbOpenDynaset)
    Set docVisio = objOLE.Object.Application.Documents(1)
    For iPage = 1 To docVisio.Pages.count
        nomPage = docVisio.Pages(iPage).Name
        Set pageVisio = ve_OuvrirPage(objOLE, nomPage)
        Call ve_sauveObjsXY(idPrj, objOLE, tVisioXY, nomPage, "Site", "PinX", "ve Prj Sites", "nommageSite")
        Call ve_sauveObjsXY(idPrj, objOLE, tVisioXY, nomPage, "Site", "PinY", "ve Prj Sites", "nommageSite")
        Call ve_sauveObjsXY(idPrj, objOLE, tVisioXY, nomPage, "Routeur", "PinX", "Materiel", "nommageMat")
        Call ve_sauveObjsXY(idPrj, objOLE, tVisioXY, nomPage, "Routeur", "PinY", "Materiel", "nommageMat")
        Call ve_sauveObjsXY(idPrj, objOLE, tVisioXY, nomPage, "LL", "Controls.X1", "ve prj Reseaux IP", "LL_netIP")
        Call ve_sauveObjsXY(idPrj, objOLE, tVisioXY, nomPage, "LL", "Controls.Y1", "ve prj Reseaux IP", "LL_netIP")
        Call ve_sauveObjsXY(idPrj, objOLE, tVisioXY, nomPage, "LL", "Controls.X2", "ve prj Reseaux IP", "LL_netIP")
        Call ve_sauveObjsXY(idPrj, objOLE, tVisioXY, nomPage, "LL", "Controls.X3", "ve prj Reseaux IP", "LL_netIP")
    Next
    tVisioXY.Close
End Sub
 
Public Sub ve_sauveObjsXY(idPrj, objOLE As Control, tVisioXY As Recordset, nomPage$, nomMaster, nomCellule$, nom_tObj$, ptr_tObj$)
    Dim ThisDb As database
    Dim tObj As Recordset
    Dim req As String
    Dim docVisio As Visio.Document, pageVisio As Visio.page, wndVisio As Visio.window
    Dim shpObj As Visio.Shape
    Dim iShape As Integer
    Dim nomObj As String
    Dim xPos As Integer, yPos As Integer
    Dim formula As String, valeur As Long
    Dim maj As Boolean
 
    Set docVisio = objOLE.Object.Application.Documents(1)
    Set pageVisio = ve_OuvrirPage(objOLE, nomPage)
 
    Set ThisDb = CurrentDb
 
    ' ouvrir la table indiquée par nom_tobj et la table des coordonnées VisioXY
    req = "SELECT *"
    req = req & " FROM [" & nom_tObj & "] WHERE idPrj=" & idPrj
    Set tObj = ThisDb.OpenRecordset(req, dbOpenSnapshot)
    ' tVisioXY.MoveFirst
 
    For iShape = 1 To pageVisio.Shapes.count
        Set shpObj = pageVisio.Shapes(iShape)
        maj = False
        If shpObj.Master.Name = nomMaster Then
            With tObj
                ' .MoveFirst
                .FindFirst (ptr_tObj & "='" & shpObj.Name & "'")
                If (Not .NoMatch) Then
                    maj = True
                    nomObj = .Fields(ptr_tObj)
                    formula = shpObj.Cells(nomCellule).formula
                    valeur = CLng(shpObj.Cells(nomCellule))
                End If
            End With
        End If
        If maj Then
            req = "idPrj=" & idPrj
            req = req & " AND nomPage='" & nomPage & "'"
            req = req & " AND nomMaster='" & nomMaster & "'"
            req = req & " AND nomObj='" & nomObj & "'"
            req = req & " AND nomCellule='" & nomCellule & "'"
            With tVisioXY
                ' .MoveFirst
                .FindFirst (req)
                If .NoMatch Then .AddNew Else .Edit
                    !idPrj = idPrj
                    !nomPage = nomPage
                    !nomMaster = nomMaster
                    !nomObj = nomObj
                    !nomCellule = nomCellule
                    !result = valeur
                    !formula = ve_2english(formula)
                    .Update
            End With
        End If
    Next
    tObj.Close
 End Sub
 
Public Function ve_DrawSites(objOLE As Control, nomPage As String, idPrj As Variant) As Boolean
    Dim ThisDb As database
    Dim tSite As Recordset, tVisioXY As Recordset
    Dim req As String
    Dim docVisio As Visio.Document
    Dim pageVisio As Visio.page
    Dim wndVisio As Visio.window
    Dim defX As Double, defY As Double
    Dim result As Boolean
    Dim nomSite As String, textSite As String
 
    Set docVisio = objOLE.Object.Application.Documents(1)
    Set pageVisio = ve_OuvrirPage(objOLE, nomPage)
    Set wndVisio = ve_OuvrirWindow(pageVisio)
 
    Set ThisDb = CurrentDb
 
    req = "SELECT SiteProjet.idPrj, Site.*"
    req = req & " FROM Site INNER JOIN SiteProjet ON Site.idSite = SiteProjet.idSite "
    req = req & " WHERE idPrj=" & idPrj
    Set tSite = ThisDb.OpenRecordset(req, dbOpenSnapshot)
 
    req = "SELECT * FROM VisioXY WHERE idPrj=" & idPrj
    Set tVisioXY = ThisDb.OpenRecordset(req, dbOpenSnapshot)
 
    While Not tSite.EOF
        With tSite
            defX = IIf(IsNull(!Xsite), 0, !Xsite)
            defY = IIf(IsNull(!Ysite), 0, !Ysite)
            nomSite = IIf(IsNull(!nommageSite), "", !nommageSite)
            textSite = IIf(IsNull(!nomSite), !nommageSite, !nomSite)
            Call ve_PoseObjet(idPrj, pageVisio, "Site", nomSite, textSite, tVisioXY, defX, defY)
            .MoveNext
        End With
    Wend
    tSite.Close
    tVisioXY.Close
    'docVisio.Save
    Call ve_FermerWindow(wndVisio)
End Function
 
Public Function ve_DrawLiens(objOLE As Control, nomPage As String, idPrj As Variant) As Boolean
    Dim ThisDb As database
    Dim tSite As Recordset, qSite As QueryDef, tVisioXY As Recordset
    Dim req As String
    Dim result As Boolean, superpose As Boolean
    Dim i As Integer, j As Integer, iLien As Integer, deltaXY As Integer
    Dim dX As Integer, dY As Integer
 
    Dim docVisio As Visio.Document, pageVisio As Visio.page, wndVisio As Visio.window
    Dim lienObj As Visio.Shape
    Dim nomLien As String, textLien As String
    Dim nom1 As String, nom2 As String
    Dim lienObj1 As Visio.Shape, lienObj2 As Visio.Shape
    Dim siteObj1 As Visio.Shape, siteObj2 As Visio.Shape
    Dim lienMaster As Visio.Master
    Dim cellGlueFromBegin As Visio.Cell, cellGlueFromEnd As Visio.Cell
    Dim cellGlueToObj1 As Visio.Cell, cellGlueToObj2 As Visio.Cell
 
    Set docVisio = objOLE.Object.Application.Documents(1)
    Set pageVisio = ve_OuvrirPage(objOLE, nomPage)
    Set wndVisio = ve_OuvrirWindow(pageVisio)
 
    Set ThisDb = CurrentDb
    Set qSite = ThisDb.QueryDefs("ve Map Sites")
    qSite.Parameters("SEl_idPrj") = idPrj
    Set tSite = qSite.OpenRecordset(dbOpenSnapshot)
 
    ' ouvrir la table des coordonnées enregistrées
    req = "SELECT * FROM VisioXY WHERE idPrj=" & idPrj
    Set tVisioXY = ThisDb.OpenRecordset(req, dbOpenSnapshot)
 
    iLien = 0
    While Not tSite.EOF
        With tSite
            If (iLien <= 0) Then iLien = !nbLiens
            superpose = (!nbLiens > 1)
            nom1 = !nommageSite1
            nom2 = !nommageSite2
            ' Set siteObj1 = pageVisio.Shapes(!nommageSite1)
            ' Set siteObj2 = pageVisio.Shapes(!nommageSite2)
 
            ' Set lienMaster = docVisio.Masters("LL")
            ' Set lienObj = pageVisio.Drop(lienMaster, 0, 0)
            ' lienObj.SendToBack
            ' lienObj.Text = !nomLiaison
            ' lienObj.Cells("TextBkgnd") = 2 ' fond blanc
            If (superpose) Then
                deltaXY = IIf((iLien Mod 2 = 0), 5 * (iLien \ 2), -5 * ((iLien + 1) \ 2))
                dX = deltaXY
                dY = deltaXY
            Else
                dX = 0
                dY = 0
            End If
            ' Libeller le lien
            nomLien = !nomLiaison
            textLien = !nomLiaison
            ' Raccorder le lien lienobj aux deux sites nom1 et nom2
            Set lienObj = ve_lierObjets(idPrj, pageVisio, nom1, nom2, "LL", nomLien, textLien, tVisioXY, dX, dY)
 
            'Set cellGlueFromBegin = lienObj.Cells("BeginX")
            'Set cellGlueFromEnd = lienObj.Cells("EndX")
 
            'Set cellGlueToObj1 = siteObj1.Cells("Connections.X5")
            'Set cellGlueToObj2 = siteObj2.Cells("Connections.X5")
 
            'cellGlueFromBegin.GlueTo cellGlueToObj1
            'cellGlueFromEnd.GlueTo cellGlueToObj2
        End With
        tSite.MoveNext
        iLien = iLien - 1
    Wend
    qSite.Close
    tSite.Close
    tVisioXY.Close
    docVisio.Save
    Call ve_FermerWindow(wndVisio)
End Function
 
Public Function ve_DrawRouteursIP(objOLE As Control, nomPage As String, idPrj As Variant) As Boolean
    Dim ThisDb As database
    Dim tRtr As Recordset, tVisioXY As Recordset
    Dim req As String
    Dim pageVisio As Visio.page
    Dim wndVisio As Visio.window
    Dim nomRtr As String, textRtr As String
    Dim defX As Double, defY As Double
 
    Set pageVisio = ve_OuvrirPage(objOLE, nomPage)
    Set wndVisio = ve_OuvrirWindow(pageVisio)
 
    Set ThisDb = CurrentDb
 
    req = "SELECT Materiel.*, Site.nommageSite, Site.nomSite, Site.XSite, Site.YSite "
    req = req & " FROM Site INNER JOIN Materiel ON Site.idSite = Materiel.idSite "
    req = req & " WHERE Materiel.marqueMat = 'CISCO' AND idPrj=" & idPrj
    Set tRtr = ThisDb.OpenRecordset(req, dbOpenSnapshot)
 
    req = "SELECT * FROM VisioXY WHERE idPrj=" & idPrj
    Set tVisioXY = ThisDb.OpenRecordset(req, dbOpenSnapshot)
 
    While Not tRtr.EOF
        With tRtr
            nomRtr = IIf(IsNull(!nommageMat), "", !nommageMat)
            textRtr = IIf(IsNull(!nomMat), !nommageMat, !nomMat)
            defX = IIf(IsNull(!Xsite), 0, !Xsite)
            defY = IIf(IsNull(!Ysite), 0, !Ysite)
            If (defX = 0) And (defY = 0) Then
                tVisioXY.FindFirst ("nomMaster='Site' AND nomCellule='PinX' AND nomObj='" & !nommageSite & "'")
                If Not tVisioXY.NoMatch Then defX = tVisioXY!result
                tVisioXY.FindFirst ("nomMaster='Site' AND nomCellule='PinY' AND nomObj='" & !nommageSite & "'")
                If Not tVisioXY.NoMatch Then defY = tVisioXY!result
            End If
            Call ve_PoseObjet(idPrj, pageVisio, "Routeur", nomRtr, textRtr, tVisioXY, defX, defY)
            .MoveNext
        End With
    Wend
    tRtr.Close
    tVisioXY.Close
    ' docVisio.Save
    Call ve_FermerWindow(wndVisio)
End Function
 
Public Function ve_DrawLiensIP(objOLE As Control, nomPage As String, idPrj As Variant) As Boolean
    Dim ThisDb As database
    Dim tNetIP As Recordset, qNetIP As QueryDef, tVisioXY As Recordset
    Dim req As String
    Dim nom1 As String, nom2 As String, nomLien As String, textLien As String, CR As String
    Dim nomExtr1 As String, nomExtr2 As String, costospf As String
    Dim DxEtiq As Double, CDxEtiq As Integer
    Dim result As Boolean, superpose As Boolean
    Dim i As Integer, j As Integer, iLien As Integer, deltaXY As Integer, dX As Integer, dY As Integer
    Dim cote1 As String, cote2 As String
 
    Dim docVisio As Visio.Document
    Dim pageVisio As Visio.page, wndVisio As Visio.window
    Dim lienObj As Visio.Shape, lienObj1 As Visio.Shape, lienObj2 As Visio.Shape
    Dim rtrObj1 As Visio.Shape, rtrObj2 As Visio.Shape
    Dim extrObj1 As Visio.Shape, extrObj2 As Visio.Shape
    Dim extrMaster As Visio.Master
    Dim cellGlueFromBegin As Visio.Cell, cellGlueFromEnd As Visio.Cell
    Dim cellGlueToObj1 As Visio.Cell, cellGlueToObj2 As Visio.Cell
 
 
    Set docVisio = objOLE.Object.Application.Documents(1)
    Set pageVisio = ve_OuvrirPage(objOLE, nomPage)
    Set wndVisio = ve_OuvrirWindow(pageVisio)
 
    Set ThisDb = CurrentDb
    ' Créér la liste des RéseauxIP
    Set qNetIP = ThisDb.QueryDefs("ve Map Réseaux IP")
    qNetIP.Parameters("SEl_idPrj") = idPrj
    Set tNetIP = qNetIP.OpenRecordset(dbOpenSnapshot)
    cote1 = "ve Map Réseaux IP Liens"
    cote2 = cote1 & "_1"
 
    ' Ouvrir la table des coordonnées enregistrées
    req = "SELECT * FROM VisioXY WHERE idPrj=" & idPrj
    Set tVisioXY = ThisDb.OpenRecordset(req, dbOpenSnapshot)
 
    CR = Chr(13) + Chr(10)
 
    iLien = 0
    While Not tNetIP.EOF
        With tNetIP
            ' Retrouver dans le résultat de la requête le nombre de liens entre les deux routeurs
            If (iLien <= 0) Then iLien = !nbLiens
            superpose = (!nbLiens > 1)
 
            ' Retrouver les formes Visio des deux routeurs à partir de leurs noms
            nom1 = .Fields(cote1 & ".nommageMat")
            nom2 = .Fields(cote2 & ".nommageMat")
 
            ' Le libellé du lien est le réseauIP et l'indication éventuelle du protocole OSI
            textLien = uip_enreg2strIP(tNetIP, cote1 & ".netIP", cote1 & ".maskIP")
            nomLien = "NetIP." & Trim(.Fields(cote1 & ".idReseauIP")) ' identifie la forme Visio pour le lien
            If .Fields(cote1 & ".clnsIF") Then
                textLien = textLien & CR & "OSI"
            End If
            If IsNumeric(.Fields(cote1 & ".coutIf")) Then
            textLien = textLien & CR & "ospf cost " & .Fields(cote1 & ".coutIf")
                End If
 
          Set rtrObj1 = pageVisio.Shapes(nom1)
            Set rtrObj2 = pageVisio.Shapes(nom2)
 
            ' Utiliser la forme "LL" pour le lien
 
            ' s'il existe plusieurs liens entre les routeurs, décaler en "diagonale" le point de courbure
            ' sur l'axe des X du lien par pas de 0.05*(longueur du lien)
            ' sur l'axe des Y par pas de 5 mètres
 
            If (superpose) Then
                deltaXY = IIf((iLien Mod 2 = 0), 5 * (iLien \ 2), -5 * ((iLien + 1) \ 2))
                dX = deltaXY
                dY = deltaXY
            Else
                dX = 0
                dY = 0
            End If
            ' Raccorder le lien lienobj aux deux routeurs nom1 et nom2
            Set lienObj = ve_lierObjets(idPrj, pageVisio, nom1, nom2, "LL", nomLien, textLien, tVisioXY, dX, dY)
 
            ' Placer une étiquette à chaque extrémité du lien (adresse IP et nom d'interface)
            ' set extrObj1 = ve_etiqLien(idPrj, pageVisio, lienObj, "Connections.X2", nom1, "Connections.centre", nomEtiq1, textEtiq1, tVisioXY)
            ' set extrObj2 = ve_etiqLien(idPrj, pageVisio, lienObj, "Connections.X3", nom2, "Connections.centre", nomEtiq2, textEtiq2, tVisioXY)
 
            ' Corriger le positionnement des étiquettes avec CDxEtiq (décalage 1 étiquette sur 2)
            CDxEtiq = IIf(iLien = 1, 0, (iLien \ 2) Mod 2)
 
            '' CDxEtiq = 1
            DxEtiq = rtrObj1.Cells("Width").result(visMeters) * (1 + 0.7 * CDxEtiq)
            lienObj.Cells("Controls.X2").result(visMeters) = DxEtiq
            DxEtiq = lienObj.Cells("Width").result(visMeters) - (rtrObj2.Cells("Width").result(visMeters) * (1 + 0.5 * CDxEtiq))
            lienObj.Cells("Controls.X3").result(visMeters) = DxEtiq
 
            ' Appliquer la correction de positionnement à la seconde étiquette
            Set extrMaster = docVisio.Masters("Etiq")
            Set extrObj1 = pageVisio.Drop(extrMaster, 0, 0)
            extrObj1.Cells("LinePattern") = 0 ' supprimer le cadre de l'étiquette
            nomExtr1 = "." & .Fields(cote1 & ".adrIP4") & " (" & ve_AbrNomIf(.Fields(cote1 & ".nomIf")) & ")"
            extrObj1.Text = nomExtr1
            extrObj1.BringToFront
            Set extrObj2 = pageVisio.Drop(extrMaster, 0, 0)
            extrObj2.Cells("LinePattern") = 0 ' supprimer le cadre de l'étiquette
            nomExtr2 = "." & .Fields(cote2 & ".adrIP4") & " (" & ve_AbrNomIf(.Fields(cote2 & ".nomIf")) & ")"
            extrObj2.Text = nomExtr2
            extrObj2.BringToFront
 
            ' Coller les étiquettes sur le lien
            ' extrObj1.Cells("PinX").formula = "=PAR(PNT(" & lienObj.Name & "!connections.X5;" & lienObj.Name & "!connections.Y5))"
            ' extrObj1.Cells("PinY").formula = "=PAR(PNT(" & lienObj.Name & "!connections.X5;" & lienObj.Name & "!connections.Y5))"
            ' extrObj2.Cells("PinX").formula = "=PAR(PNT(" & lienObj.Name & "!connections.X6;" & lienObj.Name & "!connections.Y6))"
            ' extrObj2.Cells("PinY").formula = "=PAR(PNT(" & lienObj.Name & "!connections.X6;" & lienObj.Name & "!connections.Y6))"
            Set cellGlueFromBegin = extrObj1.Cells("EndX")
            Set cellGlueToObj1 = lienObj.Cells("Connections.X5")
            Set cellGlueFromEnd = extrObj2.Cells("EndX")
            Set cellGlueToObj2 = lienObj.Cells("Connections.X6")
            cellGlueFromBegin.GlueTo cellGlueToObj1
            cellGlueFromEnd.GlueTo cellGlueToObj2
        End With
        tNetIP.MoveNext
        iLien = iLien - 1
    Wend
    qNetIP.Close
    tNetIP.Close
    tVisioXY.Close
    docVisio.Save
    Call ve_FermerWindow(wndVisio)
End Function
 
Public Function ve_DrawContoursIP(objOLE As Control, nomPage As String, idPrj As Variant) As Boolean
    Dim ThisDb As database
    Dim tContour As Recordset, qContour As QueryDef
    Dim req As String
    Dim nom1 As String, nom2 As String, nomContour As String, CR As String
    Dim result As Boolean, superpose As Boolean
    Dim i As Integer, j As Integer, iContour As Integer, deltaXY As Integer
    Dim Left#, bottom#, Right#, Top#
 
    Dim docVisio As Visio.Document, pageVisio As Visio.page, wndVisio As Visio.window
    Dim ctrObj As Visio.Shape, ctrObj1 As Visio.Shape, ctrObj2 As Visio.Shape
    Dim rtrObj1 As Visio.Shape, rtrObj2 As Visio.Shape
    Dim selVisio As Visio.Selection
    Dim ctrMaster As Visio.Master
    Dim cellGlueFromBegin As Visio.Cell, cellGlueFromEnd As Visio.Cell
    Dim cellGlueToObj1 As Visio.Cell, cellGlueToObj2 As Visio.Cell
    Dim existePage As Boolean
 
    Set docVisio = objOLE.Object.Application.Documents(1)
    Set pageVisio = ve_OuvrirPage(objOLE, nomPage)
    Set wndVisio = ve_OuvrirWindow(pageVisio)
 
    Set ThisDb = CurrentDb
    Set qContour = ThisDb.QueryDefs("ve Map Contours IP")
    qContour.Parameters("SEl_idPrj") = idPrj
    Set tContour = qContour.OpenRecordset(dbOpenSnapshot)
    CR = Chr(13) + Chr(10)
 
    iContour = 0
    While Not tContour.EOF
        With tContour
            If (iContour <= 0) Then iContour = !nbRtrs
            nom1 = !nommageMat
            Set rtrObj1 = pageVisio.Shapes(nom1)
            wndVisio.Select rtrObj1, visSelect
            If (iContour = 1) Then
                Set selVisio = wndVisio.Selection
                Call selVisio.BoundingBox(visBBoxUprightWH, Left, bottom, Right, Top)
 
                Set ctrMaster = docVisio.Masters("ContourSite")
                Set ctrObj = pageVisio.Drop(ctrMaster, 0, 0)
                ctrObj.SendToBack
                nomContour = IIf(IsNull(!nomSite), !nommageSite, !nomSite)
                ctrObj.Text = nomContour
                ctrObj.Cells("TextBkgnd") = 2 ' fond blanc
                ctrObj.Cells("PinX") = Left + ((Right - Left) / 2)
                ctrObj.Cells("PinY") = bottom + ((Top - bottom) / 2)
                ctrObj.Cells("Height") = Top - bottom + 200
                ctrObj.Cells("Width") = Right - Left + 200
                wndVisio.DeselectAll
            End If
        End With
        tContour.MoveNext
        iContour = iContour - 1
    Wend
    qContour.Close
    tContour.Close
    docVisio.Save
    Call ve_FermerWindow(wndVisio)
End Function
 
Public Function ve_OuvrirPage(objOLE As Control, nomPage As String) As Visio.page
    Dim existePage As Boolean
    Dim i As Integer
    Dim docVisio As Visio.Document, pageVisio As Visio.page, wndVisio As Visio.window
    Dim wnd0Visio As Visio.window
 
    Set docVisio = objOLE.Object.Application.Documents(1)
 
    existePage = False
    For i = 1 To docVisio.Pages.count
        existePage = existePage Or (docVisio.Pages(i).Name = nomPage)
    Next
    If Not existePage Then
        Set pageVisio = docVisio.Pages(1)
        Set wnd0Visio = pageVisio.OpenDrawWindow
        wnd0Visio.Activate
        Set pageVisio = docVisio.Pages.Add
        pageVisio.Name = nomPage
        ' EB: ligne suivante mise en commentaire
     '   wnd0Visio.Close
     'Fin EB
    End If
 
    Set pageVisio = docVisio.Pages(nomPage)
    Set ve_OuvrirPage = pageVisio
End Function
 
Private Sub ve_FermerWindow(wndVisio As Visio.window)
    wndVisio.Close
End Sub
 
Public Function ve_OuvrirWindow(pageVisio As Visio.page)
    Dim wndVisio As Visio.window
 
    Set wndVisio = pageVisio.OpenDrawWindow
    wndVisio.Activate
    Set ve_OuvrirWindow = wndVisio
End Function
 
Public Sub ve_PoseObjet(idPrj, pageVisio As Visio.page, nomMaster$, nomObj, textObj, tVisioXY As Recordset, defX#, defY#)
    Dim masterVisio As Visio.Master
    Dim shpObj As Visio.Shape
    Dim posX As Double, posY As Double
    Dim i As Integer, j As Integer, result As Boolean
    Dim req As String
    Dim nomCellule As String, formula As String
 
    Set masterVisio = pageVisio.Document.Masters(nomMaster)
    Set shpObj = pageVisio.Drop(masterVisio, defX, defY)
    shpObj.Name = IIf(IsNull(nomObj), "", nomObj)
    shpObj.Text = IIf(IsNull(textObj), shpObj.Name, textObj)
 
    ' A-t-on des coordonnées enregistées pour l'objet ?
    req = "nomPage = '" & pageVisio.Name & "'"
    req = req & " AND nomMaster='" & nomMaster & "'"
    req = req & " AND nomObj='" & nomObj & "'"
    ' tVisioXY.MoveFirst
    tVisioXY.FindFirst (req)
 
    Do Until tVisioXY.NoMatch
        nomCellule = tVisioXY!nomCellule
        formula = tVisioXY!formula
        shpObj.Cells(nomCellule).formula = ve_2english(formula)
        tVisioXY.FindNext (req)
    Loop
End Sub
 
Public Function ve_lierObjets(idPrj, pageVisio As Visio.page, Obj1$, Obj2$, nomMaster$, nomLien$, textLien$, tVisioXY As Recordset, dX%, dY%) As Visio.Shape
    Dim req As String
    Dim formuleX As String, formuleY As String
    Dim lienObj As Visio.Shape, lienObj1 As Visio.Shape, lienObj2 As Visio.Shape
    Dim shpObj1 As Visio.Shape, shpObj2 As Visio.Shape
    Dim lienMaster As Visio.Master
    Dim cellGlueFromBegin As Visio.Cell, cellGlueFromEnd As Visio.Cell
    Dim cellGlueToObj1 As Visio.Cell, cellGlueToObj2 As Visio.Cell
    Dim nomCellule As String, formula As String, result As Long
 
    ' retrouver les objets Visio à partir de leurs noms
    Set shpObj1 = pageVisio.Shapes(Obj1)
    Set shpObj2 = pageVisio.Shapes(Obj2)
 
    ' Utiliser la forme master "LL" pour le lien
    Set lienMaster = pageVisio.Document.Masters("LL")
    Set lienObj = pageVisio.Drop(lienMaster, 0, 0)
    lienObj.SendToBack
    lienObj.Name = nomLien
    lienObj.Text = textLien
    lienObj.Cells("TextBkgnd") = 2 ' fond blanc
 
    ' Raccorder le lien lienobj aux centres, ie points "Connections.X1" des deux routeurs shpObj1 et shpObj2
    Set cellGlueFromBegin = lienObj.Cells("BeginX")
    Set cellGlueFromEnd = lienObj.Cells("EndX")
    Set cellGlueToObj1 = shpObj1.Cells("Connections.X1")
    Set cellGlueToObj2 = shpObj2.Cells("Connections.X1")
    cellGlueFromBegin.GlueTo cellGlueToObj1
    cellGlueFromEnd.GlueTo cellGlueToObj2
    Set ve_lierObjets = lienObj
 
    ' les delta dX et dY (connections.X1) sont utilisés pour éviter que plusieurs liens entre obj1 et obj2
    ' ne se superposent
    ' delta sur l'axe des X du lien par pas de 0.05*la longueur du lien
    ' delta sur l'axe des Y par pas de 5 mètres
    ' A-t-on des deltas mémorisés pour le lien (table VisioXY) ?
    req = "nomPage = '" & pageVisio.Name & "'"
    req = req & " AND nomMaster='" & nomMaster & "'"
    req = req & " AND nomObj='" & nomLien & "'"
    ' tVisioXY.MoveFirst
    tVisioXY.FindFirst (req)
 
    If tVisioXY.NoMatch Then
        lienObj.Cells("Controls.X1").formula = "Width*0." & Trim(Str(50 + dX))
        lienObj.Cells("Controls.Y1").result(visMeters) = dY
    Else
        Do Until tVisioXY.NoMatch
            nomCellule = tVisioXY!nomCellule
            formula = tVisioXY!formula
            result = tVisioXY!result
            ' lienObj.Cells(nomCellule) = CDbl(result)
            lienObj.Cells(nomCellule).formula = ve_2english(formula)
            tVisioXY.FindNext (req)
        Loop
    End If
 
End Function
 
Public Function ve_2english(frs As String) As String
'
' Traduit les formules de Visio francais à Visio anglais
' les mots traduits sont "Largeur", "Hauteur"
'
    Dim i As Integer, j As Integer, pos As Integer
    Dim debs As String, fins As String
    Dim ens As String
    Dim frMots As Variant, enWords As Variant
 
    frMots = Array("Largeur", "Hauteur")
    enWords = Array("Width", "Height")
    ens = frs
    For i = LBound(frMots) To UBound(frMots)
        pos = InStr(ens, frMots(i))
        If pos > 0 Then
            debs = Left(ens, pos - 1)
            fins = Right(ens, Len(ens) - (pos - 1) - Len(frMots(i)))
            ens = debs + enWords(i) + fins
        End If
    Next
    ve_2english = ens
End Function
 
Public Function ve_EtiqLien(idPrj, pageVisio As Visio.page, lienObj As Visio.Shape, lienCnx$, nomObj$, obkCnx$, nomEtiq$, textEtiq$, tVisioXY As Recordset) As Visio.Shape
    Dim etiqObj As Visio.Shape
    Dim etiqMaster As Visio.Master
 
 
    ve_EtiqLien = etiqObj
End Function
 
Public Sub ve_EtiqSchema(objOLE As Control, nomPage As String, idPrj As Variant)
    Dim ThisDb As database
    Dim tPrj As Recordset, req As String
    Dim docVisio As Visio.Document
    Dim pageVisio As Visio.page
    Dim wndVisio As Visio.window
    Dim masterVisio As Visio.Master
    Dim shpObj As Visio.Shape
    Dim CR As String
 
    CR = Chr(13) & Chr(10)
 
    Set docVisio = objOLE.Object.Application.Documents(1)
    Set pageVisio = ve_OuvrirPage(objOLE, nomPage)
    Set wndVisio = ve_OuvrirWindow(pageVisio)
 
    Set ThisDb = CurrentDb
    req = "SELECT * FROM Projet WHERE idPrj=" & idPrj
    Set tPrj = ThisDb.OpenRecordset(req)
 
    Set masterVisio = pageVisio.Document.Masters("Legende")
    Set shpObj = pageVisio.Drop(masterVisio, 1000, 400)
    shpObj.Text = tPrj!descPrj & "[" & tPrj!versPrj & "]" & CR & uip_champ(" ", Now, 0)
 
    Call ve_FermerWindow(wndVisio)
    tPrj.Close
End Sub
 
Public Function ve_AbrNomIf(nomIf As Variant) As String
    Dim pos As Integer
    Dim posSep As Integer
 
    If IsNull(nomIf) Then
        ve_AbrNomIf = ""
    Else
        posSep = InStr(nomIf, "/")
        If posSep = 0 Then posSep = Len(nomIf)
        pos = 0
        pos = InStr(Left(nomIf, posSep), "0")
        If pos = 0 Then pos = InStr(Left(nomIf, posSep), "1")
        If pos = 0 Then pos = InStr(Left(nomIf, posSep), "2")
        If pos = 0 Then pos = InStr(Left(nomIf, posSep), "3")
        If pos = 0 Then pos = InStr(Left(nomIf, posSep), "4")
        If pos = 0 Then pos = InStr(Left(nomIf, posSep), "5")
        If pos = 0 Then pos = InStr(Left(nomIf, posSep), "6")
        If pos = 0 Then pos = InStr(Left(nomIf, posSep), "7")
        If pos = 0 Then pos = InStr(Left(nomIf, posSep), "8")
        If pos = 0 Then
            ve_AbrNomIf = LCase(Mid(nomIf, 1, 2))
        Else
            ve_AbrNomIf = LCase(Mid(nomIf, 1, 2) & Mid(nomIf, pos))
        End If
    End If
End Function
 
Public Function ve_WrSchema(objOLE As Control, idPrj As Variant) As Boolean
    Dim ThisDb As database
    Dim NomBase As String, chemin As String, nomFic As String
    Dim i As Integer
    Dim docVisio As Visio.Document
    Dim pageVisio As Visio.page
    Dim wndVisio As Visio.window
 
    Set ThisDb = CurrentDb
    NomBase = Dir$(ThisDb.Name)
    chemin = ThisDb.Name
    chemin = Left$(chemin, InStr(chemin, NomBase) - 1)
    nomFic = chemin & "oNCS\Schema_" & idPrj & ".VSD"
 
    Set docVisio = objOLE.Object.Application.Documents(1)
    docVisio.SaveAs (nomFic)
    docVisio.Application.Quit
 
End Function