Yves
Guest
|
 Posted:
Wed Dec 08, 2004 8:31 pm Post subject:
Re: Flattening 3D splines |
|
|
Here is what I have for 3D polyline... it's better and faster than Flatten!
Not much conversion is need for IAcadSpline.
Sub PolyConv2D()
Dim Sset As AcadSelectionSet, ent As AcadEntity
Dim cadObject As AcadEntity, pt1(0 To 2) As Double, pt2(0 To 2) As
Double
Dim obj3DPline As Acad3DPolyline, Pts() As Double, nmbPts As Integer
Dim PTWorld As Variant, OCSNorm, DeltaX As Double, deltaY As Double,
DeltaZ As Double
Dim objpline As AcadPolyline, t As Double, intX As Double, intY As
Double
Dim objPt As AcadPoint, pt(0 To 2) As Double, i As Integer, elev As
Double
Dim LayName As String, lWeight As Integer
Dim test, j As Integer
Set Sset = Nothing
Set Sset = ThisDrawing.PickfirstSelectionSet
Sset.Clear
Sset.Select acSelectionSetAll
'convertis toute les polylines 3D en 2D à l'élévation 0 (Zéro)
'elev = InputBox("Elevation : ", , 4500)
For Each ent In Sset
If TypeName(ent) = "IAcad3DPolyline" Then
j = j + 1
Set obj3DPline = ent
nmbPts = UBound(obj3DPline.Coordinates)
ReDim Pts(nmbPts)
'get points pt1 and pt2 of each segments
For i = 0 To nmbPts Step 3
Pts(i) = obj3DPline.Coordinates(i)
Pts(i + 1) = obj3DPline.Coordinates(i + 1)
Pts(i + 2) = 0
Next
'pour mettre les nouvelles poly sur le bon layer
LayName = ent.layer
lWeight = ent.Lineweight
ent.Delete
Set objpline = ThisDrawing.ModelSpace.AddPolyline(Pts)
'applique le layer couleur et lineweight
With objpline
.layer = LayName
.Color = acByLayer
.Lineweight = lWeight
End With
End If
Next
MsgBox (j & " , 3d poly changées")
End Sub
"KeithXP" <keith@dummyaddress.com> a écrit dans le message de news:
41b6ec1f_3@newsprd01...
| Quote: | Can anyone point me toward to routine that will successfully flatten 3D
Splines.
We sometimes get surveyors drawings with contours drawn this way, and
neither FLATTEN nor another utility I have tried FLATTEN.LSP will work.
thanks
Keith
|
|
|
FAQ
Memberlist
Register
Profile
Log in to check your private messages
Log in