|
|
贴上源代码如下，问题是红色部分设了断点分段执行，生成的txt中会有数据，如果不分步执行，生成的txt就是空的，求教
Private Sub getcorxy()
Const ds As Double = 30 '曲线上的取点间隔
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 = "PolyLine"
'建立选择集
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) = "polyLine" ' 表示对象类型是“polyLine”
groupCode = gpCode
dataCode = dataValue
SsetObj.Select acSelectionSetAll, , , groupCode, dataCode
'打开文件用于存储曲线离散化后的点的坐标
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 newlayer As AcadLayer '增加一个新图层放生成的点
Set newlayer = ThisDrawing.Layers.Add("DivPoint")
ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item("DivPoint")
'在曲线上每隔一定距离取一个点，依次将点的坐标写入文件
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")
Next j
End If
Next i
Close 1
SsetObj.Delete
End Sub |
|
置顶卡
