MNU, LISP. Предлагается панель с опциями и новыми командами для полилинии (Страница 1 из 2)

[_Button("Добавить вершины", "pl_div.bmp", "pl_div.bmp")]^C^C^P(if (not C:PL-DIV) (load "pl_div")) PL-DIV

;|*********************** Команда PL-DIV *********************************
*                                                                        *
*   Разбивает выбранный сегмент полилинии на указанное количество        *
*  сегментов или через указанное расстояние. По аналогии с командами     *
*  подели (divide) и разметь (measure). Если разбиваем сегмент через     *
*  указанное расстояние, то новые вершины добавляются начиная с вершины, *
*  ближайшей к точке указания. Не обрабатываются 3d полилинии.           *
*  В ответ на запрос "[Длина (-) /Количество (+) ] сегментов : "         *
*  можно вводить                                                         *
*   - число >0 - воспримется как кол-во сегментов                        *
*   - число <0 - воспримется как расстояние для разметки                 *
*   - соответствующие опции команды (Д К + -)                            *
*                                                                        *
**************************************************************************
Идея и первая реализация здесь https://www.caduser.ru/forum/topic27961.html
Принцип добавления сегментов взят из программы kpblc'a kpblc-stretch-pline
Обсуждения и варианты здесь https://www.caduser.ru/forum/topic20243.html
   Автор  Владимир Азарко (VVA)
   Редакция 21.06.2006|;
