Polylignes par calcul ou par saisie

C'est parti, on parle un peu moins de théorie et on se consacre à ce qu'on préfère : dessiner par programmation.

Dessiner par saisie des sommets à l'écran

Le premier exemple va permettre de dessiner une polyligne suite à une série de clics à l'écran graphique, avec ou sans accrochage objets, et de restituer une polyligne reliant tous ces points qui seront les sommets de la polyligne.

La principale difficulté est de fournir un tableau de points cohérent avec l'attente de VBA pour dessiner une polyligne, en effet comme il a été vu dans les tableaux il va falloir redimensionner le tableau des points saisis avant le dessin.

N'aimant pas le mélange des genres, je fais une FUNCTION qui va s'occuper du tableau et une SUB qui va s'occuper de la saisie et du dessin, le programme jonglant (de façon transparente) entre les deux pour in fine avec les bonnes données.

La fonction :

Private Function Ajout_Pt2D_Tableau(P1 As Variant, TabCoord) As Variant
Dim Tableau() As Double
Dim NbVal As Integer

     If IsEmpty(TabCoord) Then
          ReDim Tableau(0 To 1)
          Tableau(0) = P1(0)
          Tableau(1) = P1(1)
          Else
          Tableau = TabCoord
          NbVal = UBound(Tableau)
          ReDim Preserve Tableau(0 To NbVal + 2)
          Tableau(NbVal + 1) = P1(0)
          Tableau(NbVal + 2) = P1(1)
          End If

Ajout_Pt2D_Tableau = Tableau

End Function

Cette function attend donc un point en variant et renvoie un tableau à deux dimensions.

La SUB maintenant :

Sub TracerPolClics()
Dim Pt As Variant
Dim TabCoordonnees As Variant

     Do 'début de la boucle de saisie des points l'écran
          Pt = ThisDrawing.Utility.GetPoint(, "Cliquer un point ou Enter pour terminer")
          TabCoordonnees = Ajout_Pt2D_Tableau(Pt, TabCoordonnees)

On Error GoTo END_DO 'Sortie de la boucle de saisie si ENTER ou autre touche
Loop 'Fin de la boucle de saisie des points l'écran
END_DO:

ThisDrawing.ModelSpace.AddLightWeightPolyline TabCoordonnees

End Sub

Voici le rendu en copie d'écran :

Animation dessin poly par clics

La méthode AppendVertex

Bon c'est déjà bien de pouvoir dessiner notre polyligne mais ça ne me semble pas entièrement satisfaisant.
Le dessin n'étant réalisé qu'à la fin de la sélection du dernier point, ce n'est pas très "parlant" pour l'utilisateur.
Passons la vitesse supérieure pour dessiner une polyligne comme AutoCAD le fait en natif, mais toujours avec VBA.
La façon de faire est plus simple, pas de fonction, pas de gestion de tableau, le principe est de dessiner une polyligne de deux vertex (sommets) puis à chaque clic (point sélectionné à l'écran) rajouter un vertex.
C'est tellement simple qu'à la fin j'ajoute un affichage qui renseigne sur la longueur de la polyligne dessinée.
Exercice pour vous : Indiquez le nombre de sommets dans cette MsgBox, si vous rencontrez des soucis... pensez au formulaire de contact, je suis caché derrière.

Voici le code :

Sub TracerPolClics2()
     Dim pointDepart As Variant
     Dim pointClic As Variant
     Dim pointClicTab(0 To 5) As Double
     Dim polyObjet As AcadPolyline

     pointDepart = ThisDrawing.Utility.GetPoint(, "Choix du point de départ : ")
     On Error Resume Next
     pointClic = ThisDrawing.Utility.GetPoint(pointDepart, "Choix du point suivant : ")
     If Err Then GoTo SubEnd
          pointClicTab(0) = pointDepart(0)
          pointClicTab(1) = pointDepart(1)
          pointClicTab(2) = pointDepart(2)
          pointClicTab(3) = pointClic(0)
          pointClicTab(4) = pointClic(1)
          pointClicTab(5) = pointClic(2)
          Set polyObjet = ThisDrawing.ModelSpace.AddPolyline(pointClicTab)
          While IsNull(pointClic) = False
                   pointClic = ThisDrawing.Utility.GetPoint(pointClic, "Choix du point suivant : ")
                   If Err Then GoTo SubEnd
                            polyObjet.AppendVertex pointClic
                            ThisDrawing.Regen (acActiveViewport)
          Wend
SubEnd: ' Sortie de la commande si echap
MsgBox "création poly de longueur :" & polyObjet.Length, , "Poly via da-code.fr"

End Sub

Ce qui donne quelque chose de plus satisfaisant, en vidéo :

Animation du dessin de polyligne par points écran

Dessiner une polyligne dont les sommets sont calculés

Pour terminer (provisoirement si vous avez des sujets à me proposer) je vais calculer une liste de sommets puis les injecter dans un tableau et ce tableau en faire une polyligne.

Le genre de calcul que j'ai choisi de prendre est la progression des sinus, ça dessine une jolie vague et ça parle à tout le monde, c'est un principe, un exemple, à vous de l'adapter à votre profession et vos dessins favoris.

Le rendu ce sera ça, avouez que ça pète !

Donc on commence par déclarer les variables, en fixant une variation de -pi à pi, un nombre de points, et une boucle qui va calculer chaque Y en fonction de l'accroissement de la valeur angulaire exprimée dans la variable "a", à chaque tout on passe par la fonction déjà proposée de redimensionnement du tableau et quand elle est bouclée, on injecte le tout dans l'objet polyligne. On est OK ?
Le code :

Sub Trace_Poly_Sinus()
     Dim X As Double, Y As Double, a As Double, a2 As Double
     Dim polyObj As AcadLWPolyline
     Dim i As Integer, numpts As Integer
     Dim tabcoordonnees
     Dim P1(0 To 1) As Double

a = -3.14159265358979
a2 = 3.14159265358979 / 20

     numpts = 40
     numpts = numpts + 1
     ReDim pt(1 To numpts * 2)

     For i = 0 To 40
         P1(0) = i
         P1(1) = 3 * Sin(a)
         tabcoordonnees = AjtPt(P1, tabcoordonnees)
         a = a + a2
     Next

Set polyObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(tabcoordonnees)
polyObj.Update
End Sub

Retour au Menu VBA

Haut de page

Page Suivante (pas encore) page)

Création le 21 mai 2021