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 |
Partager