LISP. Расширенный вариант отрисовки

;|
*    Выполняет рисование примитивов любого типа по точкам, задаваемым пользователем
*    Параметры вызова:
  lst  список вида
      '(("layer" . lst_layer)  ; список параметров слоя. nil -> На текущем
        lst_layer:
          (("name" . "test_layer")    ; имя слоя. nil -> недопустим
          ("color" . 16)      ; цвет слоя. nil -> cecolor
          ("lt" . "hidden")    ; тип линии. На английском. nil -> Continuous
          ("ltfile" . "acadiso.lin")  ; файл описания типа линии. nil -> acadiso.lin
          ("lw" aclnwt025)    ; вес линии слоя. nil -> default
          )
        ; Слой создается печатаемым, в режиме "on", размораживается.
    (cons "sysvar" (list (list "plinewid" 0.2) (list "plinegen" 1)))
        ; список дополнительно устанавливаемых системных переменных
        ("color" . 25)    ; цвет рисования примитивов
        ("lt" . "hidden")  ; тип линии примитива. На английском. nil -> celtype
        ("ltfile" . "acadiso.lin")  ; файл описания типа линии. nil -> acadiso.lin
        ("lw" aclnwt025)    ; вес линии примитива. nil -> celweight
        )
  cmd  выполняемая команда
