Community
Since you only need part of the polyline to be "copied", you cannot use AcadEntity/AcadLWPolyline.Copy() to get what you want.
You need to create a new poyline based on the vertices of the partial polyline, up to the point where the partial polyline ends. So, you need to obtain a point on the polyline where the the partial polyline ends and then count each vertex from one end of the polyline all the way to the point. Now you have all the vertices of the new polyline, you simply create a new polyline with AcadModelSpace/PaperSpace.AddLightWeightPolyline().
The steps of doing it could be like these:
1. You ask user to pick a point on the polyline. You may want to validtate the picked point to make sure it exactly sits on the poilyline by using IntersectWith() to test an AcadPoint with the polyline;
2. use AcadLWPolyline.Coordinates to obtain the veritces of the polyline;
3. add up the distance from one end of the polyline, vertext by vertex. For each vertex being added, also try to add the point to compare the increased distance, so that you can decide whether the point is between 2 vertices. If yes, the partial polyline ends at the point. Now you have all the vertices of the new polyline.
4. use AcadModelSpace/PaperSpace.AddLightWeightPolyline() to create the "partial" polyline.
I have not worked with AutoCAD VBA for quite a while, thus a bit rusty with VBA code. But I wrote following code to do what you want. Some explanation:
1. I used AcadUtility.GetEntity() instead of GetPoint(), because GetEntity() allows the code to return the picked point along with the entity being selected. This way, the point reurned is guaranteed sitting on the entity. However, based on your need, you may still use GetPoint() to obtain the point, and if so, you need to make sure the point sits on the polyline;
2. In order to tell picked point is between which 2 vertices (so that you can cut off the rest of polyline), I used method Distance(A, B)=Distance(A,C) + Distance(C,B) to determine if point C is on a line between A and B. There are other way to determine if a point is on a line. Googling the web would give you some links.
Option Explicit
Public Sub CopyPartialPolyline()
Dim poly As AcadLWPolyline
Dim point As Variant
'' Pick polyline and a point on the polyline
PickPolyline poly, point
If poly Is Nothing Then
ThisDrawing.Utility.Prompt vbCr & "*Cancel*"
Exit Sub
End If
'' Get vertices of selected polyline
Dim points() As Variant
GetVertices poly, points
MsgBox (UBound(points) + 1) & " verices!"
''Get partial polyline vertices
Dim newPoints() As Variant
If Not GetPartialVertices(points, point, newPoints) Then
MsgBox "Picked point is not on polyline!"
ThisDrawing.Utility.Prompt vbCr & "*Cancel*"
Exit Sub
End If
'' drawing the partial polyline
DrawingPartialPolyline newPoints
End Sub
Private Sub PickPolyline(pline As AcadLWPolyline, pt As Variant)
Set pline = Nothing
Dim ent As AcadEntity
Dim point As Variant
On Error Resume Next
Do
ThisDrawing.Utility.GetEntity ent, point, vbCr & "Pick a point on a polyline:"
If Err Then Exit Do
If TypeOf ent Is AcadLWPolyline Then
Set pline = ent
pt = point
Exit Do
Else
ThisDrawing.Utility.Prompt vbCr & "Invalid pick: not a polyline!"
Set ent = Nothing
End If
Loop While ent Is Nothing
On Error GoTo 0
End Sub
Private Sub GetVertices(poly As AcadLWPolyline, points() As Variant)
Dim coords As Variant
coords = poly.Coordinates
Dim count As Integer
count = (UBound(coords) + 1) / 2 - 1
ReDim points(0 To count)
Dim pt(0 To 1) As Double
Dim i As Integer
Dim j As Integer
For i = 0 To UBound(coords) Step 2
pt(0) = coords(i)
pt(1) = coords(i + 1)
points(j) = pt
j = j + 1
Next
End Sub
Private Function GetPartialVertices( _
vertices As Variant, _
point As Variant, newPts() As Variant) As Boolean
Dim startP(0 To 1) As Double
Dim endP(0 To 1) As Double
Dim i As Integer
For i = 0 To UBound(vertices) - 1
ReDim Preserve newPts(i)
startP(0) = vertices(i)(0): startP(1) = vertices(i)(1)
endP(0) = vertices(i + 1)(0): endP(1) = vertices(i + 1)(1)
If i = 0 Then
newPts(i) = startP
Else
If IsPointOnSegment(startP, endP, point) Then
newPts(i) = startP
endP(0) = point(0): endP(1) = point(1)
ReDim Preserve newPts(i + 1)
newPts(i + 1) = endP
GetPartialVertices = True
Exit Function
Else
newPts(i) = startP
End If
End If
Next
GetPartialVertices = False
End Function
Private Function IsPointOnSegment( _
startP As Variant, endP As Variant, _
point As Variant, Optional tolerance As Double = 0.001) As Boolean
Dim dist1 As Double
Dim dist2 As Double
Dim dist As Double
dist = DistBetweenPoints(startP, endP)
dist1 = DistBetweenPoints(startP, point)
dist2 = DistBetweenPoints(point, endP)
Dim diff As Double
diff = Abs(dist - dist1 - dist2)
IsPointOnSegment = diff <= tolerance
End Function
Private Function DistBetweenPoints(pt1 As Variant, pt2 As Variant) As Double
Dim dX As Double
dX = Abs(pt2(0) - pt1(0))
Dim dy As Double
dy = Abs(pt2(1) - pt1(1))
DistBetweenPoints = Sqr(dX * dX + dy * dy)
End Function
Private Sub DrawingPartialPolyline(vertices As Variant)
Dim coords() As Double
Dim count As Integer
count = (UBound(vertices) + 1) * 2
ReDim coords(0 To count - 1)
Dim i As Integer
Dim j As Integer
For i = 0 To UBound(vertices)
j = i * 2
coords(j) = vertices(i)(0)
coords(j + 1) = vertices(i)(1)
Next
Dim pline As AcadLWPolyline
Set pline = ThisDrawing.ModelSpace.AddLightWeightPolyline(coords)
Dim fromPt(0 To 2) As Double
Dim toPt(0 To 2) As Double
fromPt(0) = coords(0): fromPt(1) = coords(1): fromPt(2) = 0#
toPt(0) = 0#: toPt(1) = 0#: toPt(2) = 0#
pline.Move fromPt, toPt
pline.Update
End Sub
I am not sure I understand your further question correctly: now you want to get 2 points on a polyline, and then recreate the portion of polyline between the 2 points.
If this is what you want to do, you simply find a way to count the polyline's vertices between the 2 points, then in conjunction with the 2 points, you now have a new set of vertex points that can be used to create needed polyline. If you want the new polyline's vertices created in the order that the first point as start point and the second point as end point, you just need to pay attention to how the vertices in between is added.
If you have understood the code clearly I replied previously, you can easily find out the vertices between the 2 points. I went ahead with some modifictions to the previous code, as shown below:
Option Explicit
Public Sub CopyPartialPolyline2()
Dim poly As AcadLWPolyline
Dim startPt As Variant
Dim endPt
PickPolyline poly, startPt, endPt
If poly Is Nothing Then
ThisDrawing.Utility.Prompt vbCr & "*Cancel*"
Exit Sub
End If
'' Get vertices of selected polyline
Dim points() As Variant
GetVertices poly, points
''Get partial polyline vertices
Dim newPoints() As Variant
If Not GetPartialVertices(points, startPt, endPt, newPoints) Then
MsgBox "Picked point is not on polyline!"
ThisDrawing.Utility.Prompt vbCr & "*Cancel*"
Exit Sub
End If
'' drawing the partial polyline
DrawingPartialPolyline newPoints
End Sub
Private Sub PickPolyline(pline As AcadLWPolyline, ptStart As Variant, ptEnd As Variant)
Set pline = Nothing
Dim ent As AcadEntity
Dim point As Variant
On Error Resume Next
''Pick first point on the polyline
Do
ThisDrawing.Utility.GetEntity ent, point, vbCr & "Pick first point on a polyline:"
If Err Then
Set pline = Nothing
Exit Do
End If
If TypeOf ent Is AcadLWPolyline Then
Set pline = ent
ptStart = point
Exit Do
Else
ThisDrawing.Utility.Prompt vbCr & "Invalid pick: not a polyline!"
Set ent = Nothing
End If
Loop While ent Is Nothing
''pick econd point o the polyline
If Not pline Is Nothing Then
Do
ThisDrawing.Utility.GetEntity ent, point, vbCr & "Pick second point on a polyline:"
If Err Then
Set pline = Nothing
Exit Do
End If
If TypeOf ent Is AcadLWPolyline Then
If ent.Handle = pline.Handle Then
ptEnd = point
Exit Do
Else
ThisDrawing.Utility.Prompt vbCr & "Invalid pick: point not on the same polyline!"
Set ent = Nothing
End If
Else
ThisDrawing.Utility.Prompt vbCr & "Invalid pick: not a polyline!"
Set ent = Nothing
End If
Loop While ent Is Nothing
End If
On Error GoTo 0
End Sub
Private Sub GetVertices(poly As AcadLWPolyline, points() As Variant)
Dim coords As Variant
coords = poly.Coordinates
Dim count As Integer
count = (UBound(coords) + 1) / 2 - 1
ReDim points(0 To count)
Dim pt(0 To 1) As Double
Dim i As Integer
Dim j As Integer
For i = 0 To UBound(coords) Step 2
pt(0) = coords(i)
pt(1) = coords(i + 1)
points(j) = pt
j = j + 1
Next
End Sub
Private Function GetPartialVertices( _
vertices As Variant, startPt As Variant, _
endPt As Variant, newPts() As Variant) As Boolean
Dim startIndex As Integer
startIndex = FindVertexIndex(vertices, startPt)
Dim endIndex As Integer
endIndex = FindVertexIndex(vertices, endPt)
If startIndex = -1 Or endIndex = -1 Then
GetPartialVertices = False
Exit Function
End If
Dim sameOrder As Boolean
If startIndex > endIndex Then
'' The direction from fist point to second point is
'' different from the polyline's vertices order
endIndex = endIndex + 1
sameOrder = False
Else
'' The direction from fist point to second point is
'' the same as the polyline's vertices order
startIndex = startIndex + 1
sameOrder = True
End If
''Create vertex point array for the partial polyline
Dim pt(0 To 1) As Double
Dim arrayCount As Integer
Dim i As Integer
'' Start point
arrayCount = 0
ReDim Preserve newPts(arrayCount)
pt(0) = startPt(0): pt(1) = startPt(1)
newPts(arrayCount) = pt
'' points in between
If sameOrder Then
For i = startIndex To endIndex Step 1
arrayCount = arrayCount + 1
ReDim Preserve newPts(arrayCount)
pt(0) = vertices(i)(0): pt(1) = vertices(i)(1)
newPts(arrayCount) = pt
Next
Else
For i = startIndex To endIndex Step -1
arrayCount = arrayCount + 1
ReDim Preserve newPts(arrayCount)
pt(0) = vertices(i)(0): pt(1) = vertices(i)(1)
newPts(arrayCount) = pt
Next
End If
'' End point
arrayCount = arrayCount + 1
ReDim Preserve newPts(arrayCount)
pt(0) = endPt(0): pt(1) = endPt(1)
newPts(arrayCount) = pt
GetPartialVertices = True
End Function
Private Function FindVertexIndex(vertices As Variant, point As Variant) As Integer
Dim pt1(0 To 1) As Double
Dim pt2(0 To 1) As Double
Dim i As Integer
For i = 0 To UBound(vertices)
pt1(0) = vertices(i)(0): pt1(1) = vertices(i)(1)
pt2(0) = vertices(i + 1)(0): pt2(1) = vertices(i + 1)(1)
If IsPointOnSegment(pt1, pt2, point) Then
FindVertexIndex = i
Exit Function
End If
Next
FindVertexIndex = -1
End Function
Private Function IsPointOnSegment( _
startP As Variant, endP As Variant, _
point As Variant, Optional tolerance As Double = 0.001) As Boolean
Dim dist1 As Double
Dim dist2 As Double
Dim dist As Double
dist = DistBetweenPoints(startP, endP)
dist1 = DistBetweenPoints(startP, point)
dist2 = DistBetweenPoints(point, endP)
Dim diff As Double
diff = Abs(dist - dist1 - dist2)
IsPointOnSegment = diff <= tolerance
End Function
Private Function DistBetweenPoints(pt1 As Variant, pt2 As Variant) As Double
Dim dX As Double
dX = Abs(pt2(0) - pt1(0))
Dim dy As Double
dy = Abs(pt2(1) - pt1(1))
DistBetweenPoints = Sqr(dX * dX + dy * dy)
End Function
Private Sub DrawingPartialPolyline(vertices As Variant)
Dim coords() As Double
Dim count As Integer
count = (UBound(vertices) + 1) * 2
ReDim coords(0 To count - 1)
Dim i As Integer
Dim j As Integer
For i = 0 To UBound(vertices)
j = i * 2
coords(j) = vertices(i)(0)
coords(j + 1) = vertices(i)(1)
Next
Dim pline As AcadLWPolyline
Set pline = ThisDrawing.ModelSpace.AddLightWeightPolyline(coords)
Dim fromPt(0 To 2) As Double
Dim toPt(0 To 2) As Double
fromPt(0) = coords(0): fromPt(1) = coords(1): fromPt(2) = 0#
toPt(0) = 0#: toPt(1) = 0#: toPt(2) = 0#
pline.Move fromPt, toPt
pline.Update
End Sub
![Autodesk Design & Make Report](https://forums.autodesk.com/t5/image/serverpage/image-id/1350519iCB55845EBFC43016/image-size/large?v=v2&px=999" "Autodesk Design & Make Report")
