| Правила | Регистрация | Пользователи | Поиск | Сообщения за день | Все разделы прочитаны |  Справка по форуму | Файлообменник |

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > LISP. Пересечения плоскости и линий

LISP. Пересечения плоскости и линий

Ответ
Поиск в этой теме
Непрочитано 05.09.2011, 09:38 #1
LISP. Пересечения плоскости и линий
LastGraff
 
Томск
Регистрация: 13.07.2011
Сообщений: 81

Есть куча 3д линий и сплайнов и одна полилиния, по которой нужно построить плоскость сечения, перпендикулярную XOY и получить координаты пересечения получившейся плоскости со сплайнами или полилиниями (либо с одним, либо с другим).

Заранее благодарен за помощь.
Просмотров: 8432
 
Непрочитано 05.09.2011, 10:08
#2
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,990
<phrase 1= Отправить сообщение для VVA с помощью Skype™


Вся геометрия здесь [Challenge] intersection of lines and planes
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Автор темы   Непрочитано 05.09.2011, 11:07
#3
LastGraff


 
Регистрация: 13.07.2011
Томск
Сообщений: 81


очень интересный подход, только он применим для пересечения линии (одной и прямой) с прямой плоскостью, к сожалению у меня порядка 2000 полилиний по 10-15 сегментов в каждой и плоскость для пересечения тоже состоит из нескольких (порядка 5-10) мне пока кроме полного перебора в голову ничего не приходит, VVA, может поможете еще советом, за предыдущий - очень благодарен
LastGraff вне форума  
 
Непрочитано 05.09.2011, 11:20
#4
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 39,787


Как вариант: http://www.cadtutor.net/forum/showth...6521#post56521 . Я там несколько кодов рисовал, поковыряй - может, чего и пригодится (если я верно понял задачу, конечно).
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Автор темы   Непрочитано 05.09.2011, 11:47
#5
LastGraff


 
Регистрация: 13.07.2011
Томск
Сообщений: 81


Спасибо, пытаюсь разобраться, хотя дается это мне с трудом... пока даже не могу до конца понять что в целом делает qp1.
LastGraff вне форума  
 
Непрочитано 05.09.2011, 12:16
1 | #6
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 39,787


Основная идея проста: все нужные примитивы проецируются на плоскость полилинии, получаем точки пересечения, потом примитивы обратно и получаем расстояние от вычисленной точки до примитива. Это и будет высота расположения примитива над полилинией в указанной точке. А дальше строишь все чего хочется.
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Автор темы   Непрочитано 05.09.2011, 13:33
#7
LastGraff


 
Регистрация: 13.07.2011
Томск
Сообщений: 81


Алексей, вот пример входных данных (белая линия - линия для сечения, рыжие - изолинии, с которыми и ищем пересечения) просто думал изначально построить поверхность по изолиниям, но это пока совсем не получается (цивил с этим справлялся, а вот акад как-то не очень) а потом получить линию пересечения двух поверхностей. Поэтому и решил, что поверхность надо строить только одну, или даже ни одной. Для построения этой линии и думаю найти пересечения поверхности с плиниями или сплайнами, получить эти точки и по ним построить 3д плинию.
Вложения
Тип файла: dwg
DWG 2007
surf.dwg (1.31 Мб, 1730 просмотров)
LastGraff вне форума  
 
Непрочитано 04.02.2013, 23:42
#8
obojenya


 
Регистрация: 14.06.2010
Сообщений: 1


Скажите пожалуйста вы нашли ответ на ваш вопрос, просто у меня стоит подобная задача и хотелось бы узнать как вы ее решили? заранее спасибо)
obojenya вне форума  
 
Автор темы   Непрочитано 06.02.2013, 06:41
#9
LastGraff


 
Регистрация: 13.07.2011
Томск
Сообщений: 81


воспользовался советом Алексея... Все лини в 3D перенес на плоскость, где Z=0, нашел пересечения, а потом из каждого пересечения в проверил пересечение с реальной 3D линией и нашел для каждого координату Z, иначе не получилось.
LastGraff вне форума  
 
Непрочитано 06.02.2013, 08:54
#10
Oleg T


 
Регистрация: 27.12.2011
Сообщений: 1,458


Не знаю как в AutoCAD, но в BricsCAD по этим точкам строится 3-м полилиния с использованием привязки "Мнимое пересечение".
Oleg T вне форума  
 
Непрочитано 04.07.2017, 10:09
#11
tujn08


 
Регистрация: 26.12.2013
Сообщений: 284


Приветствую.
Подобная задача у меня:

есть полилиния. Надо найти пересечения с горизонталью проходящей через координаты Y. Все в двухмерке.
tujn08 вне форума  
 
Непрочитано 04.07.2017, 10:23
#12
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 39,787


inters, vla-intersectwith, и т.п. Ну или математика.
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 04.07.2017, 11:31
#13
Vassa


 
Регистрация: 30.05.2012
Сообщений: 97


Можно выдавить полилинию (ту, что на чертеже черная), получив "стенку", и по ней обрезать (если не жалко) "рыжие". Я пробовал с Вашим чертежом - получается. Автокад 2016.
__________________
В действительности все иначе, чем на самом деле.
(Антуан де Сент-Экзюпери)
Vassa вне форума  
 
Непрочитано 04.07.2017, 12:17
#14
tujn08


 
Регистрация: 26.12.2013
Сообщений: 284


Цитата:
Сообщение от Кулик Алексей aka kpblc Посмотреть сообщение
inters, vla-intersectwith, и т.п. Ну или математика.
да я смотрел это, но надо без создания графических объектов.
tujn08 вне форума  
 
Непрочитано 04.07.2017, 12:39
#15
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 39,787


Ну раз так, то составляем уравнения для каждого сегмента полилинии (они же могут быть дуговые), и находим их корни. Проверяем - принадлежит ли точка полилинии и принадлежит ли она указанному сегменту. Весьма муторное занятие. Значительно проще создать прямую или луч и через vla-intersectwith найти все пересечения.
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 04.07.2017, 12:47
#16
tujn08


 
Регистрация: 26.12.2013
Сообщений: 284


ММм.. щас что-то в голове наклевывается.

Что я добиваюсь: у меня трасса 40км 1:10000. Я обвел нужную область полилинией (замкнутой), надо эту (кривую) область разбить на видовые экраны вписаные в лист. Плюс подгонять формат листа и распологать рационально с попыткой добавить еще один видовой экран ниже.
Что-то подобное делал с vlax-curve-. Надо вспомнить.
tujn08 вне форума  
 
Непрочитано 04.07.2017, 12:52
#17
gumel


 
Регистрация: 20.04.2011
Сообщений: 402


Давным давно решал задачу по построению изолиний из сетки 3DMesh (вернее по ее составляющим - 3DFace). Видать это было так давно, что уже и не могу вспомнить как заставить работать мое творчество..

Конечно это совсем не то, что требуется автору темы, и не совсем LISP, но вдруг кому нибудь пригодится. Помню как парился вспоминая геометрию одновременно излагая мысли на чуждом для меня языке
Вложения
Тип файла: dvb Slice_3DFace.dvb (51.0 Кб, 12 просмотров)
gumel вне форума  
 
Непрочитано 24.04.2019, 07:38
#18
hroost

Проектирование
 
Регистрация: 01.09.2009
Сообщений: 19


Цитата:
Сообщение от Кулик Алексей aka kpblc Посмотреть сообщение
Основная идея проста: все нужные примитивы проецируются на плоскость полилинии, получаем точки пересечения, потом примитивы обратно и получаем расстояние от вычисленной точки до примитива. Это и будет высота расположения примитива над полилинией в указанной точке. А дальше строишь все чего хочется.
Добрый день! Заранее извиняюсь за некропостинг, сейчас пытаюсь разобраться в твоей отличной программе qp1 (Код 1) и не могу понять где/как "вытащить" искомые координаты точек пересечения.

Это нужно для того чтобы затем попытаться эти координаты подставить в другой код (код 2) где в оригинале эти точки приходится задавать вручную


Код:
[Выделить все]
 
