请高手写代码，将一组曲线60等分将等分点连成59条等分线

清风明月10

请高手写代码，将一组曲线60等分将等分点连成59条等分线 这组曲线存在两种形式，一种是“川”字形，即曲线是呈竖向展布，绝对不交叉，且曲线方向保证它是同方向的，或者都是从上到下，或者都是从下到上。 第二种形式，是“三”字形，即曲线是呈横向展布，绝对不交叉，且曲线方向保证它是同方向的，或者都是从左到右，或者都是从右到左。 我要求是将每条线N（例如60）等分，再将第一个等分点连成一条简单多线，以此类推第2个、第3个……第N-1个。 曲线组若呈“川”字形，则将曲线组按X从小到大排序后，连等分线；曲线组若呈“三”字形，则将曲线组按Y值从大到小排序后，连等分线。

Free-Lancer

这个没有难度吧! 论坛有过这种程序

1. (defun c:tt (/ getdivpoints n pts1 pts2)
   
2.   (defun getdivpoints (e n / epam pams)
   
3.     (setq epam (vlax-curve-getdistatparam e (vlax-curve-getendparam e))
   
4.           pams (XD::Geom:NumDiv epam 0 n)
   
5.     )
   
6.     (mapcar '(lambda (x)
   
7.                (vlax-curve-getpointatdist e x)
   
8.              )
   
9.             pams
   
10.     )
    
11.   )
    
12.   (if (setq n (getint "\n等分数: "))
    
13.     (progn
    
14.       (XD::Begin)
    
15.       (while (and (setq ss (ssget '((0 . "*line"))))
    
16.                   (= (sslength ss) 2)
    
17.              )
    
18.         (setq pts1 (getdivpoints (ssname ss 0) n)
    
19.               pts2 (getdivpoints (ssname ss 1) n)
    
20.         )
    
21.         (mapcar        '(lambda (x y)
    
22.                    (xdrx_line_make x y)
    
23.                  )
    
24.                 pts1
    
25.                 pts2
    
26.         )
    
27.       )
    
28.       (xd::End)
    
29.     )
    
30.   )
    
31.   (princ)
    
32. )

(defun c:tt (/ getdivpoints n pts1 pts2)<br />   (defun getdivpoints (e n / epam pams)<br />     (setq epam (vlax-curve-getdistatparam e (vlax-curve-getendparam e))<br />           pams (XD::Geom:NumDiv epam 0 n)<br />     )<br />     (mapcar '(lambda (x)<br />                (vlax-curve-getpointatdist e x)<br />              )<br />             pams<br />     )<br />   )<br />   (if (setq n (getint "\n等分数: "))<br />     (progn<br />       (XD::Begin)<br />       (while (and (setq ss (ssget '((0 . "*line"))))<br />                   (= (sslength ss) 2)<br />              )<br />         (setq pts1 (getdivpoints (ssname ss 0) n)<br />               pts2 (getdivpoints (ssname ss 1) n)<br />         )<br />         (mapcar        '(lambda (x y)<br />                    (xdrx_line_make x y)<br />                  )<br />                 pts1<br />                 pts2<br />         )<br />       )<br />       (xd::End)<br />     )<br />   )<br />   (princ)<br /> )

清风明月10

我已经用VBA写出来了。不过还是要谢谢您，您的更好。等我有空将VBA代码贴出来

清风明月10

Sub 定数60等分任意框选的曲线并连线单线规律为沿X轴展布曲线组的叠合方向相反()
   Dim ARR1(), K, ARR2()  As Double, K2
'第一种方法：直接创建法
        Set D = CreateObject("scripting.dictionary")

   Const ds As Double = 60         '曲线上的取点间隔
    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) = "SPline"
     dataValue(0) = "*line"
    groupCode = gpCode
    dataCode = dataValue
