Как добавить вершину в полилинию нажатием одной кнопки? (Страница 1 из 4)

;; Вспомогательные функции
;; Группировка списка по числу элементов субсписка
(defun group-by-num (lst num / ls ret)
  (if (= (rem (length lst) num ) 0)
    (progn
      (setq ls nil)
      (repeat (/ (length lst) num)
    (repeat num (setq ls
            (cons (car lst) ls)
          lst (cdr lst)))
    (setq ret (append ret (list (reverse ls)))
          ls nil)))
    )
ret
  )
;; Голова списка по номеру:
(defun head (lst num )
    (if (< 0 (1- num))
      (cons (car lst) (head (cdr lst) (1- num)))))
;; Хвост списка по номеру:
(defun tail (lst num / )
(if (> (length lst) (1- num ))
(append (tail (reverse (cdr (reverse lst))) num)
    (list (last lst)))))
;; Добавление элемента в список по номеру позиции
(defun add-elt (lst num elt)
(if elt
    (append (head lst num)
          (cons  elt (tail lst num)))))
;; Создание и заполнение безопасного массива точек
(defun safe-points (lst / pt_list points)
  (setq pt_list (apply 'append lst))
  (setq    points (vlax-safearray-fill
         (vlax-make-safearray
           vlax-vbdouble
           (cons 0 (1- (length pt_list)))
         )
         pt_list
           )
  )
  )
;; Обработсик ошибок с пошаговым возвратом
(defun div-error (msg)
  (if
    (vl-position
      msg
      '("console break"
    "Function cancelled"
    "quit / exit abort"
       )
    )
     (princ "Error!")
     (princ msg)
  )
  (while (> (getvar "cmdactive") 0) (command))
  (command "._undo" "_end")
  (command "._u")
  (setq *error* olderror)
  (princ)
)
(vl-load-com)
(prompt "\n    ***    Type ADV to execute    *** \n")
;;    ОСНОВНАЯ ПРОГРАММА    ;;
(defun C:adv (/    *error*     acsp      adoc       appd        coord
           div-error     new_pl      olderror pl        pn
           pt    pt_list     seg_num  util
          )
  (or adoc
      (setq adoc
         (vla-get-activedocument
           (vlax-get-acad-object)
         )
      )
  )
  (or appd (setq appd (vla-get-application adoc)))
  (or acsp
      (setq acsp
         (vla-get-block
           (vla-get-activelayout adoc)
         )
      )
  )
  (or util (setq util (vla-get-utility adoc)))
  (command "._undo" "_end")
  (command "._undo" "_mark")
  (setq olderror *error*)
  (setq *error* div-error)
  (vla-getentity
    util
    'pl
    'pt
    "\nSelect polyline to add vertex: >>> \n"
  )
  (if pl
    (progn
      (setq pn (trans (getpoint "\nSpecify new vertex location: >>> \n") 1 0))
      (setq coord (vlax-get pl 'Coordinates)
        coord
          (cond
            ((eq (rem (length coord) 2) 0)
             (group-by-num coord 2)
            )
            ((eq (rem (length coord) 3) 0)
             (group-by-num coord 3)
            )
            (T nil)
          )
        coord (mapcar (function (lambda (x)
                      (trans x 1 0))) coord)
      )
      (setq
    seg_num    (+ (fix (vlax-curve-getparamatpoint
               pl
               (osnap (vlax-safearray->list pt) "_nea")
             )
            )
           2
        )
    )
      (setq coord (add-elt coord seg_num pn))
      (setq pt_list (safe-points coord))
      (setq new_pl (vla-addpolyline acsp pt_list))
      (vla-delete pl)
      (mapcar (function    (lambda    (x)
              (if (not (vlax-object-released-p x))
                (vlax-release-object x)
              )
            )
          )
          (list pl new_pl)
      )
    )
    (princ "\nNothing selected try again\n")
  )
  (vla-zoomextents appd)
  (vla-regen adoc acactiveviewport)
  (setq    *error*    olderror
    div-error nil
  )
  (command "._undo" "_end")
  (princ)
)
(C:adv)
(princ)

  (command "_.stretch" "_C" break_point break_point "")
  (setvar "osmode" 1)
  (while (/= (getvar "cmdactive") 0)
    (command pause)
    ) ;_ end of while

;|=============================================================================
*    Функция разрыва полилинии и одновременной передвижки новой вершины.
* Полилиния не меняет следующих свойств: цвет, слой, тип.
*    Ограничения:
*    1. Не производится отлов ошибок ввода (никто не запрещает работать с арками и
*  окружностями)
*    2. Не производится отлов нажатия Esc - не выполняется восстановление
*  системных переменных. Обработчик ошибок писать просто некогда.
*    3. Не производится проверка usc, в которой работает пользователь.
*    4. Неправильное указание точки (не принадлежащей объекту) может свалить
*  функцию в ноль.
*    5. Не отслеживается "заморозка" слоя.
*    6. Не отслеживается вариант, когда указывается пересечение двух объектов -
*  в таком случае работа непредсказуема.
*    Функция тестировалась на ADT 2005, usc = world.
*
*    Функцию желательно сохранить в файл kpblc-stretch-pline.lsp. Файл должен
* быть сохранен в путях поддержки AutoCAD.
*    Возможный макрос для вызова:
^C^C(if (not "c:pline-str") (load "kpblc-stretch-pline.lsp"));c:pline-str;
=============================================================================|;
(defun kpblc-stretch-pline (/ break_point _osmode_ selset_oper)
  (setq _osmode_ (getvar "osmode")) ;_ end of setq
  (setvar "osmode" 512)
  (setq    break_point (getpoint "\nУкажите новую вершину : ")
    selset_oper (ssget break_point)
    ) ;_ end of setq
  (command "_.break" selset_oper break_point break_point)
  (command "_.pedit" "_M" "_C" break_point break_point "" "_join" 0 "")
  (command "_.stretch" "_C" break_point break_point "" break_point)
  ;;(command (list break_point) pause)
  ;|(while (/= (getvar "cmdactive") 0)
    (command pause)
    ) ;_ end of while
    |;
  (setvar "osmode" _osmode_)|;
  (princ)
  ) ;_ end of defun
(defun c:pline-str()
  (kpblc-stretch-pline)
  ) ;_ end of defun
;;; Конец файла kpblc-stretch-pline.lsp

;|===================================================================
*    Функция разрыва полилинии и одновременной передвижки новой вершины.
* Полилиния не меняет следующих свойств: цвет, слой, тип.
*    Ограничения:
*    1. Не производится отлов ошибок ввода (никто не запрещает работать с арками и
*  окружностями)
*    2. Не производится отлов нажатия Esc - не выполняется восстановление
*  системных переменных. Обработчик ошибок писать просто некогда.
*    3. Не производится проверка usc, в которой работает пользователь.
*    4. Неправильное указание точки (не принадлежащей объекту) может свалить
*  функцию в ноль.
*    5. Не отслеживается "заморозка" слоя.
*    6. Не отслеживается вариант, когда указывается пересечение двух объектов -
*  в таком случае работа непредсказуема.
*    Функция тестировалась на ADT 2005, usc = world.
*
*    Функцию желательно сохранить в файл kpblc-stretch-pline.lsp. Файл должен
* быть сохранен в путях поддержки AutoCAD.
*    Возможный макрос для вызова:
^C^C(if (not "c:pline-str") (load "kpblc-stretch-pline.lsp"));c:pline-str;
===================================================================|;
(defun kpblc-stretch-pline (/ break_point _osmode_ selset_oper)
  (setq _osmode_ (getvar "osmode")) ;_ end of setq
  (setvar "osmode" 512)
  (setq    break_point (getpoint "\nУкажите новую вершину : ")
    selset_oper (ssget break_point)
    ) ;_ end of setq
  (command "_.break" selset_oper break_point break_point)
  (command "_.pedit" "_M" "_C" break_point break_point "" "_join" 0 "")
  (command "_.stretch" "_C" break_point break_point "" break_point)
  (setvar "osmode" _osmode_)
  (princ)
  ) ;_ end of defun
(defun c:pline-str()
  (kpblc-stretch-pline)
  )