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

(defun pl_AddVxbyPedit (/       break_point
          selset_oper break_ent     break_ent_type
          *error* layer_status
          )
  (vl-load-com)
;;; ============ Библиотечные ф-ции BEGIN =============================
(defun D2R (a)(* pi (/ a 180.0)))
(defun R2D (a)(/ (* a 180.0) pi))
(defun lib:dxf (n lst)(cdr (assoc n lst)))
(defun lib:massoc (key alist / x nlist)
  (foreach x alist
    (if (eq key (car x))
      (setq nlist (cons (cdr x) nlist))))
  (reverse nlist))
;| ! *******************************************************************
;; !                  lib:IsPtInView
;; ! *******************************************************************
;; ! Проверяет находится ли точка в видовом экране
;; ! Auguments: 'pt'  - Точка для анализа
;; ! Return   : T или nil если 'pt' в видовом экране или нет
;; ! *******************************************************************|;
(defun lib:IsPtInView (pt / VCTR Y_Len SSZ X_Pix Y_Pix X_Len Lc Uc)
(setq
   VCTR (getvar "VIEWCTR")
   Y_Len (getvar "VIEWSIZE")
   SSZ (getvar "SCREENSIZE")
   X_Pix (car SSZ)
   Y_Pix (cadr SSZ)
   X_Len (* (/ X_Pix Y_Pix) Y_Len)
   Lc (polar VCTR (d2r 180.0) (* 0.5 X_Len))
   Uc (polar Lc 0.0 X_Len)
   Lc (polar Lc (d2r 270.0) (* 0.5 Y_Len))
   Uc (polar Uc (d2r 90.0) (* 0.5 Y_Len)))
(if (and (> (car pt) (car Lc))
     (< (car pt) (car Uc))
     (> (cadr pt) (cadr Lc))
     (< (cadr pt) (cadr Uc)))
    T
    nil))
;| ! ***************************************************************************
;; !           lib:pt_extents
;; ! ***************************************************************************
;; ! Function : Возвращает границы MIN, MAX X,Y,Z списка точек
;; ! Argument : 'vlist' - Список точек
;; ! Returns  : Список точек (ЛевНижн ПравВерхн)
;; ! ***************************************************************************|;
(defun  lib:pt_extents (vlist / tmp)
(setq tmp
       (mapcar '(lambda (x) (vl-remove-if 'null x))
           (mapcar '(lambda (what) (mapcar '(lambda (x) (nth what x)) vlist))
               '(0 1 2))));_setq
  (list
    (mapcar '(lambda(x)(apply 'min x)) tmp)
    (mapcar '(lambda(x)(apply 'max x)) tmp)));_defun
; ! ****************************************************************************
;; !                             lib:Zoom2Lst
;; ! ****************************************************************************
;; ! Function : Zoom границ списка точек
;; ! Arguments: 'vlist' - Список точек
;; ! Зуммирует экран, чтобы всеточки были видны
;; ! ****************************************************************************
(defun lib:Zoom2Lst( vlist / bl tr Lst OS )
(setq    Lst (lib:pt_extents vlist)
    bl (car Lst)
    tr (cadr Lst))
(if (not (and (lib:IsPtInView bl) (lib:IsPtInView tr)))
(progn  (setq OS (getvar "OSMODE"))
    (setvar "OSMODE" 0)
    (command
        "._Zoom" "_Window" bl tr
        "._Zoom" "0.95x")
    (setvar "OSMODE" OS))))
