多段线加点 vba

yealor

'线上加点
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

'线上加点
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

感谢论坛长老“yshf”，

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

lxx2003

坐看大佬解决

jkop

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

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

chixun99

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

yealor

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

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

chixun99

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

好的，多谢回复。了解了