Тема: 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", размораживается. ("color" . 25) ; цвет рисования примитивов ("lt" . "hidden") ; тип линии примитива. На английском. nil -> celtype ("ltfile" . "acadiso.lin") ; файл описания типа линии. nil -> acadiso.lin ("lw" aclnwt025) ; вес линии примитива. nil -> celweight ) cmd выполняемая команда |; (defun _kpblc-draw (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 (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