;;; pln - ENAME or Vla-Object polyline
;;; bpt Point in WCS
;;; Retunt Number Vertex Since 0 (начиная с 0)
(defun lib:pl_getVxNumber ( pln bpt /  segm )
   (if (eq (type pln) 'ENAME)
     (setq pln (vlax-ename->vla-object pln)))
     (setq bpt (vlax-curve-getclosestpointto pln bpt))
     (fix (vlax-curve-getparamatpoint pln bpt))) ;;;№ Сегмента
;; ! ****************************************************************************
;; !               lib:pl_AddPointbyPedit
;; ! ****************************************************************************
;; ! Function : Add a new point on the polyline just before the specified vertex
;; !            number 'VxNum'
;; ! Arguments: 'ename'  - The name of the POLYLINE entity (Vla or Ename)
;; !            'VxNum'  - Vertex Number (actual count, not array) После какой вершины добавить, начиная с 1
;; !            'Pt'     - New value of the point to be added.
;; ! Action   : Adds a vertex at the specified point along the polyline
;; ! Returns  : Point of vertex if a vertex was added else returns nil
;; !Идея взята с    : www.4d-technologies.com
;; ! ****************************************************************************
(defun lib:pl_AddPointbyPedit ( ename VxNum Pt / pt1 elist ptlist Added OS )
 (if (eq (type ename) 'VLA-OBJECT)
     (setq ename (vlax-vla-object->ename ename)))
(setq    OS (getvar "OSMODE")
    Added nil
    ptlist (lib:massoc 10 (entget ename)))
(setvar "OSMODE" 0)
(lib:Zoom2Lst ptlist)
(command "._Pedit" ename "_Edit")
(if (> VxNum 0)(repeat (1- VxNum)(command "_Next")))
(command "_Insert" Pt)
(setq Added Pt)
(if (> VxNum 0)(command "_X" "_X")
(progn
    (setq elist (entget ename))
    (if (= (lib:dxf 0 elist) "LWPOLYLINE")
    (progn
      (command "_Previous")
      (setq pt1 (append (lib:dxf 10 elist) (list (lib:dxf 38 elist)))))
    (setq pt1 (lib:dxf 10 (entget (entnext ename)))))
    (command "_Move" Pt "_Next" "_Move" pt1 "_X" "_X")))
(setvar "OSMODE" OS)
Added)
;;; ============ Библиотечные ф-ции END ===============================
  (setq *error* kpblc-error)
  (if (not *kpblc-activedoc*)
    (setq *kpblc-activedoc*
     (vla-get-activedocument
       (vlax-get-acad-object)
       ) ;_ end of vla-get-activedocument
    ) ;_ end of setq
    ) ;_ end of if
  (vla-endundomark *kpblc-activedoc*)
  (vla-startundomark *kpblc-activedoc*)
  (kpblc-error-save-sysvar '(("osmode" 512)))
  ;; Обработка пустого выбора
  (while (setq break_point
    (getpoint "\nУкажите точку разрыва <выход> : "))
    (setq selset_oper   (ssget break_point)
            break_ent   (if selset_oper (ssname selset_oper 0) nil)
         break_ent_type (if break_ent (cdr (assoc 0 (entget break_ent))) nil)
      selset_oper nil
    ) ;_ end of setq
    (if (and break_ent
          (not (lib:layer-is-changeable (lib:layer-by-object break_ent))))
      (progn
         (setq layer_status (cdr (assoc  70
             (entget (lib:layer-by-object break_ent)))))
         (_kpblc-ent-modify-autoregen
            (lib:layer-by-object break_ent) 70 0 t)
      ))
    (cond
      ((member break_ent_type '("LWPOLYLINE"  "POLYLINE"))
        (lib:pl_AddPointbyPedit
      break_ent
      (1+ (lib:pl_getVxNumber break_ent
        (trans break_point 1 0)))
      (trans (getpoint break_point "Укажите новую точку : ") 1 0)
      )
       )
      ((member break_ent_type '("LINE" "ARC"))
       (if (getvar "PEDITACCEPT")(setvar "PEDITACCEPT" 0))
       (command "_.PEDIT" break_ent "_Yes" "") ;_Делаем полилинию
       (setq break_ent (entlast))
        (lib:pl_AddPointbyPedit
      break_ent
      (1+ (lib:pl_getVxNumber break_ent
        (trans break_point 1 0)))
      (trans (getpoint break_point "Укажите новую точку : ") 1 0)
      )
       )
      ((null break_ent_type)(alert "Ничего не выбрано!"))
      (t (alert "Добавить вершину к выбранному примитиву невозможно!")))
      (if  layer_status (progn
         (_kpblc-ent-modify-autoregen
          (lib:layer-by-object break_ent)
           70 layer_status t)
        (setq layer_status nil))) ;_ end of if
    ) ;_ end of while
  (kpblc-error-restore-sysvar)
  (vla-endundomark *kpblc-activedoc*)
  (princ)) ;_ end of defun
(defun c:pline-strPE ()
  (pl_AddVxbyPedit)
  ) ;_ end of defun
(princ "\nНаберите pline-strPE")