(defun C:PL-DIV ( / ent-pline break-point-count osm adoc osm *error* next)
(vl-load-com)
;| Функция pline-addvertex-divide
Добавляет вершины к сегменту полилинии
Параметры:
   ent_pline          - ссылка на полилинию, аналог (entsel)
   break-point-count  - число >0 кол-во сегментов (divide)
                      - число <0 длина сегмента   (measure)|;
(defun pline-addvertex-divide (ent-pline break-point-count /
                   pln bpt coors segm fpt
                   spt len i break-point-list )
;;;***************** Вспомогательные функции ******************************
;;======================================================;;
;;  Return list of segms and radii valiues of polyline  ;;
;;  written by Fatty The Old Horse 10/13/05    ;;
;;      (framework)      ;;
;;======================================================;;
(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)
;|=======================================================================================
* Ф-ция _pline-get-verts
* Возвращает координаты вершин полилинии
* Взята или на autocad.ru или на dwg.ru
* Arguments [Type]:
   pline_obj = Object [Vla-Object]
* Возвращает [Type]:
   список координат вида ((90.987 183.524) (93.2774 206.991) (123.052 208.708) (140.23 184.382) (111.6 170.073))
|;
(defun _pline-get-verts (pline_obj / verts)
  (setq verts (vlax-get pline_obj 'Coordinates)
      verts
      (cond
        ((wcmatch (vlax-get pline_obj 'Objectname )
           "AcDb2dPolyline,AcDb3dPolyline")
         (group-by-num verts 3))
        ((eq (vlax-get pline_obj 'Objectname )
           "AcDbPolyline")
         (group-by-num verts 2))
        (T nil))))
;;;*************** pline-addvertex-divide *********************
 (setq pln (vlax-ename->vla-object (car ent-pline))
       bpt (cadr ent-pline)
       bpt (trans bpt 1 0)
       bpt (vlax-curve-getclosestpointto pln bpt))
 (if (eq (vla-get-closed pln) :vlax-false)
   (setq coors (_pline-get-verts pln))
   (progn
     (setq coors (_pline-get-verts pln))
     (setq coors (append coors (list (car coors))))
     )
   )
   (setq segm (fix (vlax-curve-getparamatpoint pln bpt)) ;;;№ Сегмента
          fpt (nth segm coors)                ;_1-я Вершина сегмента
          spt (nth (1+ segm) coors)           ;_2-я Вершина сегмента
;|len - список из 3-х чисел
 (Длина сегмента
 Расстояние от начала сегмента до точки указания
 Расстояние от точки указания до конца сегмента)|;
          len (mapcar
               '(lambda (p1 p2)
              (abs(- (vlax-curve-getDistAtPoint pln p1)
              (vlax-curve-getDistAtPoint pln p2))))
           (list fpt fpt bpt)
           (list spt bpt spt))
break-point-list nil);_setq
 (if (minusp break-point-count)
  (progn ;_Длина
    (setq break-point-count (abs break-point-count)
        segm (fix (/ (car len) break-point-count))
       coors (if (> (nth 1 len)(nth 2 len))
               (- (car len)(* segm break-point-count)) ;_ближе к последнему сегменту
               0)
           i 1
         len break-point-count
         break-point-count segm)
   (if (zerop coors)
    (setq break-point-count (1+ break-point-count))
    (setq break-point-list
     (append break-point-list
       (list (vlax-curve-getPointAtDist pln
             (+ (vlax-curve-getDistAtPoint pln fpt) coors))))))
  )
  (progn ;_Кол-во
    (setq len (/ (car len) break-point-count)
            i 1
        coors 0))
  );_if
  (repeat (1- break-point-count)
    (setq break-point-list
            (append break-point-list
                 (list (vlax-curve-getPointAtDist pln
                       (+ (vlax-curve-getDistAtPoint pln fpt)
                          (+ (* i len) coors))))))
    (setq i (1+ i)))
    (foreach break-point break-point-list
       (setq break-point (trans break-point 0 1))
       (command "_.break" ent-pline "_F" break-point break-point)
       (command "_.pedit" "_M" "_C" break-point break-point "" "_join" 0 "")
       (setq ent-pline (list (entlast) break-point )))
  );_pline-addvertex-divide
(setq adoc (vla-get-activedocument (vlax-get-acad-object))
       osm (getvar "OSMODE")
      next t)
(defun *error* (message)
;;;Прерываем активную команду
(while (> (getvar "CMDACTIVE") 0)(command))
(if (car ent-pline)(redraw (car ent-pline) 4))
  (setvar "OSMODE" osm)
  (princ message)
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun
  (vla-startundomark adoc)
(while next
  (setvar "ERRNO" 0)
  (if (and
        (setq ent-pline
               (entsel "\nВыберите сегмент полилинии для добавления вершин <выход>: "))
        (member (vla-get-ObjectName
                  (vlax-ename->vla-object (car ent-pline)))
                '("AcDb2dPolyline" "AcDbPolyline"))
      )
    (progn
      (redraw (car ent-pline) 3)
      (initget "Количество Длина + -" 3)
      (prompt "\nЧисло <0-длина сегмента >0-количество сегментов")
      (setq break-point-count
             (getint "\n[Длина (-) /Количество (+) ] сегментов : "))
      (cond ((and
               (= (type break-point-count) 'STR)
               (member (substr break-point-count 1 1) '("Д" "-"))
               )
             (initget 7)
             (setq break-point-count
                    (getdist "\nУкажите длину сегментов : ")
                   break-point-count (- 0 break-point-count))
              )
            ((and
                (= (type break-point-count) 'STR)
                (member (substr break-point-count 1 1) '("К" "+"))
              )
              (initget 7)
              (setq break-point-count
                     (getint "\nУкажите количество сегментов : "))
             )
             (t nil));_cond
      (redraw (car ent-pline) 4)
      (setvar "OSMODE" 0)
      (pline-addvertex-divide ent-pline break-point-count)
      (setvar "OSMODE" osm)
      )
   (progn
    (setq osm (getvar "ERRNO"))
    (cond ((= osm 7) (alert "Ничего не выбрано"));;;Пустой выбор
          ((and (car ent-pline)
                (member (vla-get-ObjectName
                           (vlax-ename->vla-object (car ent-pline)))
                        '("AcDb3dPolyline")))
           (alert "3d полилинии не обрабатываются"))
          ((= osm 52)(setq next nil))  ;;;Клавиша Ввод(выход)
          (t (alert "Необходимо выбрать полилинию")));_cond
    )));_while
  (vla-endundomark adoc)(princ)
  )
  (princ "\nНаберите PL-DIV")