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

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

请高手写代码，将一组曲线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 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: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 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: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*x x 1~N '取N等分各点坐标
连线。。。。

账号		自动登录	找回密码
密码			注册