[求助]多段线

fjfhgdwfn

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

xinghesnak

看看这个帖子

http://bbs.mjtd.com/forum.php?mod=viewthread&tid=11775

fjfhgdwfn

         CommandSTR = "(Handent " "" & SsetObj.Item(i - 1).Handle & " "")"
          ThisDrawing.SendCommand "MEASURE" & vbCr & CommandSTR & vbCr & CStr(ds) & vbCr

 在我这怎么用不了啊。

fjfhgdwfn

 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
 

实现多段线等距插入图块。