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