'点集的边界
Sub PListToPLine()
Dim objSelected As Object
Dim P As AcadPoint
Dim PS As AcadSelectionSet
Dim PList() As Double
Dim PXY() As PointXY
Dim A() As Double
Dim L As AcadLine
Dim i As Long
Dim j As Long
On Error Resume Next
Dim o As Variant
o = ThisDrawing.Utility.GetPoint(, "指定边界内部一点")
Set PS = ThisDrawing.SelectionSets.Add("XXX")
'定义过滤机制
Dim filterType(0) As Integer
Dim filterData(0) As Variant
filterType(0) = 0
filterData(0) = "POINT"
PS.SelectOnScreen filterType, filterData
ReDim PList(PS.Count * 2 - 1)
ReDim A(PS.Count - 1)
ReDim PXY(PS.Count - 1)
'Prompt str(UBound(PList))
For Each objSelected In PS
If TypeOf objSelected Is AcadPoint Then
Set P = objSelected
PXY(i).x = P.Coordinates(0)
PXY(i).Y = P.Coordinates(1)
Set L = ThisDrawing.ModelSpace.AddLine(o, P.Coordinates)
'极角数组
A(i) = L.angle
i = i + 1
L.Delete
Else
'删除选择集
ThisDrawing.SelectionSets.item("XXX").Delete
End If
Next
Dim Atemp As Double
Dim Ptemp As PointXY
'按照顺时针对点进行排序
'根据极角排序
For i = 0 To UBound(A) - 1
For j = i To UBound(A)
If A(i) < A(j) Then
Atemp = A(i)
A(i) = A(j)
A(j) = Atemp
Ptemp = PXY(i)
PXY(i) = PXY(j)
PXY(j) = Ptemp
End If
Next j
Next i
For i = 0 To UBound(A)
PList(i * 2) = PXY(i).x
PList(i * 2 + 1) = PXY(i).Y
Next i
Dim Pl As AcadLWPolyline
Set Pl = ThisDrawing.ModelSpace.AddLightWeightPolyline(PList)
Pl.Closed = True
ThisDrawing.SelectionSets.item("XXX").Delete
Exit Sub
ErrControl:
MsgBox Err.Description
End Sub
Sub PListToPLine()
Dim objSelected As Object
Dim P As AcadPoint
Dim PS As AcadSelectionSet
Dim PList() As Double
Dim PXY() As PointXY
Dim A() As Double
Dim L As AcadLine
Dim i As Long
Dim j As Long
On Error Resume Next
Dim o As Variant
o = ThisDrawing.Utility.GetPoint(, "指定边界内部一点")
Set PS = ThisDrawing.SelectionSets.Add("XXX")
'定义过滤机制
Dim filterType(0) As Integer
Dim filterData(0) As Variant
filterType(0) = 0
filterData(0) = "POINT"
PS.SelectOnScreen filterType, filterData
ReDim PList(PS.Count * 2 - 1)
ReDim A(PS.Count - 1)
ReDim PXY(PS.Count - 1)
'Prompt str(UBound(PList))
For Each objSelected In PS
If TypeOf objSelected Is AcadPoint Then
Set P = objSelected
PXY(i).x = P.Coordinates(0)
PXY(i).Y = P.Coordinates(1)
Set L = ThisDrawing.ModelSpace.AddLine(o, P.Coordinates)
'极角数组
A(i) = L.angle
i = i + 1
L.Delete
Else
'删除选择集
ThisDrawing.SelectionSets.item("XXX").Delete
End If
Next
Dim Atemp As Double
Dim Ptemp As PointXY
'按照顺时针对点进行排序
'根据极角排序
For i = 0 To UBound(A) - 1
For j = i To UBound(A)
If A(i) < A(j) Then
Atemp = A(i)
A(i) = A(j)
A(j) = Atemp
Ptemp = PXY(i)
PXY(i) = PXY(j)
PXY(j) = Ptemp
End If
Next j
Next i
For i = 0 To UBound(A)
PList(i * 2) = PXY(i).x
PList(i * 2 + 1) = PXY(i).Y
Next i
Dim Pl As AcadLWPolyline
Set Pl = ThisDrawing.ModelSpace.AddLightWeightPolyline(PList)
Pl.Closed = True
ThisDrawing.SelectionSets.item("XXX").Delete
Exit Sub
ErrControl:
MsgBox Err.Description
End Sub
|
暂时没有评论
发表评论 - 不要忘了输入验证码哦! |