yealor 发表于 2023-11-20 23:22:00

多段线加点 vba

'线上加点
Sub Start_XianJiaDian()
'1、选线
Dim PolyXian As AcadLWPolyline'AcadPolyline   'AcadEntity
Dim Dianwei As Variant

ThisDrawing.Utility.GetEntity PolyXian, Dianwei, "选取线"    '如何判断没选任何东西呢？

Dim DianShu As Integer
DianShu = (UBound(PolyXian.Coordinates) + 1) / 2 '求出总点数

Dim i As Integer, j As Integer
Dim JieDian(0 To 2) As Double
Dim ZuobiaoJi As Variant
Dim Ang() As Double'直线的角度
ReDim Ang(DianShu)
ZuobiaoJi = PolyXian.Coordinates

Dim pLine As AcadLine

For i = 1 To DianShu
    JieDian(0) = ZuobiaoJi(i * 2 - 2)
    JieDian(1) = ZuobiaoJi(i * 2 - 1)
    JieDian(2) = 0
    Set pLine = ThisDrawing.ModelSpace.AddLine(Dianwei, JieDian)
       Ang(i) = pLine.Angle' 记录新建直线的角度，这个角度为弧度值。
'       Debug.Print Ang(i)
       pLine.Delete

Next i

    Dim Qd As Integer'点序号

      '通过直线夹角判断所选取点离线上的结点哪个最近，,夹角越小，离点越近
         Dim JiaJiao() As Double
         ReDim JiaJiao(DianShu - 1)

          For i = 1 To DianShu - 1
            JiaJiao(i) = Abs(Ang(i) - Ang(i + 1))   '夹角
          Next i
          For i = 1 To DianShu - 1
            JiaJiao(i) = JiaJiao(i) / 3.1415926 * 180'夹角转成度
            JiaJiao(i) = Abs(180 - JiaJiao(i))
'            Debug.Print JiaJiao(i)
          Next i

          Dim jd As Double
          jd = JiaJiao(1)
            For i = 1 To DianShu - 1
               If JiaJiao(i) < jd Then
                  jd = JiaJiao(i)      '找最小夹角和对应的序号
                  Qd = i
               End If
            Next i

Dim JiaDian As Variant
JiaDian = ThisDrawing.Utility.GetPoint(, vbCrLf & "请指定添加点的位置")
Dim tjdzb(0 To 1) As Double
tjdzb(0) = JiaDian(0)
tjdzb(1) = JiaDian(1)

PolyXian.AddVertex Qd, tjdzb



End Sub

yshf 发表于 2023-11-21 18:24:41

本帖最后由 yshf 于 2023-11-21 18:26 编辑

'线上加点
Sub Start_XianJiaDian()
'1、选线
Dim PolyXian As AcadLWPolyline'AcadPolyline   'AcadEntity
Dim Dianwei As Variant

On Error Resume Next

AppActivate ThisDrawing.Application.Caption

ThisDrawing.Utility.GetEntity PolyXian, Dianwei, "选取线"    '如何判断没选任何东西呢？

If Err.Number = -2147352567 Then
   MsgBox "没有选取对象!"
   Err.Clear
   End
Else
   If Err.Number = 13 Then
      MsgBox "选取的对象不是多段线!"
      Err.Clear
      End
   End If
   
   Dim DianShu As Integer
   DianShu = (UBound(PolyXian.Coordinates) + 1) / 2 '求出总点数

   Dim i As Integer, j As Integer
   Dim JieDian(0 To 2) As Double
   Dim ZuobiaoJi As Variant
   Dim Ang() As Double'直线的角度
   ReDim Ang(DianShu)
   ZuobiaoJi = PolyXian.Coordinates

   Dim pLine As AcadLine

   For i = 1 To DianShu
         JieDian(0) = ZuobiaoJi(i * 2 - 2)
         JieDian(1) = ZuobiaoJi(i * 2 - 1)
         JieDian(2) = 0
         Set pLine = ThisDrawing.ModelSpace.AddLine(Dianwei, JieDian)
         Ang(i) = pLine.Angle' 记录新建直线的角度，这个角度为弧度值。
'       Debug.Print Ang(i)
         pLine.Delete

   Next i

   Dim Qd As Integer'点序号

   '通过直线夹角判断所选取点离线上的结点哪个最近，,夹角越小，离点越近
   Dim JiaJiao() As Double
   ReDim JiaJiao(DianShu - 1)

   For i = 1 To DianShu - 1
         JiaJiao(i) = Abs(Ang(i) - Ang(i + 1))   '夹角
   Next i
   For i = 1 To DianShu - 1
         JiaJiao(i) = JiaJiao(i) / 3.1415926 * 180'夹角转成度
         JiaJiao(i) = Abs(180 - JiaJiao(i))
'            Debug.Print JiaJiao(i)
   Next i

   Dim jd As Double
   jd = JiaJiao(1)
   For i = 1 To DianShu - 1
         If JiaJiao(i) < jd Then
            jd = JiaJiao(i)      '找最小夹角和对应的序号
            Qd = i
          End If
   Next i

   Dim JiaDian As Variant
   JiaDian = ThisDrawing.Utility.GetPoint(, vbCrLf & "请指定添加点的位置")
   Dim tjdzb(0 To 1) As Double
   tjdzb(0) = JiaDian(0)
   tjdzb(1) = JiaDian(1)

   PolyXian.AddVertex Qd, tjdzb

End If
End Sub

yealor 发表于 2023-11-21 23:57:45


感谢论坛长老“yshf”，

我为什么就不知道这些错误代码呢，有什么相关的书或者资料吗

lxx2003 发表于 2023-11-22 20:47:01

坐看大佬解决

jkop 发表于 2023-11-24 09:30:39

http://www.lee-mac.com/addpolyvertex.html
可以参考Lee-mac ，也是线上加点的功能

AddLWPolylineVertexV1-1.lsp 下面为连结
http://www.lee-mac.com/lisp/AddLWPolylineVertexV1-1.lsphttp://www.lee-mac.com/lisp/gifs/addvertex.gif

chixun99 发表于 2024-1-13 08:42:42

多段线也研究过一段时间，这个加点功能主要用在哪些场景？

yealor 发表于 2024-3-22 21:05:35

chixun99 发表于 2024-1-13 08:42
多段线也研究过一段时间，这个加点功能主要用在哪些场景？

测绘专业在处理等高线、公路、河流等线性地物的时候

chixun99 发表于 2024-3-25 10:56:19

yealor 发表于 2024-3-22 21:05
测绘专业在处理等高线、公路、河流等线性地物的时候

好的，多谢回复。了解了

wuyunpeng888 发表于 2024-5-5 16:20:15

多段线插入点要想适应范围宽，就得考虑凸度，没有凸度的比较简单，只处理数组就行，有凸度的要判断

wuyunpeng888 发表于 2024-5-5 16:21:54

再做一个判断点在线的哪一段上的函数
页: [1]
查看完整版本: 多段线加点 vba