(defun c:qp1 (/                        *error*
              *kpblc-activedoc*        _kpblc-ent-modify-autoregen
              _kpblc-ent-properties-set
              _kpblc-get-ent-no-error-by-type
              _kpblc-conv-2d-to-3d     _kpblc-ent-create-line
              _kpblc-ent-create-lwpline
              _kpblc-error-catch       selset
              align_hor                aggregation
              align_hor_z              align_hor_norm
              lst_inters               pt_inters
              loc:rename-layers->back  loc:layer-rename-lst
              loc:rename-layers->fwd   _kpblc-string-replace
              _kpblc-get-active-space-obj
              orig:coord               orig:normal
              orig:elev                restored
              main_restored            blk_prof
              blk_prof_name            pline_prof
              base_prof                base_level
              cur_pos_x                _kpblc-block-insert-low-level
              tmp                      tmp_pt
              )


  (defun _kpblc-block-insert-low-level (block-name  lst         /
                                        res         x           y
                                        z           ang         msg_pt
                                        msg_ang     do_insert   ins_point
                                        tmp_angle   tmp_block   unnamed_block
                                        cur_layer   is_attr     loc:subst
                                        exp_block   put_point
                                        )

    (defun loc:subst (lst-new lst-old)
      ;; lst-new - ñïèñîê íîâûõ òî÷å÷íûõ ïàð
      ;; lst-old - ìîäèôèöèðóåìûé ñïèñîê
      (vl-remove-if-not
        '(lambda (a) (cdr a))
        (append
          (vl-remove-if '(lambda (x) (cdr (assoc (car x) lst-new))) lst-old)
          lst-new
          ) ;_ end of append
        ) ;_ end of vl-remove-if-not
      ) ;_ end of defun
    (setq x       (cond ((cdr (assoc "x" lst)))
                        (t 1.)
                        ) ;_ end of cond
          y       (cond ((cdr (assoc "y" lst)))
                        (t x)
                        ) ;_ end of cond
          z       (cond ((cdr (assoc "z" lst)))
                        (t x)
                        ) ;_ end of cond
          ang     (cond ((cdr (assoc "ang" lst)))
                        (t 0.)
                        ) ;_ end of cond
          msg_pt  (cond ((cdr (assoc "msg_pt" lst)))
                        (t "Insertion point <Cancel> : ")
                        ) ;_ end of cond
          msg_ang (cond ((cdr (assoc "msg_ang" lst)))
                        (t "Angle to rotate <0.0> : ")
                        ) ;_ end of cond
          ) ;_ end of setq
    (if (cdr (assoc "pt" lst))
      (progn
        (_kpblc-error-catch
          (function
            (lambda ()
              (setq res (vla-insertblock
                          (cond
                            ((cdr (assoc "where" lst)))
                            (t (_kpblc-get-active-space-obj))
                            ) ;_ end of cond
                          (vlax-3d-point (cdr (assoc "pt" lst)))
                          block-name
                          x
                          y
                          z
                          ang
                          ) ;_ end of vla-InsertBlock
                    ) ;_ end of setq
              (if (cdr (assoc "normal" lst))
                (vla-put-normal res (vlax-3d-point (cdr (assoc "normal" lst))))
                ) ;_ end of if
              (if (and (not (cdr (assoc "where" lst)))
                       (not (cdr (assoc "ang" lst)))
                       ) ;_ end of and
                (progn
                  (princ msg_ang)
                  (vl-cmdf "_.change"
                           (vlax-vla-object->ename res)
                           ""
                           ""
                           ""
                           pause
                           ) ;_ end of vl-cmdf
                  ) ;_ end of progn
                ) ;_ end of if
              (setq res (list res))
              ) ;_ end of lambda
            ) ;_ end of function
          '(lambda (x) (alert (strcat "_kpblc-block-insert-low-level : " x)))
          ;nil
          ) ;_ end of _kpblc-error-catch
        ) ;_ end of progn
      (progn
        (setq do_insert t
              ins_point ((lambda ()
                           (trans (list
                                    (- (* 2. (car (getvar "VSMIN"))))
                                    (- (* 2. (cadr (getvar "VSMIN"))))
                                    0.0
                                    ) ;_ end of list
                                  0
                                  1
                                  ) ;_ end of trans
                           ) ;_ end of lambda
                         )
              ) ;_ end of setq
        (if (setq
              tmp_block (car (_kpblc-block-insert-low-level
                               block-name
                               (loc:subst
                                 (list (cons "pt" ins_point)
                                       (cons "ang"
                                             (cond ((cdr (assoc "ang" lst)))
                                                   (t 0.0)
                                                   ) ;_ end of cond
                                             ) ;_ end of cons
                                       (cons "where" nil)
                                       (cons "normal" '(0. 0. 1.))
                                       ) ;_ end of list
                                 lst
                                 ) ;_ end of loc:subst
                               ) ;_ end of setq
                             ) ;_ end of car
              ) ;_ end of setq
          (progn
            (setq unnamed_block
                   (vla-add (vla-get-blocks *kpblc-activedoc*)
                            (vlax-3d-point '(0. 0. 0.))
                            "*U"
                            ) ;_ end of vla-add
                  ) ;_ end of setq
            (_kpblc-block-insert-low-level
              block-name
              (loc:subst
                (list (cons "pt" '(0. 0. 0.))
                      (cons "ang"
                            (cond ((cdr (assoc "ang" lst)))
                                  (t 0.0)
                                  ) ;_ end of cond
                            ) ;_ end of cons
                      (cons "where" unnamed_block)
                      (cons "normal" '(0. 0. 1.))
                      ) ;_ end of list
                lst
                ) ;_ end of loc:subst
              ) ;_ end of _kpblc-block-insert-low-level
            (vla-erase tmp_block)
            ) ;_ end of progn
          (setq do_insert nil)
          ) ;_ end of if
        (while do_insert
          (setq tmp_block
                 (handent
                   (vla-get-handle
                     (car (_kpblc-block-insert-low-level
                            (vla-get-name unnamed_block)
                            (loc:subst
                              (list (cons "pt" ins_point)
                                    (cons "x" 1.)
                                    (cons "y" 1.)
                                    (cons "z" 1.)
                                    (cons "ang" (angle '(0 0 0) (getvar "UCSXDIR")))
                                    (cons "where" nil)
                                    ) ;_ end of list
                              lst
                              ) ;_ end of loc:subst
                            ) ;_ end of _kpblc-block-insert-low-level
                          ) ;_ end of car
                     ) ;_ end of vla-get-Handle
                   ) ;_ end of handent
                ) ;_ end of setq
          (princ msg_pt)
          (vl-cmdf "_.change" tmp_block "" "" pause "")
          (vl-catch-all-apply
            '(lambda ()
               (vla-put-insertionpoint
                 (vla-item
                   (vla-item (vla-get-blocks
                               (vla-get-activedocument (vlax-get-acad-object))
                               ) ;_ end of vla-get-blocks
                             block-name
                             ) ;_ end of vla-item
                   0
                   ) ;_ end of vla-item
                 (vlax-3d-point '(0 0 0))
                 ) ;_ end of vla-put-InsertionPoint
               ) ;_ end of lambda
            ) ;_ end of vl-catch-all-apply
          (if (setq do_insert
                     (not (equal (setq
                                   put_point (trans (cdr (assoc 10 (entget tmp_block)))
                                                    tmp_block
                                                    0
                                                    ) ;_ end of trans
                                   ) ;_ end of setq
                                 ins_point
                                 1e-3
                                 ) ;_ end of EQUAL
                          ) ;_ end of not
                    ) ;_ end of setq
            (progn
              (if (not (cdr (assoc "ang" lst)))
                (progn
                  (princ msg_ang)
                  (vl-cmdf "_.change" tmp_block "" "" "" pause)
                  ) ;_ end of progn
                ) ;_ end of if
              (if do_insert
                (progn
                  (setq exp_block (car (vlax-safearray->list
                                         (vlax-variant-value
                                           (vla-explode
                                             (vlax-ename->vla-object
                                               tmp_block
                                               ) ; _ end of
                                             ) ;_ end of vla-explode
                                           ) ;_ end of vlax-variant-value
                                         ) ;_ end of vlax-safearray->list
                                       ) ;_ end of car
                        ) ;_ end of setq
                  (if (and (= (getvar "attreq") 1)
                           is_attr
                           ) ;_ end of and
                    (command "_.ddatte" (entlast))
                    ) ;_ end of if
                  (vla-put-insertionpoint exp_block (vlax-3d-point put_point))
                  (setq
                    res (append res
                                (list (vlax-ename->vla-object (entlast)))
                                ) ;_ end of append
                    ) ;_ end of setq
                  ) ;_ end of progn
                ) ;_ end of if
              ) ;_ end of progn
            ) ;_ end of if
          (entdel tmp_block)
          (setq do_insert (and do_insert (cdr (assoc "multi" lst))))
          ) ;_ end of while
        ) ;_ end of progn
      ) ;_ end of if

    res
    ) ;_ end of defun

  (defun _kpblc-get-active-space-obj ()
    (if (and (zerop (vla-get-activespace *kpblc-activedoc*))
             (= :vlax-false (vla-get-mspace *kpblc-activedoc*))
             ) ;_ end of and
      (vla-get-paperspace *kpblc-activedoc*)
      (vla-get-modelspace *kpblc-activedoc*)
      ) ;_ end of if
    ) ;_ end of defun

  (defun _kpblc-error-catch (protected-function
                             on-error-function
                             /
                             catch_error_result
                             )
    (setq catch_error_result (vl-catch-all-apply protected-function))
    (if (and (vl-catch-all-error-p catch_error_result)
             on-error-function
             ) ;_ end of and
      (apply on-error-function
             (list (vl-catch-all-error-message catch_error_result))
             ) ;_ end of apply
      catch_error_result
      ) ;_ end of if
    ) ;_ end of defun

  (defun *error* (msg)
    (loc:rename-layers->back)
    (if (not main_restored)
      (progn
        (vla-put-elevation align_hor align_hor_z)
        (vla-put-normal align_hor align_hor_norm)
        ) ;_ end of progn
      ) ;_ end of if
    (vla-endundomark *kpblc-activedoc*)
    (princ msg)
    (princ)
    ) ;_ end of defun

  (defun _kpblc-conv-2d-to-3d (point)
    (list (car point)
          (cadr point)
          (if (caddr point)
            (caddr point)
            0.0
            ) ;_ end of if
          ) ;_ end of list
    ) ;_ end of defun

  ;|=============================================================================
*    Setting to entity some properties.
*    Call parameters:
*	ent	vla-pointer to entity
*	lst	list like '((<PropertyName> . <Value>))
*    Returns vla-pointer to changed entity. There are some properties has default
* values:
*	color	(getvar "cecolor")
*	layer	"0"
*	ltype	"Continuous"
*    For "normal" and "closed" properties values are not vla!
=============================================================================|;
  (defun _kpblc-ent-properties-set (ent lst / res_lst loc:color loc:ltype
                                    loc:layer)
    (setq res_lst lst
          loc:layer
           (cons "layer"
                 (cond
                   ((cdr (assoc "layer" res_lst)))
                   (t "0")
                   ) ;_ end of cond
                 ) ;_ end of cons
          loc:color
           (cons "color"
                 (cond
                   ((not (cdr (assoc "color" res_lst))) 256)
                   ((= (type (cdr (assoc "color" res_lst))) 'str)
                    (cond
                      ((= (strcase (cdr (assoc "color" res_lst))) "BYBLOCK")
                       0
                       )
                      ((= (strcase (cdr (assoc "color" res_lst))) "BYLAYER")
                       256
                       )
                      ) ;_ end of cond
                    )
                   ((cdr (assoc "color" res_lst)))
                   ((= (strcase (getvar "cecolor") nil) "BYBLOCK") 0)
                   ((= (strcase (getvar "cecolor") nil) "BYLAYER") 256)
                   (t (getvar "cecolor"))
                   ) ;_ end of cond
                 ) ;_ end of cons
          loc:ltype
           (cons
             "linetype"
             (cond
               ((or
                  (not (cdr (assoc "ltype" res_lst)))
                  (= (strcase (cdr (assoc "ltype" res_lst)) t) "bylayer")
                  ) ;_ end of or
                "ByLayer"
                )
               ((= (strcase (cdr (assoc "ltype" res_lst)) t) "byblock")
                "ByBlock"
                )
               ((= (strcase (cdr (assoc "ltype" res_lst)) t)
                   "continuous"
                   ) ;_ end of =
                "Continuous"
                )
               (t
                (vla-get-name
                  (_kpblc-linetype-load
                    (cdr (assoc "ltype" res_lst))
                    (if (assoc "ltypefile" res_lst)
                      (cdr (assoc "ltypefile" res_lst))
                      nil
                      ) ;_ end of if
                    ) ;_ end of _kpblc-linetype-load
                  ) ;_ end of vla-get-name
                )
               ) ;_ end of cond
             ) ;_ end of cons
          ) ;_ end of setq
    (foreach x
               '(("align" . "alignment")
                 ("elev" . "elevation")
                 ("hatang" . "patternangle")
                 ("hatscale" . "patternscale")
                 ("hatspace" . "patternspace")
                 ("ins" . "insertionpoint")
                 ("ltype" . "linetype")
                 ("ltypegen" . "linetypegeneration")
                 ("lw" . "lineweight")
                 ("obliq" . "obliqueangle")
                 ("rot" . "rotation")
                 ("string" . "textstring")
                 ("textstyle" . "stylename")
                 ("width" . "constantwidth")
                 )
      (setq res_lst
             (subst (cons (cdr x) (cdr (assoc (car x) res_lst)))
                    (assoc (car x) res_lst)
                    res_lst
                    ) ;_ end of subst
            ) ;_ end of setq
      ) ;_ end of foreach
    (if (cdr (assoc "color" res_lst))
      (setq res_lst
             (subst loc:color
                    (assoc "color" res_lst)
                    res_lst
                    ) ;_ end of subst
            ) ;_ end of setq
      (setq res_lst (append (list loc:color) res_lst))
      ) ;_ end of if
    (if (cdr (assoc "linetype" res_lst))
      (setq res_lst (subst loc:ltype
                           (assoc "linetype" res_lst)
                           res_lst
                           ) ;_ end of subst
            ) ;_ end of setq
      (setq res_lst (append (list loc:ltype) res_lst))
      ) ;_ end of if
    (if (cdr (assoc "layer" res_lst))
      (setq res_lst (subst loc:layer
                           (assoc "layer" res_lst)
                           res_lst
                           ) ;_ end of subst
            ) ;_ end of setq
      (setq res_lst (append (list loc:layer) res_lst))
      ) ;_ end of if
    (foreach x '("normal" "color" "linetype" "lineweight")
      (if (cdr (assoc x res_lst))
        (cond
          ((and (= x "normal")
                (/= (type (assoc x res_lst)) 'variant)
                ) ;_ end of and
           (setq
             res_lst (subst (cons x
                                  (vlax-3d-point (cdr (assoc x res_lst)))
                                  ) ;_ end of cons
                            (assoc x res_lst)
                            res_lst
                            ) ;_ end of subst
             ) ;_ end of setq
           )
          ((= x "closed")
           (setq
             res_lst
              (subst
                (cons
                  x
                  (_kpblc-conv-value-bool-to-vla (cdr (assoc x res_lst)))
                  ) ;_ end of cons
                (assoc x res_lst)
                res_lst
                ) ;_ end of subst
             ) ;_ end of setq
           )
          ) ;_ end of cond
        ) ;_ end of if
      ) ;_ end of foreach
    (vl-remove-if
      '(lambda (x)
         (member (strcase (car x) t)
                 '("where" "ltypefile" "inner" "outer")
                 ) ;_ end of member
         ) ;_ end of lambda
      res_lst
      ) ;_ end of vl-remove-if
    (mapcar
      '(lambda (prop)
         (if (vlax-property-available-p ent (car prop))
           (_kpblc-error-catch
             (function
               (lambda ()
                 (if (and (vlax-read-enabled-p ent)
                          (vlax-write-enabled-p ent)
                          (vlax-property-available-p ent (car prop) t)
                          ) ;_ end of and
                   (vlax-put-property ent (car prop) (cdr prop))
                   ) ;_ end of if
                 ) ;_ end of lambda
               ) ;_ end of function
             (function
               (lambda (x)
                 (princ (strcat "\nERROR _kpblc-ent-properties-set "
                                x
                                "; "
                                (vla-get-objectname ent)
                                "; property : "
                                (car prop)
                                "; value : "
                                (_kpblc-conv-value-to-string (cdr prop))
                                ) ;_ end of strcat
                        ) ;_ end of princ
                 nil
                 ) ;_ end of lambda
               ) ;_ end of function
             ) ;_ end of _kpblc-error-catch
           ) ;_ end of if
         ) ;_ end of lambda
      res_lst
      ) ;_ end of mapcar
    ent
    ) ;_ end of defun

  ;|=============================================================================
*    Adds lightweightpolyline
*    Call parameters are like params in _kpblc-ent-create-line
=============================================================================|;
  (defun _kpblc-ent-create-lwpline (lst point-list / res point_list)
    (_kpblc-error-catch
      (function
        (lambda ()
          (setq res
                 (vla-addlightweightpolyline
                   (if (and (assoc "where" lst)
                            (cdr (assoc "where" lst))
                            ) ;_ end of and
                     (cdr (assoc "where" lst))
                     (_kpblc-get-active-space-obj)
                     ) ;_ end of if
                   (vlax-make-variant
                     (vlax-safearray-fill
                       (vlax-make-safearray
                         vlax-vbdouble
                         (cons 1
                               (length (setq point-list
                                              (apply
                                                'append
                                                (mapcar '(lambda (point)
                                                           (list (car point) (cadr point))
                                                           ) ;_ end of lambda
                                                        point-list
                                                        ) ;_ end of mapcar
                                                ) ;_ end of apply
                                             ) ;_ end of setq
                                       ) ;_ end of LENGTH
                               ) ;_ end of cons
                         ) ;_ end of vlax-make-safearray
                       point-list
                       ) ;_ end of vlax-safearray-fill
                     ) ;_ end of vlax-make-variant
                   ) ;_ end of vla-addlightweightpolyline
                ) ;_ end of setq
          (_kpblc-ent-properties-set res lst)
          ) ;_ end of lambda
        ) ;_ end of function
      (function (lambda (x)
                  (princ (strcat "\nERROR : _kpblc-ent-create-lwpline " x))
                  nil
                  ) ;_ end of lambda
                ) ;_ end of function
      ) ;_ end of _kpblc-error-catch
    res
    ) ;_ end of defun

  ;|=============================================================================
*    Adds a single-line text. Call parameters
*	lst:
      '(("where" . <vla-pointer where to add text>)
	("string" . "TextString")	; nil -> ""
	("height" . 2.5)		; nil -> 2.5
	("align" . acAlignmentMiddleCenter)	; nil -> acAlignmentLeft
	("layer" . "MyLayer")		; nil -> "0"
	("lw" . 25)			; lineweight. nil -> 0
	("ltype" . "Continuous")	; linetype. nil -> Continuous
	("color" . 0)			; color. nil -> (getvar "cecolor")
	(cons "normal" '(0. 0. 1.))	; normal for line. nil -> current
	("rot" . 0.)			; rotation. nil -> 0
	("style" . "MyTextStyle")	; text style for text. nil-> current
	)
*	pt	-> insertion point 
=============================================================================|;
  (defun _kpblc-ent-create-text (lst pt / res)
    (_kpblc-error-catch
      (function
        (lambda ()
          (setq res (vla-addtext
                      (cdr (assoc "where" lst))
                      (cond ((cdr (assoc "string" lst)))
                            (t "")
                            ) ;_ end of cond
                      (vlax-3d-point pt)
                      (cond ((cdr (assoc "height" lst)))
                            (t 2.5)
                            ) ;_ end of cons
                      ) ;_ end of vla-AddText
                ) ;_ end of setq
          (_kpblc-ent-properties-set res lst)
          (if (and (cdr (assoc "align" lst))
                   (/= (cdr (assoc "align" lst)) acalignmentleft)
                   ) ;_ end of and
            (progn
              (vla-put-textalignmentpoint res (vlax-3d-point pt))
              (vla-put-insertionpoint res (vlax-3d-point pt))
              ) ;_ end of progn
            ) ;_ end of if
          ) ;_ end of lambda
        ) ;_ end of function
      (function (lambda (x)
                  (princ (strcat "\nERROR _kpblc-ent-create-text " x))
                  nil
                  ) ;_ end of lambda
                ) ;_ end of function
      ) ;_ end of _kpblc-error-catch
    ) ;_ end of defun

  ;|=============================================================================
*    Adds line by parameters.
*    Call parameters:
*	param	list like this:
      '(("where" . <vla-point>)	; where to add line
	("lw" . 25)		; lineweight to new line. nil -> 0
	("ltype" . "Continuous"); linetype. nil -> Continuous
	("color" . 0)		; color. nil -> (getvar "cecolor")
	("layer" . "MyLayer")	; layer for new line. Have to be defined. nil -> "0"
	(cons "normal" '(0. 0. 1.))	; normal for line. nil -> current
	)
	point-list	list of 2 3Dpoints
*    Returns vla-pointer to created line
=============================================================================|;
  (defun _kpblc-ent-create-line (lst point-list / res point_list)
    (_kpblc-error-catch
      (function
        (lambda ()
          (setq res
                 (vla-addline
                   (if (and (assoc "where" lst)
                            (cdr (assoc "where" lst))
                            ) ;_ end of and
                     (cdr (assoc "where" lst))
                     (_kpblc-get-active-space-obj)
                     ) ;_ end of if
                   (vlax-3d-point (_kpblc-conv-2d-to-3d (car point-list)))
                   (vlax-3d-point (_kpblc-conv-2d-to-3d (cadr point-list)))
                   ) ;_ end of vla-addline
                ) ;_ end of setq
          (_kpblc-ent-properties-set res lst)
          ) ;_ end of lambda
        ) ;_ end of function
      (function (lambda (x)
                  (princ (strcat "\nERROR : _kpblc-line-add " x))
                  nil
                  ) ;_ end of lambda
                ) ;_ end of function
      ) ;_ end of _kpblc-error-catch
    res
    ) ;_ end of defun

  (defun loc:rename-layers->back ()
    (foreach item loc:layer-rename-lst
      (vla-put-name
        (vla-item (vla-get-layers *kpblc-activedoc*) (car item))
        (cdr item)
        ) ;_ end of vla-put-name
      ) ;_ end of foreach
    ) ;_ end of defun

  (defun loc:rename-layers->fwd (/ name)
    (vlax-for item (vla-get-layers *kpblc-activedoc*)
      (if (wcmatch (vla-get-name item) "*_*")
        (progn
          (setq name                 (_kpblc-string-replace (vla-get-name item) "_" "-")
                loc:layer-rename-lst (append loc:layer-rename-lst
                                             (list
                                               (cons (vla-get-name item) name)
                                               ) ;_ end of list
                                             ) ;_ end of append
                ) ;_ end of setq
          (vla-put-name item name)
          ) ;_ end of progn
        ) ;_ end of if
      (if (wcmatch (vla-get-name item) "* *")
        (progn
          (setq name                 (_kpblc-string-replace (vla-get-name item) "$" " ")
                loc:layer-rename-lst (append loc:layer-rename-lst
                                             (list
                                               (cons (vla-get-name item) name)
                                               ) ;_ end of list
                                             ) ;_ end of append
                ) ;_ end of setq
          (vla-put-name item name)
          ) ;_ end of progn
        ) ;_ end of if
      ) ;_ end of vlax-for
    ) ;_ end of defun

  (defun _kpblc-string-replace (string old_substr new_substr / pos)
    (while (setq pos (vl-string-search old_substr string))
      (setq string
             (strcat
               (substr string 1 pos)
               new_substr
               (_kpblc-string-replace
                 (substr string (+ (strlen old_substr) pos 1))
                 old_substr
                 new_substr
                 ) ;_ end of _kpblc-string-replace
               ) ;_ end of strcat
            ) ;_ end of setq
      ) ;_ end of while
    string
    ) ;_ end of defun

  (defun _kpblc-get-ent-no-error-by-type (enttype msg / ent)
    (vl-catch-all-apply
      (function
        (lambda ()
          (setvar "errno" 0)
          (if (not msg)
            (setq msg "Select an entity : ")
            ) ;_ end of if
          (setq msg (strcat (vl-string-trim "\n: " msg) " : "))
          (princ msg)
          (while (or (not (setq ent (ssget "_+.:E:S" (list (cons 0 enttype)))))
                     (= 7 (getvar "errno"))
                     ) ;_ end of or
            (setvar "errno" 0)
            (princ "\nError selection (not expected type)!")
            (princ msg)
            ) ;_ end of while
          (cond
            ((= (getvar "errno") 52)
             nil
             )
            (t (ssname ent 0))
            ) ;_ end of cond
          ) ;_ end of lambda
        ) ;_ end of function
      ) ;_ end of vl-catch-all-apply
    ) ;_ end of defun

  (defun _kpblc-ent-modify-autoregen (ent        bit        value
                                      ext_regen  /          ent_list
                                      old_dxf    new_dxf    layer_dxf70
                                      )
    (setq ent_list (entget ent)
          new_dxf  (cons bit
                         (if (and (= bit 62) (= (type value) 'str))
                           (if (= (strcase value) "BYLAYER")
                             256
                             0
                             ) ;_ end of if 
                           value
                           ) ;_ end of if 
                         ) ;_ end of cons 
          ) ;_ end of setq 
    (if (not (equal new_dxf (setq old_dxf (assoc bit ent_list))))
      (progn
        (entmod (if old_dxf
                  (subst new_dxf old_dxf ent_list)
                  (append ent_list (list new_dxf))
                  ) ;_ end of if 
                ) ;_ end of entmod
        (if ent_regen
          (entupd ent)
          (redraw ent)
          ) ;_ end of if
        ) ;_ end of progn
      ) ;_ end of if
    ent
    ) ;_ end of defun

  (defun _kpblc-style-create-textstyle (name font / text_style)
    (setq text_style
           (vla-add (vla-get-textstyles *kpblc-activedoc*)
                    name
                    ) ;_ end of vla-add
          ) ;_ end of setq
    (vla-put-fontfile text_style font)
    (vla-put-height text_style 0.0)
    (vla-put-obliqueangle text_style 0.0)
    (vla-put-width text_style 0.9)
    (_kpblc-ent-modify-autoregen (vlax-vla-object->ename text_style) 4 "" t)
    (_kpblc-ent-modify-autoregen (vlax-vla-object->ename text_style) 71 0 t)
    (vla-put-activetextstyle *kpblc-activedoc* text_style)
    ) ;_ end of defun

  (defun loc:get-all-layers-names (/ lst)
    (vlax-for lay (vla-get-layers *kpblc-activedoc*)
      (setq lst (append lst (list (vla-get-name lay))))
      ) ;_ end of vlax-for
    (acad_strlsort lst)
    ) ;_ end of defun

  (defun _kpblc-ent-conv-z-to-0 (ent / pt loc:transpoint)

    (defun loc:transpoint (point ent)
      (if
        (and
          (vlax-property-available-p ent 'normal)
          (not (equal
                 (vlax-safearray->list (vlax-variant-value (vla-get-normal ent)))
                 '(0. 0. 1.)
                 1e-6
                 ) ;_ end of equal
               ) ;_ end of not
          ) ;_ end of and
         (trans point
                (vlax-safearray->list (vlax-variant-value (vla-get-normal ent)))
                0
                ) ;_ end of trans
         point
         ) ;_ end of if
      ) ;_ end of defun

    (cond
      ((= (vla-get-objectname ent) "AcDbPoint")
       (vla-put-coordinates
         ent
         (loc:transpoint
           (vlax-safearray->list (vlax-variant-value (vla-get-coordinates ent)))
           ent
           ) ;_ end of loc:transpoint
         ) ;_ end of vla-put-Coordinates
       )
      ((= (vla-get-objectname ent) "AcDbLine")
       (mapcar
         '(lambda (x)
            (vlax-put-property
              ent
              x
              (loc:transpoint
                (vlax-safearray->list
                  (vlax-variant-value (vlax-get-property ent x))
                  ) ;_ end of vlax-safearray->list
                ent
                ) ;_ end of loc:transpoint
              ) ;_ end of vlax-put-property
            ) ;_ end of lambda
         '("startpoint" "endpoint")
         ) ;_ end of mapcar
       )
      ((member (vla-get-objectname ent) '("AcDbPolyline" "AcDb3dPolyline"))
       (vla-put-coordinates
         ent
         (vlax-make-variant
           (vlax-safearray-fill
             (vlax-make-safearray
               vlax-vbdouble
               (cons 1
                     (length
                       (setq pt
                              (apply
                                'append
                                (mapcar
                                  '(lambda (x)
                                     (loc:transpoint x ent)
                                     ) ;_ end of lambda
                                  (cond
                                    ((= (vla-get-objectname ent) "AcDbPolyline")
                                     (_kpblc-conv-list-to-2dpoints
                                       (vlax-safearray->list
                                         (vlax-variant-value (vla-get-coordinates ent))
                                         ) ;_ end of vlax-safearray->list
                                       ) ; _ end of
                                     )
                                    ((= (vla-get-objectname ent) "AcDb3dPolyline")
                                     (_kpblc-conv-list-to-3dpoints
                                       (vlax-safearray->list
                                         (vlax-variant-value (vla-get-coordinates ent))
                                         ) ;_ end of vlax-safearray->list
                                       ) ; _ end of
                                     )
                                    ) ;_ end of cond
                                  ) ;_ end of mapcar
                                ) ;_ end of apply
                             ) ;_ end of setq
                       ) ;_ end of length
                     ) ;_ end of cons
               ) ;_ end of vlax-make-safearray
             pt
             ) ;_ end of vlax-safearray-fill
           ) ;_ end of vlax-make-variant
         ) ;_ end of vla-put-Coordinates
       )
      ((= (vla-get-objectname ent) "AcDbSpline")
       (foreach prop '("controlpoints" "fitpoints")
         (vlax-put-property
           ent
           prop
           (vlax-make-variant
             (vlax-safearray-fill
               (vlax-make-safearray
                 vlax-vbdouble
                 (cons
                   0
                   (length
                     (setq pt (apply
                                'append
                                (mapcar
                                  '(lambda (x)
                                     (loc:transpoint x ent)
                                     ) ;_ end of lambda
                                  (_kpblc-conv-list-to-3dpoints
                                    (vlax-safearray->list
                                      (vlax-variant-value
                                        (vlax-get-property ent prop)
                                        ) ;_ end of vlax-variant-value
                                      ) ;_ end of vlax-safearray->list
                                    ) ;_ end of _kpblc-conv-list-to-3dpoints
                                  ) ;_ end of mapcar
                                ) ;_ end of apply
                           ) ;_ end of setq
                     ) ;_ end of length
                   ) ;_ end of cons
                 ) ;_ end of vlax-make-safearray
               pt
               ) ;_ end of vlax-safearray-fill
             ) ;_ end of vlax-make-variant
           ) ;_ end of vlax-put-property
         ) ;_ end of foreach
       )
      ) ;_ end of cond
    (mapcar
      '(lambda (x)
         (_kpblc-error-catch
           (function
             (lambda ()
               (if (vlax-property-available-p ent (car x))
                 (vlax-put-property ent (car x) (cdr x))
                 ) ;_ end of if
               ) ;_ end of lambda
             ) ;_ end of function
           (function (lambda (x)
                       (princ (strcat "\nERROR : _kpblc-ent-conv-z-to-0 : "
                                      (vl-princ-to-string x)
                                      ) ;_ end of strcat
                              ) ;_ end of princ
                       nil
                       ) ;_ end of lambda
                     ) ;_ end of function
           ) ;_ end of _kpblc-error-catch
         ) ;_ end of lambda
      (list (cons "normal" (vlax-3d-point '(0. 0. 1.)))
            (cons "elevation" 0.)
            ) ;_ end of list
      ) ;_ end of mapcar
    ) ;_ end of defun

  (defun _kpblc-conv-list-to-3dpoints (lst / res)
    (cond
      ((not lst)
       nil
       )
      (t
       (setq res (cons
                   (list (car lst)
                         (if (cadr lst)
                           (cadr lst)
                           0.
                           ) ;_ end of if
                         (if (caddr lst)
                           (caddr lst)
                           0.
                           ) ;_ end of if
                         ) ;_ end of list
                   (_kpblc-conv-list-to-3dpoints (cdddr lst))
                   ) ;_ end of cons
             ) ;_ end of setq
       )
      ) ;_ end of cond
    res  
    ) ;_ end of defun

  (defun _kpblc-conv-list-to-2dpoints (lst / res)
    (cond
      ((not lst)
       nil
       )
      (t
       (setq res (cons (list (car lst)
                             (if (cadr lst)
                               (cadr lst)
                               0.
                               ) ;_ end of if
                             ) ;_ end of list
                       (_kpblc-conv-list-to-2dpoints (cddr lst))
                       ) ;_ end of cons
             ) ;_ end of setq
       )
      ) ;_ end of cond
    res
    ) ;_ end of defun


  (vl-load-com)
  (setq *kpblc-activedoc* (vla-get-activedocument (vlax-get-acad-object)))
  (vla-startundomark *kpblc-activedoc*)
  (if (= (caddr (trans '(0. 0. 1.) 0 1)) 1.)
    (progn
      (loc:rename-layers->fwd)
      (initget ((lambda (/ str)
                  (foreach item (loc:get-all-layers-names)
                    (setq str (strcat (if str
                                        (strcat str " ")
                                        ""
                                        ) ;_ end of if
                                      item
                                      ) ;_ end of strcat
                          ) ;_ end of setq
                    ) ;_ end of foreach
                  str
                  ) ;_ end of lambda
                )
               ) ;_ end of initget
      (if
        (and (setq
               lay (getkword (strcat
                               "\nEnter the name of layer "
                               "["
                               ((lambda (/ str)
                                  (foreach item (loc:get-all-layers-names)
                                    (setq str (strcat (if str
                                                        (strcat str "/")
                                                        ""
                                                        ) ;_ end of if
                                                      item
                                                      ) ;_ end of strcat
                                          ) ;_ end of setq
                                    ) ;_ end of foreach
                                  ) ;_ end of lambda
                                )
                               "]"
                               "<Exit> : "
                               ) ;_ end of strcat
                             ) ;_ end of GETKWORD
               ) ;_ end of setq
             (/= lay "")
             (setq selset (ssget "_X"
                                 (list '(0 . "LINE,*POLYLINE,SPLINE")
                                       (cons 8 lay)
                                       ) ;_ end of list
                                 ) ;_ end of ssget
                   ) ;_ end of setq
             (not (vl-catch-all-error-p
                    (setq align_hor (_kpblc-get-ent-no-error-by-type
                                      "LWPOLYLINE"
                                      "Horizonal alignment : "
                                      ) ; _ end of
                          ) ;_ end of setq
                    ) ;_ end of vl-catch-all-error-p
                  ) ;_ end of not
             ) ;_ end of and
         (_kpblc-error-catch
           (function
             (lambda ()
               (setq align_hor (vlax-ename->vla-object align_hor))
               (_kpblc-style-create-textstyle
                 "PMSF-TEXT"
                 (findfile "Romans.shx")
                 ) ;_ end of _kpblc-style-create-textstyle
               (mapcar '(lambda (x)
                          (_kpblc-ent-create-text
                            (list (cons "where" (_kpblc-get-active-space-obj))
                                  (cons "style" "PMSF-TEXT")
                                  (cons "height" 2.5)
                                  (cons "lw" aclnwtbylayer)
                                  (cons "ltype" "bylayer")
                                  (cons "color" "bylayer")
                                  (cons "string" (car x))
                                  ) ;_ end of list
                            (cdr x)
                            ) ;_ end of _kpblc-ent-create-text
                          ) ;_ end of LAMBDA
                       (list (cons "A" (vlax-curve-getstartpoint align_hor))
                             (cons "B" (vlax-curve-getendpoint align_hor))
                             ) ;_ end of list
                       ) ;_ end of mapcar
               (initget 2)
               (setq aggregation    (cond
                                      ((getreal
                                         "\nEnter the vertical exaggeration <1.> : "
                                         ) ;_ end of getreal
                                       )
                                      (t 1.)
                                      ) ;_ end of cond
                     align_hor_z    (vla-get-elevation align_hor)
                     align_hor_norm (vla-get-normal align_hor)
                     ) ;_ end of setq
               (_kpblc-ent-conv-z-to-0 align_hor)
               (foreach item
                        (mapcar
                          'vlax-ename->vla-object
                          (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset)))
                          ) ;_ end of mapcar
                 (setq restored nil)
                 (cond
                   ((= (vla-get-objectname item) "AcDbLine")
                    (setq orig:coord  (list (vla-get-startpoint item)
                                            (vla-get-endpoint item)
                                            ) ;_ end of list
                          orig:normal (vla-get-normal item)
                          ) ;_ end of setq	    
                    (_kpblc-ent-conv-z-to-0 item)
                    (if (<= 0
                            (vlax-safearray-get-u-bound
                              (setq pt_inters
                                     (vlax-variant-value
                                       (vla-intersectwith
                                         item
                                         align_hor
                                         acextendnone
                                         ) ;_ end of vla-IntersectWith
                                       ) ;_ end of vlax-variant-value
                                    ) ;_ end of setq
                              1
                              ) ;_ end of vlax-safearray-get-u-bound
                            ) ;_ end of <=
                      (progn
                        (setq lst_inters
                               (append
                                 lst_inters
                                 (list
                                   (list
                                     (vlax-curve-getdistatpoint
                                       align_hor
                                       (setq pt_inters
                                              (vlax-safearray->list pt_inters)
                                             ) ;_ end of setq
                                       ) ;_ end of vlax-curve-getdistatpoint
                                     (caddr
                                       (vlax-curve-getclosestpointtoprojection
                                         ((lambda ()
                                            (setq restored t)
                                            (vla-put-startpoint item (car orig:coord))
                                            (vla-put-endpoint item (cadr orig:coord))
                                            (vla-put-normal item orig:normal)
                                            item
                                            ) ;_ end of lambda
                                          )
                                         pt_inters
                                         '(0. 0. 1.)
                                         ) ; _ end of
                                       ) ;_ end of caddr
                                     ) ;_ end of list
                                   ) ;_ end of list
                                 ) ;_ end of append
                              ) ;_ end of setq		
                        ) ;_ end of progn
                      ) ;_ end of if
                    (if (not restored)
                      (progn
                        (vla-put-startpoint item (car orig:coord))
                        (vla-put-endpoint item (cadr orig:coord))
                        (vla-put-normal item orig:normal)
                        ) ;_ end of progn
                      ) ;_ end of if
                    )
                   ((member (vla-get-objectname item)
                            '("AcDbPolyline" "AcDb3dPolyline")
                            ) ;_ end of member
                    (setq orig:coord  (vla-get-coordinates item)
                          orig:normal (vla-get-normal item)
                          orig:elev   (if (= (vla-get-objectname item) "AcDbPolyline")
                                        (vla-get-elevation item)
                                        ) ;_ end of if
                          ) ;_ end of setq
                    (_kpblc-ent-conv-z-to-0 item)
                    (if (<= 0
                            (vlax-safearray-get-u-bound
                              (setq pt_inters
                                     (vlax-variant-value
                                       (vla-intersectwith
                                         item
                                         align_hor
                                         acextendnone
                                         ) ;_ end of vla-IntersectWith
                                       ) ;_ end of vlax-variant-value
                                    ) ;_ end of setq
                              1
                              ) ;_ end of vlax-safearray-get-u-bound
                            ) ;_ end of <=
                      (progn
                        (setq lst_inters
                               (append
                                 lst_inters
                                 (mapcar
                                   '(lambda (x)
                                      (list
                                        (vlax-curve-getdistatpoint
                                          align_hor
                                          x
                                          ) ; _ end of
                                        (caddr
                                          (vlax-curve-getclosestpointtoprojection
                                            ((lambda ()
                                               (setq restored t)
                                               (vla-put-coordinates item orig:coord)
                                               (vla-put-normal item orig:normal)
                                               (vl-catch-all-apply
                                                 '(lambda ()
                                                    (vla-put-elevation item orig:elev)
                                                    ) ;_ end of lambda
                                                 ) ; _ end of
                                               item
                                               ) ;_ end of lambda
                                             )
                                            x
                                            '(0. 0. 1.)
                                            ) ; _ end of
                                          ) ;_ end of caddr
                                        ) ;_ end of list
                                      ) ;_ end of lambda
                                   (_kpblc-conv-list-to-3dpoints
                                     (vlax-safearray->list pt_inters)
                                     ) ;_ end of _kpblc-conv-list-to-3dpoints				   
                                   ) ;_ end of mapcar
                                 ) ;_ end of append
                              ) ;_ end of setq
                        ) ;_ end of progn
                      ) ;_ end of if
                    (if (not restored)
                      (progn
                        (vla-put-coordinates item orig:coord)
                        (vla-put-normal item orig:normal)
                        (if (= (vla-get-objectname item) "AcDbPolyline")
                          (vla-put-elevation item orig:elev)
                          ) ;_ end of if
                        ) ;_ end of progn
                      ) ;_ end of if
                    )
                   ((= (vla-get-objectname item) "AcDbSpline")
                    (setq orig:coord
                                      (list (vla-get-controlpoints item)
                                            (vla-get-fitpoints item)
                                            ) ;_ end of list
                          orig:normal (vla-get-normal item)
                          ) ;_ end of setq
                    (_kpblc-ent-conv-z-to-0 item)
                    (if (<= 0
                            (vlax-safearray-get-u-bound
                              (setq pt_inters
                                     (vlax-variant-value
                                       (vla-intersectwith
                                         item
                                         align_hor
                                         acextendnone
                                         ) ;_ end of vla-IntersectWith
                                       ) ;_ end of vlax-variant-value
                                    ) ;_ end of setq
                              1
                              ) ;_ end of vlax-safearray-get-u-bound
                            ) ;_ end of <=
                      (progn
                        (setq lst_inters
                               (append
                                 lst_inters
                                 (list
                                   (list
                                     (vlax-curve-getdistatpoint
                                       align_hor
                                       (setq pt_inters
                                              (vlax-safearray->list pt_inters)
                                             ) ;_ end of setq
                                       ) ;_ end of vlax-curve-getdistatpoint
                                     (caddr
                                       (vlax-curve-getclosestpointtoprojection
                                         ((lambda ()
                                            (setq restored t)
                                            (vla-put-coordinates item orig:coord)
                                            (vla-put-normal item orig:normal)
                                            item
                                            ) ;_ end of lambda
                                          )
                                         pt_inters
                                         '(0. 0. 1.)
                                         ) ; _ end of
                                       ) ;_ end of caddr
                                     ) ;_ end of list
                                   ) ;_ end of list
                                 ) ;_ end of append
                              ) ;_ end of setq		
                        ) ;_ end of progn
                      ) ;_ end of if
                    (if (not restored)
                      (progn
                        (vla-put-normal item orig:normal)
                        (vla-put-controlpoints item (car orig:coord))
                        (vla-put-fitpoints item (cadr orig:coord))
                        ) ;_ end of progn
                      ) ;_ end of if
                    )
                   ) ;_ end of cond
                 ) ;_ end of foreach
               (setq base_level (cadar (vl-sort lst_inters
                                                '(lambda (a b) (< (cadr a) (cadr b)))
                                                ) ;_ end of vl-sort
                                       ) ;_ end of cadar
                     lst_inters (mapcar '(lambda (x)
                                           (list (car x)
                                                 (- (cadr x) base_level)
						 ;;;(- (cadr x) 0);;;
                                                 ) ;_ end of list
                                           ) ;_ end of LAMBDA
                                        (vl-sort lst_inters
                                                 '(lambda (a b) (< (car a) (car b)))
                                                 ) ;_ end of vl-sort
                                        ) ;_ end of mapcar
                     blk_prof   (vla-add
                                  (vla-get-blocks *kpblc-activedoc*)
                                  (vlax-3d-point '(0. 0. 0.))
                                  (setq blk_prof_name
                                         (strcat "profile_"
                                                 (vl-princ-to-string
                                                   (fix (getvar "cdate"))
                                                   ) ; _ end of
                                                 "_"
                                                 (vl-string-trim
                                                   "0."
                                                   (vl-princ-to-string
                                                     (- (getvar "cdate")
                                                        (fix (getvar "cdate"))
                                                        ) ;_ end of -
                                                     ) ; _ end of
                                                   ) ;_ end of vl-string-trim
                                                 ) ;_ end of strcat
                                        ) ;_ end of setq
                                  ) ;_ end of vla-add
                     ) ;_ end of setq
	       
               (vla-put-elevation align_hor align_hor_z)
               (vla-put-normal align_hor align_hor_norm)
               (setq main_restored
                      t
                     align_hor_z
                      (cond
                        ((getreal
                           (strcat "\nBase line lower <"
                                   (vl-princ-to-string
                                     (car (vl-sort
                                            (mapcar 'cadr lst_inters)
                                            '(lambda (a b)
                                               (< a b)
                                               ) ; _ end of
                                            ) ; _ end of
                                          ) ;_ end of car
                                     ) ; _ end of
                                   "> : "
                                   ) ;_ end of strcat
                           ) ;_ end of getreal
                         )
                        (t
                         (car (vl-sort
                                (mapcar 'cadr lst_inters)
                                '(lambda (a b)
                                   (< a b)
                                   ) ;_ end of lambda
                                ) ;_ end of vl-sort
                              ) ;_ end of car
                         )
                        ) ;_ end of cond
                     base_prof
                      (_kpblc-ent-create-line
                        (list (cons "where" blk_prof)
                              (cons "lw" aclnwtbyblock)
                              (cons "ltype" "byblock")
                              (cons "color" 0)
                              (cons "layer" "0")
                              ) ;_ end of list
                        (list (list 0. 0.)
                              (list (vlax-curve-getdistatpoint
                                      align_hor
                                      (vlax-curve-getendpoint align_hor)
                                      ) ; _ end of
                                    0.
                                    ) ;_ end of list
                              ) ;_ end of list
                        ) ;_ end of _kpblc-ent-create-line
                     pline_prof
                      (_kpblc-ent-create-lwpline
                        (list (cons "where" blk_prof)
                              (cons "lw" aclnwtbyblock)
                              (cons "ltype" "byblock")
                              (cons "color" 0)
                              (cons "layer" "0")
                              ) ;_ end of list
                        lst_inters
                        ) ;_ end of _kpblc-ent-create-lwpline
                     lst_inters
                      (vl-sort
                        (append
                          lst_inters
                          (mapcar
                            '(lambda (x / tmp res)
                               (setq res
                                      (vlax-safearray->list
                                        (vlax-variant-value
                                          (vla-intersectwith
                                            pline_prof
                                            (setq
                                              tmp
                                               (vla-addline
                                                 blk_prof
                                                 (vlax-3d-point x)
                                                 (vlax-3d-point
                                                   (list (car x)
                                                         (1+ (cadr x))
                                                         ) ; 
                                                   ) ; _
                                                 ) ;
                                              ) ;
                                            acextendboth
                                            ) ;
                                          ) ; _ end of
                                        ) ; _ end of
                                     ) ;_ end of setq
                               (vla-erase tmp)
                               res
                               ) ;_ end of lambda
                            (list
                              (vlax-safearray->list
                                (vlax-variant-value
                                  (vla-get-startpoint base_prof)
                                  ) ; _ end of
                                ) ; _ end of
                              (vlax-safearray->list
                                (vlax-variant-value
                                  (vla-get-endpoint base_prof)
                                  ) ; _ end of
                                ) ; _ end of
                              ) ;_ end of list
                            ) ;_ end of mapcar
                          ) ;_ end of append
                        '(lambda (a b) (< (car a) (car b)))
                        ) ;_ end of vl-sort
                     align_hor_z
                      (- align_hor_z
                         (cadar
                           (vl-sort lst_inters
                                    '(lambda (a b) (< (cadr a) (cadr b)))
                                    ) ;_ end of vl-sort
                           ) ;_ end of cadar
                         ) ;_ end of -
                     lst_inters
                      (mapcar '(lambda (x)
                                 (list (car x) (+ (cadr x) align_hor_z))
                                 ) ;_ end of LAMBDA
                              lst_inters
                              ) ;_ end of mapcar
                     cur_pos_x 0.
                     ) ;_ end of setq

(princ lst_inters)(princ "|3")(princ "\n");;;
	       
               (vla-put-coordinates
                 pline_prof
                 (vlax-make-variant
                   (vlax-safearray-fill
                     (vlax-make-safearray
                       vlax-vbdouble
                       (cons 0 (1- (length (apply 'append lst_inters))))
                       ) ;_ end of vlax-make-safearray
                     (apply 'append lst_inters)
                     ) ;_ end of vlax-safearray-fill
                   ) ;_ end of vlax-make-variant
                 ) ;_ end of vla-put-coordinates
               (while (<= cur_pos_x (vla-get-length base_prof))
                 ((lambda (/ tmp tmp_pt)
                    (setq tmp (_kpblc-ent-create-line
                                (list (cons "where" blk_prof)
                                      (cons "lw" aclnwtbyblock)
                                      (cons "ltype" "byblock")
                                      (cons "color" 0)
                                      (cons "layer" "0")
                                      (cons "normal" '(0. 0. 1.))
                                      ) ;_ end of list
                                (list (list cur_pos_x 0.)
                                      (list cur_pos_x 1.)
                                      ) ;_ end of list
                                ) ;_ end of _kpblc-ent-create-line
                          ) ;_ end of setq
                    (vla-put-endpoint
                      tmp
                      (vla-intersectwith tmp pline_prof acextendboth)
                      ) ;_ end of vla-put-EndPoint
                    ;; Now adding a text "inside" line
                    (_kpblc-ent-create-text
                      (list
                        (cons "where" blk_prof)
                        (cons "string"
                              (vl-princ-to-string
                                (+ (vla-get-length tmp)
                                   base_level
                                   ) ;_ end of +
                                ) ;_ end of vl-princ-to-string
                              ) ;_ end of cons
                        (cons "height" 0.25)
                        (cons "align" acalignmentcenter)
                        (cons "layer" "0")
                        (cons "lw" aclnwtbyblock)
                        (cons "color" "byblock")
                        (cons "rot" (/ pi 2.))
                        (cons "style" "PMSF-TEXT")
                        (cons "normal" '(0. 0. 1.))
                        ) ;_ end of list
                      (list (- (car (setq tmp_pt
                                           (mapcar '(lambda (x y) (/ (+ x y) 2.))
                                                   (vlax-safearray->list
                                                     (vlax-variant-value
                                                       (vla-get-startpoint tmp)
                                                       ) ; _ end of
                                                     ) ; _ end of
                                                   (vlax-safearray->list
                                                     (vlax-variant-value
                                                       (vla-get-endpoint tmp)
                                                       ) ; _ end of
                                                     ) ; _ end of
                                                   ) ;_ end of mapcar
                                          ) ;_ end of setq
                                    ) ;_ end of car
                               (abs (getvar "dimgap"))
                               ) ;_ end of -
                            (cadr tmp_pt)
                            ) ;_ end of list
                      ) ;_ end of _kpblc-ent-create-text
                    ) ;_ end of lambda
                  )
                 (setq cur_pos_x (+ cur_pos_x 10.))
                 ) ;_ end of while
               (setq tmp
                      (_kpblc-ent-create-line
                        (list (cons "where" blk_prof)
                              (cons "lw" aclnwtbyblock)
                              (cons "ltype" "byblock")
                              (cons "color" 0)
                              (cons "layer" "0")
                              ) ;_ end of list
                        (list (vlax-safearray->list
                                (vlax-variant-value (vla-get-endpoint base_prof))
                                ) ;_ end of vlax-safearray->list
                              (vlax-curve-getendpoint pline_prof)
                              ) ;_ end of list
                        ) ;_ end of _kpblc-ent-create-line
                     ) ;_ end of setq
               (_kpblc-ent-create-text
                 (list
                   (cons "where" blk_prof)
                   (cons "string"
                         (vl-princ-to-string
                           (+ (vla-get-length tmp)
                              base_level
                              ) ;_ end of +
                           ) ;_ end of vl-princ-to-string
                         ) ;_ end of cons
                   (cons "height" 0.25)
                   (cons "align" acalignmentcenter)
                   (cons "layer" "0")
                   (cons "lw" aclnwtbyblock)
                   (cons "color" "byblock")
                   (cons "rot" (/ pi 2.))
                   (cons "style" "PMSF-TEXT")
                   (cons "normal" '(0. 0. 1.))
                   ) ;_ end of list
                 (list (- (car (setq tmp_pt
                                      (mapcar '(lambda (x y) (/ (+ x y) 2.))
                                              (vlax-safearray->list
                                                (vlax-variant-value
                                                  (vla-get-startpoint tmp)
                                                  ) ; _ end of
                                                ) ; _ end of
                                              (vlax-safearray->list
                                                (vlax-variant-value
                                                  (vla-get-endpoint tmp)
                                                  ) ; _ end of
                                                ) ; _ end of
                                              ) ;_ end of mapcar
                                     ) ;_ end of setq
                               ) ;_ end of car
                          (abs (getvar "dimgap"))
                          ) ;_ end of -
                       (cadr tmp_pt)
                       ) ;_ end of list
                 ) ;_ end of _kpblc-ent-create-text
               (_kpblc-block-insert-low-level
                 blk_prof_name
                 (list (cons "msg_pt" "Insertion point : ")
                       (cons "ang" 0.)
                       (cons "x" 1.)
                       (cons "y" aggregation)
                       (cons "z" 1.)
                       ) ;_ end of list
                 ) ;_ end of _kpblc-block-insert-low-level
          ;(command "_.-insert" blk_prof_name pause 1. aggregation 0.)
               (loc:rename-layers->back)
               ) ;_ end of lambda
             ) ;_ end of function
           nil
           ) ;_ end of _kpblc-error-catch
         ) ;_ end of if
      ) ;_ end of progn
    (progn
      (alert (strcat "Current coordinate system is not world!"
                     "Author can't guarantee current working in this UCS!"
                     ) ;_ end of strcat
             ) ;_ end of alert
      ) ;_ end of progn
    ) ;_ end of if
  (vla-endundomark *kpblc-activedoc*)
  (princ)
  )





Код:
[Выделить все]
 (defun entmake-text (str tp rad hgt wdt ali ali2)
(entmake
(list
'(0 . "TEXT") ;тип примитива
'(100 . "AcDbEntity") ;хер знает для чего надо, и без нее пашет норм
'(100 . "AcDbText") ;хер знает для чего надо, и без нее пашет норм
(cons 1 str) ;содержимое текста
(cons 7 (getvar "textstyle")) ;тектсовый стиль
(cons 8 "0") ;слой
(cons 62 256) ;цвет текста
(cons 10 tp) ;начальная точка
(cons 11 tp) ;точка выравнивания
(cons 40 hgt) ;высота текста
(cons 41 wdt) ;фактор сжатия
(cons 50 rad) ;угол поворота в рад
(cons 51 0.0) ;угол наклона
'(71 . 0) ;флаги генерации
(cons 72 ali) ;выравнивание лево центр право
(cons 73 ali2) ;выравнивание низ середина верх
) ;list
) ;entmake
(princ)
)

(defun dtr (a) (* pi (/ a 180.0)))

(defun C:pro (/ anngg dz ucs osn txt p pt1 pt2 ppt1 ppt2 tdis uk ang12)
(setq osn (getvar "OSMODE"))
(setvar "OSMODE" 0)
(if (= (tblsearch "block" "blck001") nil)
(progn (setq namset (ssadd))
(command "_PLINE" '(0 0) "_W" 0.3 0.3 '(0 2) "")
(ssadd (entlast) namset)
(command "_PLINE" '(0 4) "_W" 0.0 2.0 '(0 2) "")
(ssadd (entlast) namset)
(command "_block" "blck001" '(0.0 5.0 0.0) namset "")
) ;progn
) ;if

(setq anngg (getvar "ANGBASE"))
(setq dz (getvar "DIMZIN"))
(setvar "DIMZIN" 0)
(setvar "CMDECHO" 0)
(setq ucs (getpoint "\n Укажите точку где строить профиль: "))
(command "_UCS" ucs "")
;Рисуем табличку
(command "_rectang" "_w" 0 '(0 0) '(85 10))
(setq txt (substr " Покрытие" 1))
(command "_TEXT" "_ML" '(0 5) 3.5 "0" txt)

(command "_rectang" '(0 20) '(85 10))
(setq txt (substr " Углы поворота" 1))
(command "_TEXT" "_ML" '(0 15) 3.5 "0" txt)

(command "_rectang" '(0 20) '(85 40))
(setq txt (substr " План трассы. Пикетаж." 1))
(command "_TEXT" "_ML" '(0 30) 3.5 "0" txt)

(command "_rectang" '(0 50) '(85 40))
(command "_PLINE" '(0 50) "_w" 0 0 '(85 40) "")
(setq txt (substr " Длина участка" 1))
(command "_TEXT" "_ML" '(0 43) 3.5 "0" txt)
(setq txt (substr "Уклон " 1))
(command "_TEXT" "_MR" '(85 47) 3.5 "0" txt)

(command "_rectang" '(0 50) '(85 60))
(setq txt (substr " Расстояние" 1))
(command "_TEXT" "_ML" '(0 55) 3.5 "0" txt)

(command "_rectang" '(0 70) '(85 60))
(setq txt (substr " Глубина до верха канала" 1))
(command "_TEXT" "_ML" '(0 65) 3.5 "0" txt)

(command "_rectang" '(0 70) '(85 80))
(setq txt (substr " Глубина заложения низа канала" 1))
(command "_TEXT" "_ML" '(0 75) 3.5 "0" txt)

(command "_rectang" '(0 80) '(8 140))
(setq txt (substr "Отметки" 1))
(command "_TEXT" "_MC" '(4 110) 3.5 "90" txt)

(command "_rectang" '(8 80) '(85 95))
(setq txt (substr " Верха труб" 1))
(command "_TEXT" "_ML" '(8 87.5) 3.5 "0" txt)

(command "_rectang" '(8 110) '(85 95))
(setq txt (substr " Низа канала или дна траншеи" 1))
(command "_TEXT" "_ML" '(8 102.5) 3.5 "0" txt)

(command "_rectang" '(8 110) '(85 125))
(setq txt (substr " Верха канала или верха труб" 1))
(command "_TEXT" "_ML" '(8 117.5) 3.5 "0" txt)

(command "_rectang" '(8 140) '(85 125))
(setq txt (substr " Планировки" 1))
(command "_TEXT" "_ML" '(8 132.5) 3.5 "0" txt)

(command "_rectang" '(0 140) '(85 150))
(setq txt (substr " Номера точек" 1))
(command "_TEXT" "_ML" '(0 145) 3.5 "0" txt)

(command "_PLINE"
(setq p '(80 150))
(setq p (polar p (dtr 90) 5))
(setq p (polar p (dtr 180) 15))
""
)

(command "_PLINE"
(setq p '(80 150))
(setq p (polar p (dtr 45) 4))
""
)
(setq p (entlast))
(command "_MIRROR" p "" '(80 150) '(80 151) "")

(setq p (getstring "\n Условный горизонт:"))
(command "_TEXT" '(66 156) 3.5 "0" p)

(setq p (atof p))

(setq txt (substr "М гор. 1:500" 1))
(command "_TEXT" '(30 160) 3.5 "0" txt)
(setq txt (substr "М вер. 1:100" 1))
(command "_TEXT" '(30 154.5) 3.5 "0" txt)
(command "_UCS" '(110 0) "")

(setvar "OSMODE" 8)
(setvar "PDMODE" 35)
(setvar "PDSIZE" 1)

(setq ali 1)
(setq ali2 0)
(setq dis 0.0)
(setq str "ПК 00+00.00")
(setq pt1 (getpoint "\n Укажите точку : "))
(setq pt1 (trans pt1 1 0))
(setq tp (list (car pt1) (+ (cadr pt1) 1) 0))

(setq rad (dtr 0))
(setq hgt 1.0)
(setq wdt 1.0)

(entmake-text str tp rad hgt wdt ali ali2)
(setq rad (dtr 90))
(setq tp '(-2.5 30))
(setq tp (trans tp 1 0))
(setq hgt 2.5)
(setq wdt 1.0)

(entmake-text str tp rad hgt wdt ali ali2)
(command "_PLINE"
(list 0 150)
(list 0 (+ 150 (* (- (last pt1) p) 10)))
""
)
(command "_TEXT"
"_BC"
(list 0 87.5)
3.5
"90"
(rtos (last pt1) 2 2)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Ц И К Л ;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(while (setq pt2 (getpoint "\n Укажите точку (ENTER = хватит): "))
(setq pt2 (trans pt2 1 0))

(setq ang12 (atoi (angtos (angle pt1 pt2) 0 0)))
(if (= dis 0)
(setq ang12 nil)
)
(print ang12)
(setvar "ANGBASE" anngg)

(setq ppt1 (list (car pt1) (cadr pt1) 0))
(setq ppt2 (list (car pt2) (cadr pt2) 0))
(setq ali2 0)
(setq ali 1)
(setq tdis (distance ppt1 ppt2))

(setq rad (dtr 0))
(setq dis (+ dis (distance ppt1 ppt2)))
(setq da (fix (/ dis 100))
head (if (< da 10)
(strcat "0" (rtos da 2 0))
(rtos da 2 0)
)
) ;setq da
(setq tail (rtos (- dis (* da 100)) 2 2))
(setq str (strcat "ПК" (chr 32) head "+" tail))

(setq tp (list (car pt2) (+ (cadr pt2) 1) 0))
(setq hgt 1.0)
(setq wdt 1.0)

(entmake-text str tp rad hgt wdt ali ali2)
(setq rad (dtr 90))

(setq tp (list (- (* tdis 2) 2.5) 30))
(setq tp (trans tp 1 0))
(setq hgt 2.5)
(setq wdt 1.0)

(entmake-text str tp rad hgt wdt ali ali2)
(setq uk (/ (- (last pt1) (last pt2)) tdis))
(setvar "OSMODE" 0)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Пишем углы поворота трассы

(if (= (type ang12) (type 1))
(progn

(setq tp (trans (list (+ 0 2) 15) 1 0))
(setq hgt 3.5)
(setq rad 0)
(setq str (itoa ang12))
(setq ali 0)
(setq ali2 1)
(if (> ang12 180)
(progn (command "_insert" "blck001" '(0 10) 1 1 180)
(setq ang12 (- 360 ang12)
ali2 3
str (itoa ang12)
) ;setq
) ;progn
(command "_insert" "blck001" '(0 20) 1 1 0)
) ;if

(entmake-text str tp rad hgt wdt ali ali2)
) ;progn
) ;if

; строим прямоугольники

(command "_rectang"
(list 0 140)
"_D"
(* tdis 2)
10
(list 1 140)
)
(command "_rectang"
(list 0 125)
"_D"
(* tdis 2)
15
(list 1 125)
)
(command "_rectang"
(list 0 110)
"_D"
(* tdis 2)
15
(list 1 110)
)
(command "_rectang"
(list 0 95)
"_D"
(* tdis 2)
15
(list 1 95)
)
(command "_rectang"
(list 0 80)
"_D"
(* tdis 2)
15
(list 1 80)
)

; пишем отметку оси
(command "_TEXT"
"_BC"
(list (* tdis 2) 87.5)
3.5
"90"
(rtos (last pt2) 2 2)
)
; написали

(command "_rectang"
(list 0 70)
"_D"
(* tdis 2)
10
(list 1 70)
)
(command "_rectang"
(list 0 60)
"_D"
(* tdis 2)
10
(list 1 60)
)

; пишем длину
(command "_TEXT"
"_BC"
(list tdis 52)
3.5
"0"
(rtos tdis 2 2)
)
; написали

(command "_rectang"
(list 0 50)
"_D"
(* tdis 2)
10
(list 1 50)
)

; рисуем направление уклона
(if (> uk 0)
(command "_PLINE" (list 0 50) (list (* tdis 2) 40) "")
(command "_PLINE" (list 0 40) (list (* tdis 2) 50) "")
) ;if
(if (= uk 0)
(command "_erase" (entlast) "")
)
; нарисовали

; пишем уклон и длину
(if (= uk 0)
(progn
(command "_TEXT"
"_BC"
(list tdis 44.13)
3.5
"0"
(substr "0.000" 1)
)
(command "_TEXT"
"_BC"
(list tdis 40.13)
3.5
"0"
(rtos tdis 2 2)
)
) ;progn
(progn
(if (> uk 0)
(progn
(command "_TEXT"
"_MR"
(list (- (* tdis 2) 1) 46)
3.5
"0"
(rtos (abs uk) 2 4)
)
(command "_TEXT" "_ML" (list 1 44) 3.5 "0" (rtos tdis 2 2))
) ;progn
(progn
(command "_TEXT"
"_Ml"
(list 1 46)
3.5
"0"
(rtos (abs uk) 2 4)
)
(command "_TEXT"
"_MR"
(list (- (* tdis 2) 1) 44)
3.5
"0"
(rtos tdis 2 2)
)
) ;progn
) ;if
) ;progn
) ;if
; написали

(command "_rectang"
(list 0 40)
"_D"
(* tdis 2)
10
(list 1 40)
)
(command "_rectang"
(list 0 20)
"_D"
(* tdis 2)
20
(list 1 20)
)
(command "_rectang"
(list 0 10)
"_D"
(* tdis 2)
10
(list 1 10)
)
(command "_rectang"
(list 0 0)
"_D"
(* tdis 2)
10
(list 1 0)
)

;построили
;;;(princ lst-new)(princ "|")(princ "\n")

;рисуем линии профиля
(command "_PLINE"
(list 0 (+ 150 (* (- (last pt1) p) 10)))
"_W"
0.6
0.6
(list (* tdis 2) (+ 150 (* (- (last pt2) p) 10)))
""
)
(command "_PLINE"
(list (* tdis 2) 150)
"_W"
0
0
(list (* tdis 2) (+ 150 (* (- (last pt2) p) 10)))
""
)
;нарисовали

(command "_UCS" (list (* tdis 2) 0) "")
(print tdis)

(print uk)

(setvar "ANGBASE" (angle pt1 pt2))
(setq pt1 pt2)
(setvar "OSMODE" 8)
) ; while

(setvar "ANGBASE" anngg)
(command "_UCS" "_W")
(setvar "OSMODE" osn)
(setvar "DIMZIN" dz)
(princ)
) ; defun

Последний раз редактировалось Кулик Алексей aka kpblc, 24.04.2019 в 17:16.
hroost вне форума  
 
Непрочитано 24.04.2019, 17:17
#19
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 39,787


Ох, е-мое! Я даж не помню, что это была за функция и чего она делала. Откуда хоть взято?
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 24.04.2019, 17:34
#20
hroost

Проектирование
 
Регистрация: 01.09.2009
Сообщений: 19


Цитата:
Сообщение от Кулик Алексей aka kpblc Посмотреть сообщение
Как вариант: http://www.cadtutor.net/forum/showth...6521#post56521 . Я там несколько кодов рисовал, поковыряй - может, чего и пригодится (если я верно понял задачу, конечно).
Эта отсюда (к сожалению туда ссылка битая и даже на том форуме поиском не нашел), здесь кто-то из форумчан выложил код. Функция строит продольный профиль трассы, т.е. полилиния (трасса) пересекает другие полилинии (горизонтали) находящиеся на разных уровнях и строит профиль. Программа просто отличная, но как всегда хочется чего-то большего

Последний раз редактировалось hroost, 24.04.2019 в 17:40.
hroost вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > LISP. Пересечения плоскости и линий

Размещение рекламы
Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
LISP. Разорвать объекты в точках пересечения. BreakObjects. VVA Готовые программы 110 25.02.2022 07:33
LISP для подсчета суммы длин линий Kostinok LISP 18 26.04.2013 14:56
Как сделать 3D путь из объектов (линий и дуг), нележащих в одной плоскости Ухряб AutoCAD 5 21.01.2010 12:25
деление множества линий в точках пересечения shurup Программирование 4 24.03.2008 15:11
Нужен Lisp для работы с типами линий Gostushev LISP 12 06.07.2005 14:50