[master_aleks]

Здравствуйте. Нужна помощь в создании автоматической мультивыноски с некоторыми параметрами. Lisp "123" я осилил сам, но необходимо добавить некоторые параметры, которые есть в созданном LISP другим человек (К1 В1.lsp), но у меня не хватает ума их объединить. На основе "К1 В1 07.08.2016.lsp" нужно добавить в мультивыноске координаты Х и У. Из "К1 В1 07.08.2016.lsp" убрать вначале всплывающее окно, убрать выбор канализации. Оставить ПК с автоматической простановкой, угол поворота полилинии, координаты Х и У. Файл автокада с образцом приложил. Свойства мультилинии, цвет, слой и т.д. по умолчанию в автокаде.

[kp+]

Как-то неудобно вмешиваться в чужой код, даже если он распространяется бесплатно, видя эту надпись

Благие начинания, без финансовой поддержки умирают

Автор оставил номер кошелька для обратной связи. Может, можно поставить ему задачу в комментариях к переводу? Обычно такие задачи выполняются с наивысшим приоритетом

[Maksim7enov]

Доброе утро! Сделал по своему, проверял только на примере.

Код:

[Выделить все]

   ;Вызов 	(fun-mliader_picket_coord_angle)
(defun fun-mliader_picket_coord_angle (/ adoc selset cord ang)
  (setq adoc (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
  (setq selset (_kpblc-conv-selset-to-vla (ssget '((0 . "lwpolyline"))))) ;Вставляем координаты в точки вершин полилинии
  (foreach q selset
    (setq cord (mapcar 'cdr (vl-remove-if '(lambda (x) (/= 10 (car x))) (entget (vlax-vla-object->ename q)))) ;_ end of  mapcar
    ) ;_ end of setq
    (setq a 0)
    (setq ang (fun-angle-poy (vlax-vla-object->ename q)))
    (mapcar (function
              (lambda (x1 х2 / obml pic1 pic2)
                (setq obml (vla-addmleader adoc (ru-mleader-coords-from-list (list x1 (polar x1 (/ pi 2) 5))) 0)) ;Вставляем пикетаж
                (setq pic1 (vl-princ-to-string (fix (/ a 100))))
                (setq pic2 (rtos (- a (* (fix (/ a 100)) 100)) 2 1))
                (setq a (+ (distance x1 х2) a))
                (vla-put-textstring obml
                                    (strcat "ПК"
                                            (vl-princ-to-string pic1)
                                            "+"
                                            (if (wcmatch pic2 "*.*")
                                              pic2
                                              (setq pic2 (strcat pic2 ".0"))
                                            ) ;_ end ofif
                                    ) ;_ end ofstrcat
                ) ;_ end ofvla-put-textstring
          ;вставляем углы поворота
                (foreach d ang
                  (if (equal (car d) x1)
                    (vla-put-textstring obml (strcat (vla-get-textstring obml) "\\P" "УП" (cadr d) "°"))
                  ) ;_ end ofif
                ) ;_ end offoreach
          ;Вставляем координаты в точки вершин полилинии  
                (vla-put-textstring obml
                                    (strcat (vla-get-textstring obml) "\\P" "X=" (rtos (cadr x1) 2 2) "\\P" "Y=" (rtos (car x1) 2 2))
                ) ;_ end ofvla-put-textstring
              ) ;_ end oflambda
            ) ;_ end offunction
            cord
            (append (cdr cord) (list (last cord)))
    ) ;_ end ofmapcar
  ) ;_ end offoreach
) ;_ end ofdefun


;;; Получает список из координаты и угла сегмента полилинии
(defun fun-angle-poy (selset / q)
  (setq vert (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget selset))))
  (setq n (1- (length vert))
        i 0
  ) ;_ end ofsetq
  (repeat n
    (setq p1 (nth i vert)
          p2 (nth (setq i (1+ i)) vert)
    ) ;_ end ofsetq
    (if (< i n)
      (progn (setq p3    (nth (1+ i) vert)
                   ang-1 (atof (angtos (angle p2 p1) 0 3))
                   ang+1 (atof (angtos (angle p2 p3) 0 3))
             ) ;_ end ofsetq
             (if (> ang+1 ang-1)
               (setq angl (rtos (- ang+1 ang-1) 2 0))
               (setq angl (rtos (- ang-1 ang+1) 2 0))
             ) ;_ end ofif
             (setq q (cons (list p2 angl) q))
      ) ;_ end ofprogn
    ) ;_ end ofif
  ) ;_ end ofrepeat
  q
) ;_ end ofdefun


(defun ru-mleader-coords-from-list (list_points / n pt pt_array)
  (setq pt_array (vlax-make-safearray vlax-vbdouble (cons 1 (* 3 (length list_points))))
        n        0
  ) ;_ end of setq
  (while (< n (length list_points))
    (setq pt (nth n list_points))
    (vlax-safearray-put-element pt_array (+ (* n 3) 1) (car pt))
    (vlax-safearray-put-element pt_array (+ (* n 3) 2) (cadr pt))
    (vlax-safearray-put-element pt_array (+ (* n 3) 3) (caddr pt))
    (setq n (1+ n))
  ) ;_ end of while
  pt_array
) ;_ end of defun

(defun _kpblc-conv-selset-to-vla (selset / tab item)
  (cond ((not selset) nil)
        ((= (type selset) 'pickset)
         (repeat (setq tab  nil
                       item (sslength selset)
                 ) ;_ end setq
           (setq tab (cons (vlax-ename->vla-object (ssname selset (setq item (1- item)))) tab))
         ) ;_ end repeat
        )
        ((listp selset) selset)
  ) ;_ end of cond
) ;_ end of defun

[master_aleks]

Спасибо большое. Все заработало