|
|
发表于 2006-5-25 17:00:00
|
显示全部楼层
Sub GetPointOfPline()
Const ds As Double = 50 '曲线上的取点间隔
Const bb As String = "1" '块名
Dim SsetObj As AcadSelectionSet '选择集对象
Dim SsetPoint As AcadSelectionSet '点选择集
Dim SsetName As String '选择集名称
Dim PointObj As AcadPoint '点对象
Dim CommandSTR As String
Dim Pt() As Double '点坐标
Dim i As Integer, j As Integer
Dim Num1 As Integer, Num2 As Integer
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
Dim groupCode As Variant, dataCode As Variant
'选择集名称
SsetName = "SplineSet"
'建立选择集
On Error Resume Next
Set SsetObj = ThisDrawing.SelectionSets.Add(SsetName)
If Err Then
Set SsetObj = ThisDrawing.SelectionSets.Item(SsetName)
SsetObj.Clear
Err.Clear
End If
On Error GoTo 0
'将曲线添加到选择集
gpCode(0) = 0
dataValue(0) = "LWPOLYLINE"
groupCode = gpCode
dataCode = dataValue
' SsetObj.Select acSelectionSetAll, , , groupCode, dataCode
SsetObj.SelectOnScreen groupCode, dataCode
' MsgBox SsetObj.Count
'打开文件用于存储曲线离散化后的点的坐标
' Open "D:\curve.txt" For Output As #1
Num1 = SsetObj.Count
' Print #1, "曲线数目：" & Num1
'选择集名称
SsetName = "PointSet"
'建立选择集
On Error Resume Next
Set SsetPoint = ThisDrawing.SelectionSets.Add(SsetName)
If Err Then
Set SsetPoint = ThisDrawing.SelectionSets.Item(SsetName)
SsetPoint.Clear
Err.Clear
End If
On Error GoTo 0
'将全部点添加到选择集
gpCode(0) = 0
dataValue(0) = "point"
groupCode = gpCode
dataCode = dataValue
Dim blockRefObj As AcadBlockReference
Dim insertionPnt(0 To 2) As Double
'在曲线上每隔一定距离取一个点，依次将点的坐标写入文件
For i = 1 To Num1
CommandSTR = "(Handent """ & SsetObj.Item(i - 1).Handle & """ ) "
ThisDrawing.SendCommand "MEASURE" & vbCr & CommandSTR & vbCr & CStr(ds) & vbCr
SsetPoint.Select acSelectionSetAll, , , groupCode, dataCode
Num2 = SsetPoint.Count
If Num2 0 Then
ReDim Pt(Num2 - 1, 2) As Double
For j = 0 To Num2 - 1
Set PointObj = SsetPoint.Item(j)
Pt(j, 0) = PointObj.Coordinates(0)
Pt(j, 1) = PointObj.Coordinates(1)
Pt(j, 2) = PointObj.Coordinates(2)
Next j
SsetPoint.Erase '删除选择集中所有图元
'Print #1, "第" & i & "条曲线"
For j = 0 To Num2 - 1
' Print #1, Format(Pt(j, 0), "0.000"); ""; Format(Pt(j, 1), "0.000"); ""; Format(Pt(j, 2), "0.000")
insertionPnt(0) = Pt(j, 0)
insertionPnt(1) = Pt(j, 1)
insertionPnt(2) = Pt(j, 2)
Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock _
(insertionPnt, bb, 1#, 1#, 1#, 0)
Next j
End If
Next i
Close 1
SsetObj.Delete
End Sub
实现多段线等距插入图块。 |
|
置顶卡