'    SsetObj.Select acSelectionSetAll, , , groupCode, dataCode
    Dim mypnt1 As Variant
    Dim mypnt2  As Variant
    mypnt1 = ThisDrawing.Utility.GetPoint(, "请选择左下角点:")
    mypnt2 = ThisDrawing.Utility.GetCorner(mypnt1, "请选择右上角点:")
   
    SsetObj.Select acSelectionSetCrossing, mypnt1, mypnt2, groupCode, dataCode ' 使用Crossing选择模式，选择内部所有对象（包含边界本身）
    '打开文件用于存储曲线离散化后的点的坐标
    Rem Open "D:\curve.txt" For Output As #1
    Num1 = SsetObj.count
    Rem 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
    SsetPoint.Select acSelectionSetAll, , , groupCode, dataCode '将图中的点删除干净，因为后面会产生等分点
    SsetPoint.Erase '删除选择集中所有图元
    '在曲线上每隔一定距离取一个点，依次将点的坐标写入文件
    For i = 1 To Num1
        CommandSTR = "(Handent """ & SsetObj.Item(i - 1).Handle & """)"
        ThisDrawing.SendCommand "divide" & vbCr & CommandSTR & vbCr & CStr(ds) & vbCr
        SsetPoint.Select acSelectionSetAll, , , groupCode, dataCode
        Num2 = SsetPoint.count
        If Num2 <> 0 Then
            Rem ReDim Pt(Num2 - 1, 2) As Double
            For J = 0 To Num2 - 1
    Set PointObj = SsetPoint.Item(J)
    K = K + 1
    ReDim Preserve ARR1(1 To 5, 1 To K)
    ARR1(1, K) = i '是曲线的编号
    ARR1(2, K) = PointObj.Coordinates(0) '等分点的X坐标
    ARR1(3, K) = PointObj.Coordinates(1) '等分点的Y坐标
    'arr1(4,K)存储同一曲线等分点按X或Y排序后的顺序号
    'arr1(5,K)存储曲线组起点或终点按X或Y排序后的顺序号。必然是先求出arr1(4,K)，再根据所有曲线的第1个端点来排序定出曲线组的左右或上下顺序，这个顺序存储在一个字典中，方便取出。
                '最后画多段线时，arr1中的4行及5行分别按升序排列后，画PL线，4行中的序号一变，则画另1条线
            Next J
            SsetPoint.Erase '删除选择集中所有图元
            Rem Print #1, "第" & i & "条曲线"
            Rem For j = 0 To Num2 - 1
                Rem Print #1, Format(Pt(j, 0), "0.000"); " "; Format(Pt(j, 1), "0.000"); " "; Format(Pt(j, 2), "0.000")
            Rem Next j
        End If
    Next i
'    Close 1
    SsetObj.Delete
Dim SZPX As New 数组排序
ARR1 = SZPX.数组排序2维第1参数2行升升(ARR1, 1, 2)
Dim DBH '同一曲线中的点编号
DBH = 1
ARR1(4, 1) = DBH

For I1 = 2 To K
     If ARR1(1, I1) = ARR1(1, I1 - 1) Then
          DBH = DBH + 1
          ARR1(4, I1) = DBH
       Else
          DBH = 1
          ARR1(4, I1) = DBH
     End If
Next I1

ARR1 = SZPX.数组排序2维第1参数2行升升(ARR1, 4, 3) '即把每条曲线的第一个端点放在最前面,且第1端点按Y来排序
' 建立曲线组从上到下每条曲线的编号
  DBH = 1
  
  D(ARR1(1, 1)) = DBH
For I1 = 2 To K
     If ARR1(4, I1) = 1 Then '这里是比较端点的序号是否跳过了1
          DBH = DBH + 1
         D(ARR1(1, I1)) = DBH
       Else
         Exit For
     End If
Next I1

' 将曲线组从上到下每条曲线的编号放入ARR1(5, I1)中
For I1 = 1 To K
      ARR1(5, I1) = D(ARR1(1, I1))
Next I1
   
'  arr1中的4行及5行分别按升序排列
ARR1 = SZPX.数组排序2维第1参数2行升升(ARR1, 4, 5)
  K2 = K2 + 1
             ReDim Preserve ARR2(1 To K2)
           ARR2(K2) = ARR1(2, 1)
           K2 = K2 + 1
             ReDim Preserve ARR2(1 To K2)
           ARR2(K2) = ARR1(3, 1)
'最后画多段线时
  For I1 = 2 To K
      If ARR1(4, I1) = ARR1(4, I1 - 1) Then
'           往画多段线的数组中添加元素
            K2 = K2 + 1
             ReDim Preserve ARR2(1 To K2)
           ARR2(K2) = ARR1(2, I1)
           K2 = K2 + 1
             ReDim Preserve ARR2(1 To K2)
           ARR2(K2) = ARR1(3, I1)
       Else
'          说明到了另一线多段线的数据中，则前面的数级内容要画出一条多段线，之后将数级内容清空，再往数组中加入本次内容。
            ThisDrawing.ModelSpace.AddLightWeightPolyline (ARR2) '根据数组信息画轻多义线
            Erase ARR2
            K2 = 0
            '           往画多段线的数组中添加元素
              K2 = K2 + 1
               ReDim Preserve ARR2(1 To K2)
             ARR2(K2) = ARR1(2, I1)
             K2 = K2 + 1
               ReDim Preserve ARR2(1 To K2)
             ARR2(K2) = ARR1(3, I1)
     End If
Next I1
ThisDrawing.ModelSpace.AddLightWeightPolyline (ARR2) '根据数组信息画轻多义线，这句是因为最后NEXT循环没有经过“ELSE”段



   
End Sub

清风明月10

Sub 定数60等分任意框选的曲线并连线单线规律为沿Y轴展布曲线组的叠合方向相反()
   Dim ARR1(), K, ARR2()  As Double, K2
'第一种方法：直接创建法
        Set D = CreateObject("scripting.dictionary")

   Const ds As Double = 60         '曲线上的取点间隔
    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) = "SPline"
     dataValue(0) = "*line"
    groupCode = gpCode
    dataCode = dataValue
'    SsetObj.Select acSelectionSetAll, , , groupCode, dataCode
    Dim mypnt1 As Variant
    Dim mypnt2  As Variant
    mypnt1 = ThisDrawing.Utility.GetPoint(, "请选择左下角点:")
    mypnt2 = ThisDrawing.Utility.GetCorner(mypnt1, "请选择右上角点:")
   
    SsetObj.Select acSelectionSetCrossing, mypnt1, mypnt2, groupCode, dataCode ' 使用Crossing选择模式，选择内部所有对象（包含边界本身）
    '打开文件用于存储曲线离散化后的点的坐标
    Rem Open "D:\curve.txt" For Output As #1
    Num1 = SsetObj.count
    Rem 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
    SsetPoint.Select acSelectionSetAll, , , groupCode, dataCode '将图中的点删除干净，因为后面会产生等分点
    SsetPoint.Erase '删除选择集中所有图元
    '在曲线上每隔一定距离取一个点，依次将点的坐标写入文件
    For i = 1 To Num1
        CommandSTR = "(Handent """ & SsetObj.Item(i - 1).Handle & """)"
        ThisDrawing.SendCommand "divide" & vbCr & CommandSTR & vbCr & CStr(ds) & vbCr
        SsetPoint.Select acSelectionSetAll, , , groupCode, dataCode
        Num2 = SsetPoint.count
        If Num2 <> 0 Then
            Rem ReDim Pt(Num2 - 1, 2) As Double
            For J = 0 To Num2 - 1
    Set PointObj = SsetPoint.Item(J)
    K = K + 1
    ReDim Preserve ARR1(1 To 5, 1 To K)
    ARR1(1, K) = i '是曲线的编号
    ARR1(2, K) = PointObj.Coordinates(0) '等分点的X坐标
    ARR1(3, K) = PointObj.Coordinates(1) '等分点的Y坐标
    'arr1(4,K)存储同一曲线等分点按X或Y排序后的顺序号
    'arr1(5,K)存储曲线组起点或终点按X或Y排序后的顺序号。必然是先求出arr1(4,K)，再根据所有曲线的第1个端点来排序定出曲线组的左右或上下顺序，这个顺序存储在一个字典中，方便取出。
                '最后画多段线时，arr1中的4行及5行分别按升序排列后，画PL线，4行中的序号一变，则画另1条线
            Next J
            SsetPoint.Erase '删除选择集中所有图元
            Rem Print #1, "第" & i & "条曲线"
            Rem For j = 0 To Num2 - 1
                Rem Print #1, Format(Pt(j, 0), "0.000"); " "; Format(Pt(j, 1), "0.000"); " "; Format(Pt(j, 2), "0.000")
            Rem Next j
        End If
    Next i
'    Close 1
    SsetObj.Delete
Dim SZPX As New 数组排序
' ARR1 = SZPX.数组排序2维第1参数2行升升(ARR1, 1, 2)'这是单行沿X轴展布的写法
ARR1 = SZPX.数组排序2维第1参数2行升升(ARR1, 1, 3) '这是单行沿Y轴展布的写法
Dim DBH '同一曲线中的点编号
DBH = 1
ARR1(4, 1) = DBH

For I1 = 2 To K
     If ARR1(1, I1) = ARR1(1, I1 - 1) Then
          DBH = DBH + 1
          ARR1(4, I1) = DBH
       Else
          DBH = 1
          ARR1(4, I1) = DBH
     End If
Next I1
' '下面是是单行沿X轴展布的写法
' ARR1 = SZPX.数组排序2维第1参数2行升升(ARR1, 4, 3) '即把每条曲线的第一个端点放在最前面,且第1端点按Y来排序
''上面是是单行沿X轴展布的写法


'下面是是单行沿X轴展布的写法
ARR1 = SZPX.数组排序2维第1参数2行升升(ARR1, 4, 2) '即把每条曲线的第一个端点放在最前面,且第1端点按Y来排序
'上面是是单行沿X轴展布的写法
' 建立曲线组从上到下每条曲线的编号
  DBH = 1
  
  D(ARR1(1, 1)) = DBH
For I1 = 2 To K
     If ARR1(4, I1) = 1 Then '这里是比较端点的序号是否跳过了1
          DBH = DBH + 1
         D(ARR1(1, I1)) = DBH
       Else
         Exit For
     End If
Next I1

' 将曲线组从上到下每条曲线的编号放入ARR1(5, I1)中
For I1 = 1 To K
      ARR1(5, I1) = D(ARR1(1, I1))
Next I1
   
'  arr1中的4行及5行分别按升序排列
ARR1 = SZPX.数组排序2维第1参数2行升升(ARR1, 4, 5)
  K2 = K2 + 1
             ReDim Preserve ARR2(1 To K2)
           ARR2(K2) = ARR1(2, 1)
           K2 = K2 + 1
             ReDim Preserve ARR2(1 To K2)
           ARR2(K2) = ARR1(3, 1)
'最后画多段线时
  For I1 = 2 To K
      If ARR1(4, I1) = ARR1(4, I1 - 1) Then
'           往画多段线的数组中添加元素
            K2 = K2 + 1
             ReDim Preserve ARR2(1 To K2)
           ARR2(K2) = ARR1(2, I1)
           K2 = K2 + 1
             ReDim Preserve ARR2(1 To K2)
           ARR2(K2) = ARR1(3, I1)
       Else
'          说明到了另一线多段线的数据中，则前面的数级内容要画出一条多段线，之后将数级内容清空，再往数组中加入本次内容。
            ThisDrawing.ModelSpace.AddLightWeightPolyline (ARR2) '根据数组信息画轻多义线
            Erase ARR2
            K2 = 0
            '           往画多段线的数组中添加元素
              K2 = K2 + 1
               ReDim Preserve ARR2(1 To K2)
             ARR2(K2) = ARR1(2, I1)
             K2 = K2 + 1
               ReDim Preserve ARR2(1 To K2)
             ARR2(K2) = ARR1(3, I1)
     End If
Next I1
ThisDrawing.ModelSpace.AddLightWeightPolyline (ARR2) '根据数组信息画轻多义线，这句是因为最后NEXT循环没有经过“ELSE”段



   
End Sub

清风明月10

写好了，两套独立的，适用于所有情况

csharp

VBA 也可以引入 vlax-curve 类

清风明月10

csharp 发表于 2014-6-25 21:45
VBA 也可以引入 vlax-curve 类

这个没试过，能否贴上一可操作代码给我看看，研究学习一下

csharp

VBA 分坛有相关代码，我不会 VBA

Free-Lancer

子函数中应该是 vlax-curve-getpointatdist

hnjszbs

呵呵，我想领奖。

hnjszbs

高手如云啊！