Discussion :

[Garruth]

Bonjour,

Je suis en train de programmer un petit script en VBA faisant les choses suivantes:
- sélection d'une polyligne sous Autocad 2013
- récupération de données de longueur sur Excel
- insertion d'un bloc au point correspondant à la longueur entrée sur la polyligne
Mais j'ai un point de blocage: comment déterminer le point d'insertion?
J'ai les données suivantes: la polyligne et la longueur
Je sais que ça doit exister (ex: création des tabulation sous covadis ou civil 3D) mais où??
En bonus si l'insertion peut se faire perpendiculairement à la polyligne


Merci d'avance!!!

Nicolas

[Garruth]

Salut,

Je me suis débrouillé , pour ceux que ça intéresse le code permettant l'insertion d'un bloc "CT" à un PK donné sur une polyligne.

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
 
Sub Insertion_sur_axe(AxePoly As AcadLWPolyline, Attval As String, PK As Double)
 
    Dim AcadApp As AcadApplication
    Dim AcadPlan As AcadDocument
    Dim PtInsert As Variant
'    Dim Attval As String
    Dim BlockInsert As AcadBlockReference
    Dim BlocAtt As AcadAttributeReference
'    Dim AxePoly As AcadLWPolyline
'    Dim PLObj As AcadEntity
'    Dim PtIns(0 To 2) As Double
'    Dim PK As Double
    Dim Coord As Variant
    Dim PolyPoints As Integer
    Dim DistanceParcourue As Double
    Dim i As Integer
    Dim X1 As Double
    Dim Y1 As Double
    Dim X2 As Double
    Dim Y2 As Double
    Dim LongSeg As Double
    Dim P1(0 To 2) As Double
    Dim P2(0 To 2) As Double
    Dim ObjCercle As AcadCircle
    Dim ObjLine As AcadLine
    Dim CoordCentre As Variant
    Dim AngInsert As Double
 
    DistanceParcourue = 0
 
    Set AcadApp = AcadApplication
    Set AcadPlan = AcadApp.ActiveDocument
 
'    Attval = "PK VI 1+044-0"
'    PK = 1044
'
'    Set AcadApp = AcadApplication
'    Set AcadPlan = AcadApp.ActiveDocument
'    AcadPlan.Utility.GetEntity PLObj, PtIns, "Sélectionner une polyligne"
'    While PLObj.ObjectName <> "AcDbPolyline"
'        AcadPlan.Utility.GetEntity PLObj, PtIns, "Ceci n'est pas une polyligne, sélectionner une polyligne"
'    Wend
'    Set AxePoly = PLObj
 
    Coord = AxePoly.Coordinates
    For i = 0 To UBound(Coord) - 3 Step 2
 
        If AxePoly.GetBulge(i / 2) <> 0 Then
 
            X1 = Coord(i)
            Y1 = Coord(i + 1)
            X2 = Coord(i + 2)
            Y2 = Coord(i + 3)
            LongSeg = 4 * Atn(Abs(AxePoly.GetBulge(i / 2))) * (Distance_Point(X1, Y1, X2, Y2) / 2) / Sin(2 * Atn(Abs(AxePoly.GetBulge(i / 2))))
            DistanceParcourue = DistanceParcourue + LongSeg
 
        Else
            X1 = Coord(i)
            Y1 = Coord(i + 1)
            X2 = Coord(i + 2)
            Y2 = Coord(i + 3)
            LongSeg = Distance_Point(X1, Y1, X2, Y2)
            DistanceParcourue = DistanceParcourue + LongSeg
 
        End If
        If DistanceParcourue > PK Then
 
            P1(0) = X1: P1(1) = Y1: P1(2) = 0
            P2(0) = X2: P2(1) = Y2: P2(2) = 0
            If AxePoly.GetBulge(i / 2) = 0 Then
                Set ObjCercle = AcadPlan.ModelSpace.AddCircle(P2, DistanceParcourue - PK)
                Set ObjLine = AcadPlan.ModelSpace.AddLine(P1, P2)
                PtInsert = ObjCercle.IntersectWith(ObjLine, acExtendNone)
                AngleInsert = ObjLine.Angle
                ObjCercle.Delete
                ObjLine.Delete
            Else
 
                Dim rayon As Double
                Dim bulge As Double
                Dim theta As Double
                Dim gamma As Double
                Dim phi As Double
                Dim PtTemp As Variant
                Dim ObjPoly As AcadPolyline
                Dim ObjLineTemp As AcadLine
                Dim AngDecal As Double
                Dim PolyPoint(0 To 5) As Double
 
                PolyPoint(0) = X1: PolyPoint(1) = Y1: PolyPoint(2) = 0
                PolyPoint(3) = X2: PolyPoint(4) = Y2: PolyPoint(5) = 0
 
                rayon = (Distance_Point(X1, Y1, X2, Y2) / 2) / Sin(2 * Atn(Abs(AxePoly.GetBulge(i / 2))))
                bulge = AxePoly.GetBulge(i / 2)
                theta = 4 * Atn(Abs(bulge))
                gamma = (WorksheetFunction.Pi - theta) / 2
                Set ObjLine = AcadPlan.ModelSpace.AddLine(P1, P2)
                If bulge > 0 Then
                    phi = ObjLine.Angle + gamma
                Else
                    phi = ObjLine.Angle - gamma
                End If
 
                ObjLine.Delete
                CoordCentre = AcadPlan.Utility.PolarPoint(P1, phi, rayon)
                AngDecal = (DistanceParcourue - PK) / LongSeg * theta
                Set ObjLine = AcadPlan.ModelSpace.AddLine(P2, CoordCentre)
                Set ObjPoly = AcadPlan.ModelSpace.AddPolyline(PolyPoint)
                ObjPoly.SetBulge 0, bulge
                If bulge > 0 Then AngDecal = AngDecal * -1
                ObjLine.Rotate CoordCentre, AngDecal
                PtInsert = ObjLine.IntersectWith(ObjPoly, acExtendOtherEntity)
                ObjLine.Delete
                ObjPoly.Delete
                Set ObjLine = AcadPlan.ModelSpace.AddLine(PtInsert, CoordCentre)
                AngleInsert = ObjLine.Angle + WorksheetFunction.Pi / 2
                ObjLine.Delete
 
            End If
            Exit For
        End If
 
    Next
 
 
    Set BlockInsert = AcadPlan.ModelSpace.InsertBlock(PtInsert, "CT", 1, 1, 1, 0)
    BlockInsert.Rotation = AngleInsert
    Set BlocAtt = BlockInsert.GetAttributes(0)
    BlocAtt.TextString = Attval
 
End Sub

Désolé, ce n'est pas commenté, je n'ai pas eu le temps!!!