|;
(defun _kpblc-draw-ext (lst                       cmd
                    /                         *error*
                    *kpblc-activedoc*         _kpblc-error-catch
                    _kpblc-layer-create-by-list
                    _kpblc-sysvar-set         _kpblc-error-sysvar-restore
                    _kpblc-error-sysvar-save  _kpblc-linetype-load
                    )
  (defun *error* (msg)
    (_kpblc-error-sysvar-restore nil)
    (vla-endundomark *kpblc-activedoc*)
    (princ msg)
    (princ)
    ) ;_ end of defun
  ;|=============================================================================
*** Компонент интегрированной системы CADWare
*******************************************************************************
*** Автор системы: Кулик Алексей aka kpblc
*** www: http://my.opera.com/kpblc/
*** При разработке системы были использованы материалы:
*  ruCAD (www.kurganobl.ru)
*  "САПР на базе AutoCAD — как это делается", авторы Зуев С.А., Полещук Н.Н.
*    при участии Лоскутова П.В.
*  конференций www.dwg.ru; www.autocad.ru; www.arcada.com.ua;
*    www.theswamp.com; www.cadtutor.net; www.forums.augi.com
*** Автор выражает самую искреннюю благодарность всем, принимавшим участие в
*** разработке системы.
*******************************************************************************
*** Разрешено использование компонента в любых целях при указании автора и при
*** условии поставки этой части с исходными текстами
*******************************************************************************
*    Функция подгрузки типа линии в текущий файл. Учитывает возможную
* локализацию системы.
*    Возвращает vla-указатель на подгруженный тип линии.
*    Параметры вызова:
*  ltype-name  имя типа линии для английской версии
*  ltype-file  имя файла описания типа линии. nil -> "acadiso.lin"ю
*      Если файл с описанием типа линии не лежит по путям
*      поддержки када, надо указывать полный путь к нему.
*    Примеры вызова:
(_kpblc-linetype-load "center" nil)  ; для русской версии подгружает Осевая
***  Соответствие наименований линий обеспечивается огромным списком ltype_list
*** который можно и нужно дополнять :)
***  Тип линии "Continuous" обработке не подвергается — он есть во всех версиях
=============================================================================|;
  (defun _kpblc-linetype-load (ltype-name ltype-file / ltype_list)
    (vl-load-com)
    (if
      (not (member (strcase ltype-name t) '("continuous" "byblock" "bylayer")))
       (progn
         (setq ltype_list '(("border" . "рант")
                            ("border2" . "рант2")
                            ("borderX2" . "рантX2")
                            ("center" . "осевая")
                            ("center2" . "осевая2")
                            ("centerX2" . "осеваяX2")
                            ("dashdot" . "штрихпунктирная")
                            ("dashdot2" . "штрихпунктирная2")
                            ("dashdotX2" . "штрихпунктирнаяX2")
                            ("dashed" . "штриховая")
                            ("dashed2" . "штриховая2")
                            ("dashedX2" . "штриховаяX2")
                            ("divide" . "линия_сгиба")
                            ("divide2" . "линия_сгиба2")
                            ("divideX2" . "линия_сгибаX2")
                            ("dot" . "пунктирная")
                            ("dot2" . "пунктирная2")
                            ("dotX2" . "пунктирнаяX2")
                            ("hidden" . "невидимая")
                            ("hidden2" . "невидимая2")
                            ("hiddenX2" . "невидимаяX2")
                            ("phantom" . "фантом")
                            ("phantom2" . "фантом2")
                            ("phantomX2" . "фантомX2")
                            ("fenceline1" . "ограждение1")
                            ("fenceline2" . "ограждение2")
                            ("tracks" . "пути")
                            ("batting" . "изоляция")
                            ("hot_water_supply" . "горячая_вода")
                            ("gas_line" . "газопровод")
                            ("zigzag" . "зигзаг")
                            )
               ltype-name (strcase ltype-name t)
               ) ;_ end of setq
         (if (not ltype-file)
           (setq ltype-file "acadiso.lin")
           ) ;_ end of if
         (if (assoc ltype-name ltype_list)
           (setq ltype-name
                  (if (vl-string-search "419" (vlax-product-key))
                    (cdr (assoc ltype-name ltype_list))
                    (car (assoc ltype-name ltype_list))
                    ) ;_ end of if
                 ) ;_ end of setq
           ) ;_ end of if
         (if (not (tblsearch "ltype" ltype-name))
           ;; тип линии не найден, надо его загрузить. Тип линии должен быть
           ;; описан в файле
           (vl-catch-all-error-p
             (vl-catch-all-apply
               'vla-load
               (list
                 (vlax-get-property
                   *kpblc-activedoc*
                   'linetypes
                   ) ;_ end of vlax-get-property
                 ltype-name
                 ltype-file
                 ) ;_ end of list
               ) ;_ end of vl-catch-all-apply
             ) ;_ end of vl-catch-all-error-p
           ) ;_ end of if
         ) ;_ end of progn
       ) ;_ end of if
    (if (tblsearch "ltype" ltype-name)
      (vla-item (vla-get-linetypes *kpblc-activedoc*) ltype-name)
      (vla-item (vla-get-linetypes *kpblc-activedoc*) "continuous")
      ) ;_ end of if
    ) ;_ end of defun
  ;|=============================================================================
*** Компонент интегрированной системы CADWare
*******************************************************************************
*** Автор системы: Кулик Алексей aka kpblc
*** www: http://my.opera.com/kpblc/
*** При разработке системы были использованы материалы:
*  ruCAD (www.kurganobl.ru)
*  "САПР на базе AutoCAD — как это делается", авторы Зуев С.А., Полещук Н.Н.
*    при участии Лоскутова П.В.
*  конференций www.dwg.ru; www.autocad.ru; www.arcada.com.ua;
*    www.theswamp.com; www.cadtutor.net; www.forums.augi.com
*** Автор выражает самую искреннюю благодарность всем, принимавшим участие в
*** разработке системы.
*******************************************************************************
*** Разрешено использование компонента в любых целях при указании автора и при
*** условии поставки этой части с исходными текстами
*******************************************************************************
*    Сохраняет текущее значение переданных системных переменных в глобальном
* списке *kpblc-list-sysvar*
*    Параметры вызова:
*  lst  список системных переменных (возможно, с переданными значениями)
*    Примеры вызова:
(_kpblc-error-sysvar-save '(("osmode" 512) ("orthomode" 1)))
*    Возвращаемое значение:  нет
=============================================================================|;
  (defun _kpblc-error-sysvar-save (lst)
    (foreach sysvar lst
      (setq *kpblc-list-sysvar*
             (append (list (list (car sysvar) (getvar (car sysvar))))
                     *kpblc-list-sysvar*
                     ) ;_ end of append
            ) ;_ end of setq
      (if (cdr sysvar)
        (_kpblc-sysvar-set (car sysvar) (cadr sysvar))
        ) ;_ end of if
      ) ;_ end of foreach
    (princ)
    ) ;_ end of defun
  ;|=============================================================================
*** Компонент интегрированной системы CADWare
*******************************************************************************
*** Автор системы: Кулик Алексей aka kpblc
*** www: http://my.opera.com/kpblc/
*** При разработке системы были использованы материалы:
*  ruCAD (www.kurganobl.ru)
*  "САПР на базе AutoCAD — как это делается", авторы Зуев С.А., Полещук Н.Н.
*    при участии Лоскутова П.В.
*  конференций www.dwg.ru; www.autocad.ru; www.arcada.com.ua;
*    www.theswamp.com; www.cadtutor.net; www.forums.augi.com
*** Автор выражает самую искреннюю благодарность всем, принимавшим участие в
*** разработке системы.
*******************************************************************************
*** Разрешено использование компонента в любых целях при указании автора и при
*** условии поставки этой части с исходными текстами
*******************************************************************************
*    Восстаналивает значения системных переменных.
*    Параметры вызова:
*  lst  список системных переменных, значения которых восстанавливаются
*    nil -> восстанавливать все
=============================================================================|;
  (defun _kpblc-error-sysvar-restore (lst)
    (if lst
      (foreach sysvar lst
        (_kpblc-sysvar-set sysvar (car (assoc sysvar *kpblc-list-sysvar*)))
        ) ;_ end of foreach
      (progn
        (foreach sysvar *kpblc-list-sysvar*
          (_kpblc-sysvar-set (car sysvar) (cadr sysvar))
          ) ;_ end of foreach
        (setq *kpblc-list-sysvar* nil)
        ) ;_ end of progn
      ) ;_ end of if
    ) ;_ end of defun
  ;|=============================================================================
*** Компонент интегрированной системы CADWare
*******************************************************************************
*** Автор системы: Кулик Алексей aka kpblc
*** www: http://my.opera.com/kpblc/
*** При разработке системы были использованы материалы:
*  ruCAD (www.kurganobl.ru)
*  "САПР на базе AutoCAD — как это делается", авторы Зуев С.А., Полещук Н.Н.
*    при участии Лоскутова П.В.
*  конференций www.dwg.ru; www.autocad.ru; www.arcada.com.ua;
*    www.theswamp.com; www.cadtutor.net; www.forums.augi.com
*** Автор выражает самую искреннюю благодарность всем, принимавшим участие в
*** разработке системы.
*******************************************************************************
*** Разрешено использование компонента в любых целях при указании автора и при
*** условии поставки этой части с исходными текстами
*******************************************************************************
*******************************************************************************
*** Функция взята из книжной версии ruCAD'a без каких бы то ни было переделок,
*** кроме переименования.
*    Оболочка отлова ошибок.
*    Параметры вызова:
*  protected-function  — "защищаемая" функция
*  on-error-function  — функция, выполняемая в случае ошибки
=============================================================================|;
  (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
  ;|=============================================================================
*** Компонент интегрированной системы CADWare
*******************************************************************************
*** Автор системы: Кулик Алексей aka kpblc
*** www: http://my.opera.com/kpblc/
*** При разработке системы были использованы материалы:
*  ruCAD (www.kurganobl.ru)
*  "САПР на базе AutoCAD — как это делается", авторы Зуев С.А., Полещук Н.Н.
*    при участии Лоскутова П.В.
*  конференций www.dwg.ru; www.autocad.ru; www.arcada.com.ua;
*    www.theswamp.com; www.cadtutor.net; www.forums.augi.com
*** Автор выражает самую искреннюю благодарность всем, принимавшим участие в
*** разработке системы.
*******************************************************************************
*** Разрешено использование компонента в любых целях при указании автора и при
*** условии поставки этой части с исходными текстами
*******************************************************************************
*    Создание слоя по переданному списку (не связано с БД)
*    Возвращает указатель на созданный слой
=============================================================================|;
  (defun _kpblc-layer-create-by-list (name lst / res)
    (foreach pr
             (list
               '("color" . 7)
               (cons "lt"
                     (vla-get-linetype (vla-get-activelayer *kpblc-activedoc*))
                     ) ;_ end of cons
               '("ltfile" . "acadiso.lin")
               (cons "lw" aclnwtbylwdefault)
               ) ;_ end of list
      (if (not (assoc (car pr) lst))
        (setq lst (append lst (list pr)))
        ) ;_ end of if
      ) ;_ end of foreach
    (setq res (vla-add (vla-get-layers *kpblc-activedoc*) name))
    (_kpblc-error-catch
      (function
        (lambda ()
          (vla-put-color res (cdr (assoc "color" lst)))
          (vla-put-lineweight res (cdr (assoc "lw" lst)))
          (vla-put-linetype
            res
            (vla-get-name
              (_kpblc-linetype-load
                (cdr (assoc "lt" lst))
                (cdr (assoc "ltfile" lst))
                ) ;_ end of _kpblc-linetype-load
              ) ;_ end of vla-get-name
            ) ;_ end of vla-put-linetype
          (vla-put-plottable
            res
            (if (cdr (assoc "plot" lst))
              :vlax-true
              :vlax-false
              ) ;_ end of if
            ) ;_ end of vla-put-Plottable
          (vla-put-layeron
            res
            (if (cdr (assoc "on" lst))
              :vlax-true
              :vlax-false
              ) ;_ end of if
            ) ;_ end of vla-put-layeron
          (if
            (/= (strcase (vla-get-name res))
                (strcase (vla-get-name (vla-get-activelayer *kpblc-activedoc*)))
                ) ;_ end of /=
             (progn
               (cond
                 ((cdr (assoc "active" lst))
                  (vla-put-activelayer *kpblc-activedoc* res)
                  )
                 ((cdr (assoc "freeze" lst))
                  (vl-catch-all-apply
                    '(lambda () (vla-put-freeze res :vlax-true))
                    ) ;_ end of vl-catch-all-apply
                  )
                 ((not (cdr (assoc "freeze" lst)))
                  (vl-catch-all-apply
                    '(lambda () (vla-put-freeze res :vlax-false))
                    ) ;_ end of vl-catch-all-apply
                  )
                 ) ;_ end of cond
               ) ;_ end of progn
             ) ;_ end of if
          ) ;_ end of lambda
        ) ;_ end of function
      (function
        (lambda (x)
          (princ (strcat "\nОшибка создания слоя : " x))
          ) ;_ end of lambda
        ) ;_ end of function
      ) ;_ end of _kpblc-error-catch
    res
    ) ;_ end of defun
  ;|=============================================================================
*** Компонент интегрированной системы CADWare
*******************************************************************************
*** Автор системы: Кулик Алексей aka kpblc
*** www: http://my.opera.com/kpblc/
*** При разработке системы были использованы материалы:
*  ruCAD (www.kurganobl.ru)
*  "САПР на базе AutoCAD — как это делается", авторы Зуев С.А., Полещук Н.Н.
*    при участии Лоскутова П.В.
*  конференций www.dwg.ru; www.autocad.ru; www.arcada.com.ua;
*    www.theswamp.com; www.cadtutor.net; www.forums.augi.com
*** Автор выражает самую искреннюю благодарность всем, принимавшим участие в
*** разработке системы.
*******************************************************************************
*** Разрешено использование компонента в любых целях при указании автора и при
*** условии поставки этой части с исходными текстами
*******************************************************************************
*    Установка системных переменных. Замена стандартному (setvar) для
* безошибочной обработки
*    Параметры вызова:
*  sysvar  имя системной переменной
*  value  устанавливаемое значение
*    Возвращаемое значение:
*  Установленное значение системной переменной либо nil в случае неудачи
=============================================================================|;
  (defun _kpblc-sysvar-set (sysvar value)
    (if (getvar sysvar)
      (if (and (= value "")
               (wcmatch (strcase sysvar t) "dim*")
               ) ;_ end of and
        (setvar sysvar ".")
        (vl-catch-all-apply 'setvar (list sysvar value))
        ) ;_ end of if
      ) ;_ end of if
    (getvar sysvar)
    ) ;_ end of defun
  (vl-load-com)
  (vla-startundomark
    (setq *kpblc-activedoc* (vla-get-activedocument (vlax-get-acad-object)))
    ) ;_ end of vla-StartUndoMark
  (_kpblc-error-catch
    (function
      (lambda ()
        (if (and lst (cdr (assoc "layer" lst)))
          (_kpblc-error-sysvar-save
            (list (list "clayer"
                        (vla-get-name
                          (_kpblc-layer-create-by-list
                            (cdr (assoc "name" (cdr (assoc "layer" lst))))
                            (append (vl-remove-if
                                      '(lambda (x) (= (car x) "name"))
                                      (cdr (assoc "layer" lst))
                                      ) ;_ end of vl-remove-if
                                    (list (cons "plot" t)
                                          (cons "on" t)
                                          ) ;_ end of list
                                    ) ;_ end of append
                            ) ;_ end of _kpblc-layer-create-by-list
                          ) ;_ end of vla-get-name
                        ) ;_ end of list
                  ) ;_ end of list
            ) ;_ end of _kpblc-error-sysvar-save
          ) ;_ end of if
        (if (cdr (assoc "sysvar" lst))
          (_kpblc-error-sysvar-save (cdr (assoc "sysvar" lst)))
          ) ;_ end of if
        (foreach prop
                      '(("color" . "cecolor")
                        ("lt" . "celtype")
                        ("lw" . "celweight")
                        )
          (if (cdr (assoc (car prop) lst))
            (_kpblc-error-sysvar-save
              (list (list (cdr prop)
                          (cond
                            ((= (car prop) "lt")
                             (vla-get-name
                               (_kpblc-linetype-load
                                 (cdr (assoc (car prop) lst))
                                 (cdr (assoc "ltfile" lst))
                                 ) ;_ end of _kpblc-linetype-load
                               ) ;_ end of vla-get-name
                             )
                            ((cdr (assoc (car prop) lst))
                             (if (= (type (getvar (cdr prop))) 'str)
                               (vl-princ-to-string (cdr (assoc (car prop) lst)))
                               (cdr (assoc (car prop) lst))
                               ) ;_ end of if
                             )
                            (t (getvar (cdr prop)))
                            ) ;_ end of cond
                          ) ;_ end of list
                    ) ;_ end of list
              ) ;_ end of _kpblc-error-sysvar-save
            ) ;_ end of if
          ) ;_ end of foreach
        (command (strcat "_." (vl-string-left-trim "_." cmd)))
        (while (/= (logand (getvar "cmdactive") 31) 0)
          (command pause)
          ) ;_ end of while
        ) ;_ end of lambda
      ) ;_ end of function
    '(lambda (x)
       (princ (strcat "\nerror : " x))
       ) ;_ end of LAMBDA
    ) ;_ end of _kpblc-error-catch
  (_kpblc-error-sysvar-restore nil)
  (vla-endundomark *kpblc-activedoc*)
  (princ)
  ) ;_ end of defun