明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 1925|回复: 5

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

[复制链接]
发表于 2014-6-25 09:38 | 显示全部楼层 |阅读模式
10明经币
请高手写代码,将一组曲线60等分将等分点连成59条等分线
这组曲线存在两种形式,一种是“川”字形,即曲线是呈竖向展布,绝对不交叉,且曲线方向保证它是同方向的,或者都是从上到下,或者都是从下到上。
第二种形式,是“三”字形,即曲线是呈横向展布,绝对不交叉,且曲线方向保证它是同方向的,或者都是从左到右,或者都是从右到左。
我要求是将每条线N(例如60)等分,再将第一个等分点连成一条简单多线,以此类推第2个、第3个……第N-1个。
曲线组若呈“川”字形,则将曲线组按X从小到大排序后,连等分线;曲线组若呈“三”字形,则将曲线组按Y值从大到小排序后,连等分线。

 楼主| 发表于 2014-6-25 21:26 | 显示全部楼层
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



回复

使用道具 举报

 楼主| 发表于 2014-6-25 21:27 | 显示全部楼层
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


回复

使用道具 举报

 楼主| 发表于 2014-6-25 21:27 | 显示全部楼层
写好了,两套独立的,适用于所有情况
回复

使用道具 举报

发表于 2015-5-19 11:29 | 显示全部楼层
顶!!!!!!!!!
回复

使用道具 举报

发表于 2015-5-19 22:11 | 显示全部楼层
把图中原来所有的点都删掉?万一原图中哪些点有用呢
vlax-curve-getEndPoint '取结尾点
vlax-curve-getDistAtPoint‘得曲线长度
d=曲线长度/N ' N等分
vlax-curve-getPointAtDist d*x  x 1~N    '取N等分各点坐标
连线。。。。
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-3-29 05:59 , Processed in 0.148192 second(s), 20 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表