fjfhgdwfn 发表于 2006-5-25 15:24:00

[求助]多段线

一条多段线，如何等分。再在等分点上插入一个块

xinghesnak 发表于 2006-5-25 15:47:00

看看这个帖子

fjfhgdwfn 发表于 2006-5-25 16:29:00

         CommandSTR = "(Handent " "" & SsetObj.Item(i - 1).Handle & " "")"
          ThisDrawing.SendCommand "MEASURE" & vbCr & CommandSTR & vbCr & CStr(ds) & vbCr
在我这怎么用不了啊。

fjfhgdwfn 发表于 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 Num20 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

实现多段线等距插入图块。
页: [1]
查看完整版本: [求助]多段线