清风明月名字 发表于 2014-6-25 09:38:44

求代码，将一组曲线60等分将等分点连成59条等分线

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

清风明月名字 发表于 2014-6-25 21:26:19

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 mypnt2As 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



清风明月名字 发表于 2014-6-25 21:27:22

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 mypnt2As 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


清风明月名字 发表于 2014-6-25 21:27:57

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

mycad 发表于 2015-5-19 11:29:00

顶！！！！！！！！！

zzyong00 发表于 2015-5-19 22:11:34

把图中原来所有的点都删掉？万一原图中哪些点有用呢
vlax-curve-getEndPoint '取结尾点
vlax-curve-getDistAtPoint‘得曲线长度
d=曲线长度/N ' N等分
vlax-curve-getPointAtDist d*xx 1~N    '取N等分各点坐标
连线。。。。
页: [1]
查看完整版本: 求代码，将一组曲线60等分将等分点连成59条等分线