Слой и стили. Их создание, установка текущими, и возврат к исходному состоянию после завершения команды

Browning Zed · 19.02.2018, 19:58

Всем привет. Пытаюсь доработать под себя ряд программ, чтобы объекты с помощью которых они создаются, располагались на определенных слоях и им присваивались определенные стили. Конкретно в данном примере - построение выноски с координатами.
Цель такова: посредством ряда функций создаем текстовой стиль, стиль мультивыноски, слой. Устанавливаем их текущими.
Далее запускается циклическая команда построения выноски. После того как мы обрываем команду, все стили, и слой должны вернуться в исходное состояние, стать такими как до выполнения команды. Пытался сообразить нечто подобное, но ничего не выходит - слой и стили создаются, но программа перестает работать должным образом. Ногами не бить - я ни разу не программист, даже близко. Все лисп-функции и сама программа построения выноски честно скопипащены с просторов интернета. Помогите разобраться.

Код:

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

 (defun create-text-style ()
 (if (not (tblsearch "STYLE" "ГОСТ ISO"))
    (entmake '((0 . "STYLE")
                     (100 . "AcDbSymbolTableRecord") 
                     (100 . "AcDbTextStyleTableRecord") 
                     (2 . "ГОСТ ISO"); название стиля 
                     (3 . "ISOCPEUR"); файл шрифта 
                     (70 . 0) 
                     (40 . 0.0) 
                     (41 . 1.0) 
                     (50 . 0.0) 
                     (71 . 0) 
                    ) 
    )
 )
)
(defun create-layer-and-set (/ layname laycol ltname lay)
  (vl-load-com)
	(setq 
		  layname	"Выноски"		; имя слоя 
          laycol	5				; цвет слоя
		  ltname	"Continuous"	; тип линии слоя
		)
  (if (not (tblsearch "LTYPE" ltname))
    (vla-load
      (vla-get-Linetypes
        (vla-get-ActiveDocument
          (vlax-get-acad-object))) ltname "acad.lin"))
  (if (not (tblsearch "LAYER" layname))
    (progn
      (setq lay (vla-add
                  (vla-get-layers
                    (vla-get-ActiveDocument
                      (vlax-get-acad-object))) layname))
      (vla-put-color lay laycol)
      (vla-put-linetype lay ltname)))
	(setvar "CLAYER" layname)
 )

(defun create-mleader-style 
  ( mleaderstylename  / mldrdict newldrstyle textcolor leadercolor objcolor dimblk)
  (if (not (member (cons 3 mleaderstylename)(DICTSEARCH (NAMEDOBJDICT) "ACAD_MLEADERSTYLE")))
    (progn
      (setq dimblk nil)
      (or dimblk (setq dimblk "_None")); dimblk (имя блока на конце) ""
      (setq mldrdict (vla-item (vla-get-dictionaries (vla-get-activedocument (vlax-get-acad-object))) "ACAD_MLEADERSTYLE"))
      (setq newldrstyle (vlax-invoke mldrdict 'addobject mleaderstylename "AcDbMLeaderStyle"))
      (setq textcolor acByBlock); Цвет текста
      (setq leadercolor acByBlock); Цвет выноски
      (setq objcolor (vla-getinterfaceobject
		       (vlax-get-acad-object)
		       (strcat "AutoCAD.AcCmColor." (substr (getvar "acadver") 1 2))
		       );_vla-getinterfaceobject
	    );_setq
      (vla-put-ColorIndex objcolor textcolor)
      (vla-put-TextColor newldrstyle objcolor)
      (vla-put-ColorIndex objcolor leadercolor)
      (vla-put-LeaderLineColor newldrstyle objcolor)
      (if (not (tblobjname "block" dimblk))
	(progn
	  (setq textcolor (getvar "dimblk"))
	  (if (VL-CATCH-ALL-ERROR-P(VL-CATCH-ALL-APPLY 'setvar (list "dimblk" dimblk)))
	    (setvar "dimblk" (setq dimblk "_None"))
	    )
	  (setvar "dimblk" (if (= textcolor "") "." textcolor))
	  )
	)
      (foreach item
	       (list
		 '("AlignSpace" 5.0)
		 '("Annotative" 0)
		 '("ArrowSize" 1.0); размер стрелки
		 (list "ArrowSymbol"  dimblk)
		 '("BitFlags" 0)
		 '("BlockConnectionType" 0)
		 '("BlockRotation" 0.0)
		 '("BlockScale" 1.0)
		 '("BreakSize" 0.125)
		 '("ContentType" 2)
		 '("Description"  "Стиль для подписей")
		 '("DoglegLength" 0.3)
		 '("DrawLeaderOrderType" 0)
		 '("DrawMLeaderOrderType" 1)
		 '("EnableBlockRotation" -1)
		 '("EnableBlockScale" -1)
		 '("EnableDogleg" -1)
		 '("EnableFrameText" 0)
		 '("EnableLanding" -1)
		 '("FirstSegmentAngleConstraint" 0)
		 '("LandingGap" 0.2)
		 '("LeaderLineType"  1); ("LeaderLineTypeId" "ByBlock"); "Continuous"
		 '("LeaderLineTypeId" "Continuous"); "ByBlock"; ("LeaderLineWeight" 30); вес линий выноски
		 '("MaxLeaderSegmentsPoints" 2)
		 '("ScaleFactor" 1.0)
		 '("SecondSegmentAngleConstraint"  0)
		 '("TextAlignmentType" 0)
		 '("TextAngleType" 0)
		 '("TextHeight" 2.1); высота текста
		 '("TextLeftAttachmentType" 3)
		 '("TextRightAttachmentType" 3)
		 '("TextString"  "")
		 (list "TextStyle" (getvar "TEXTSTYLE")); устанавливает стиль текста
		 )
	(vlax-put-property newldrstyle (car item)(cadr item))
	)
      )
    newldrstyle
    )
  )
(defun c:xyz_mleader (/ pod_z koord  xyz)
  (setq orig-tstyle (getvar "TEXTSTYLE")); запоминает исходный текстовой стиль
  (create-text-style); создает новый текстовой стиль
  (setvar "TEXTSTYLE" "ГОСТ ISO"); устанавливает вновь созданный текстовой стиль в качестве текущего
  (create-mleader-style "Подписи"); создает стиль мультивыноски
  (setq orig-layer (getvar "CLAYER")); запоминает исходный слой
  (create-layer-and-set); создает новый слой
(initget "Да Нет Lf Ytn _ Y N Y N")
  (setq
    pod_z (getkword "\nПодписывать Z [Да/Нет] <Нет>? : ")
  )
  (while (and
      (setq koord (getpoint "\nТочка <Выход>"))
    )
    (setq
    ; xyz  (strcat "Y=" (rtos (nth 0 koord) 2 3)"\nX=" (rtos (nth 1 koord) 2 3)(if
      xyz  (strcat "X=" (rtos (nth 1 koord) 2 3)"\nY=" (rtos (nth 0 koord) 2 3)(if
    (= pod_z "Y")
      (strcat "\nZ=" (rtos (nth 2 koord) 2 3))
      ""
  ))
    )
    (VL-cmdf "_mleader" koord pause  xyz "")
  )
  (setvar "CLAYER" orig-layer); возвращает исходный слой
  (setvar "TEXTSTYLE" orig-tstyle); возвращает исходный текстовой стиль
)
(princ)

Кулик Алексей aka kpblc · 19.02.2018, 20:26

Ты хочешь, чтобы тебе код переработали или подсказали идеи, как надо сделать?

Browning Zed · 19.02.2018, 20:29

Если не затруднит, показать как должен выглядеть рабочий код.

VVA · 20.02.2018, 19:15

Цитата:

Сообщение от Browning Zed

После того как мы обрываем команду, все стили, и слой должны вернуться в исходное состояние, стать такими как до выполнения команды

Цитата:

Сообщение от Browning Zed

Если не затруднит, показать как должен выглядеть рабочий код.

Как вариант. Код не проверял, но если твои функции рабочие, то должен работать

Код:

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

 
 (defun create-text-style ()
 (if (not (tblsearch "STYLE" "ГОСТ ISO"))
    (entmake '((0 . "STYLE")
                     (100 . "AcDbSymbolTableRecord") 
                     (100 . "AcDbTextStyleTableRecord") 
                     (2 . "ГОСТ ISO"); название стиля 
                     (3 . "ISOCPEUR"); файл шрифта 
                     (70 . 0) 
                     (40 . 0.0) 
                     (41 . 1.0) 
                     (50 . 0.0) 
                     (71 . 0) 
                    ) 
    )
 )
)
(defun create-layer-and-set (/ layname laycol ltname lay)
  (vl-load-com)
	(setq 
		  layname	"Выноски"		; имя слоя 
          laycol	5				; цвет слоя
		  ltname	"Continuous"	; тип линии слоя
		)
  (if (not (tblsearch "LTYPE" ltname))
    (vla-load
      (vla-get-Linetypes
        (vla-get-ActiveDocument
          (vlax-get-acad-object))) ltname "acad.lin"))
  (if (not (tblsearch "LAYER" layname))
    (progn
      (setq lay (vla-add
                  (vla-get-layers
                    (vla-get-ActiveDocument
                      (vlax-get-acad-object))) layname))
      (vla-put-color lay laycol)
      (vla-put-linetype lay ltname)))
	(setvar "CLAYER" layname)
 )

(defun create-mleader-style 
  ( mleaderstylename  / mldrdict newldrstyle textcolor leadercolor objcolor dimblk)
  (if (not (member (cons 3 mleaderstylename)(DICTSEARCH (NAMEDOBJDICT) "ACAD_MLEADERSTYLE")))
    (progn
      (setq dimblk nil)
      (or dimblk (setq dimblk "_None")); dimblk (имя блока на конце) ""
      (setq mldrdict (vla-item (vla-get-dictionaries (vla-get-activedocument (vlax-get-acad-object))) "ACAD_MLEADERSTYLE"))
      (setq newldrstyle (vlax-invoke mldrdict 'addobject mleaderstylename "AcDbMLeaderStyle"))
      (setq textcolor acByBlock); Цвет текста
      (setq leadercolor acByBlock); Цвет выноски
      (setq objcolor (vla-getinterfaceobject
		       (vlax-get-acad-object)
		       (strcat "AutoCAD.AcCmColor." (substr (getvar "acadver") 1 2))
		       );_vla-getinterfaceobject
	    );_setq
      (vla-put-ColorIndex objcolor textcolor)
      (vla-put-TextColor newldrstyle objcolor)
      (vla-put-ColorIndex objcolor leadercolor)
      (vla-put-LeaderLineColor newldrstyle objcolor)
      (if (not (tblobjname "block" dimblk))
	(progn
	  (setq textcolor (getvar "dimblk"))
	  (if (VL-CATCH-ALL-ERROR-P(VL-CATCH-ALL-APPLY 'setvar (list "dimblk" dimblk)))
	    (setvar "dimblk" (setq dimblk "_None"))
	    )
	  (setvar "dimblk" (if (= textcolor "") "." textcolor))
	  )
	)
      (foreach item
	       (list
		 '("AlignSpace" 5.0)
		 '("Annotative" 0)
		 '("ArrowSize" 1.0); размер стрелки
		 (list "ArrowSymbol"  dimblk)
		 '("BitFlags" 0)
		 '("BlockConnectionType" 0)
		 '("BlockRotation" 0.0)
		 '("BlockScale" 1.0)
		 '("BreakSize" 0.125)
		 '("ContentType" 2)
		 '("Description"  "Стиль для подписей")
		 '("DoglegLength" 0.3)
		 '("DrawLeaderOrderType" 0)
		 '("DrawMLeaderOrderType" 1)
		 '("EnableBlockRotation" -1)
		 '("EnableBlockScale" -1)
		 '("EnableDogleg" -1)
		 '("EnableFrameText" 0)
		 '("EnableLanding" -1)
		 '("FirstSegmentAngleConstraint" 0)
		 '("LandingGap" 0.2)
		 '("LeaderLineType"  1); ("LeaderLineTypeId" "ByBlock"); "Continuous"
		 '("LeaderLineTypeId" "Continuous"); "ByBlock"; ("LeaderLineWeight" 30); вес линий выноски
		 '("MaxLeaderSegmentsPoints" 2)
		 '("ScaleFactor" 1.0)
		 '("SecondSegmentAngleConstraint"  0)
		 '("TextAlignmentType" 0)
		 '("TextAngleType" 0)
		 '("TextHeight" 2.1); высота текста
		 '("TextLeftAttachmentType" 3)
		 '("TextRightAttachmentType" 3)
		 '("TextString"  "")
		 (list "TextStyle" (getvar "TEXTSTYLE")); устанавливает стиль текста
		 )
	(vlax-put-property newldrstyle (car item)(cadr item))
	)
      )
    newldrstyle
    )
  )
 
(defun c:xyz_mleader (/ pod_z koord xyz)
  (vl-load-com)
  (kpblc-error-save-sysvar
    (list
      '("osmode")
      '("CLAYER")
      '("CMDECHO" 0)
      '("EXPERT" 5)
      '("highlight" 1)
      '("cecolor" "bylayer")
      '("CELTYPE" "bylayer")
      '("TEXTSTYLE")
      '("CMLSTYLE")
    ) ;_ end of list
  ) ;_ end of kpblc-error-save-sysvar
  (vl-catch-all-apply
    '(lambda ()
       (create-text-style) ;_ создает новый текстовой стиль
       (setvar "TEXTSTYLE" "ГОСТ ISO") ;_ устанавливает вновь созданный текстовой стиль в качестве текущего
       (create-mleader-style "Подписи") ;_ создает стиль мультивыноски
       (create-layer-and-set) ;_ создает новый слой
       (initget "Да Нет Lf Ytn _ Y N Y N")
       (setq
         pod_z (getkword "\nПодписывать Z [Да/Нет] <Нет>? : ")
       ) ;_ end of setq
       (while (and
                (setq koord (getpoint "\nТочка <Выход>"))
              ) ;_ end of and
         (setq  ;_ xyz  (strcat "Y=" (rtos (nth 0 koord) 2 3)"\nX=" (rtos (nth 1 koord) 2 3)(if
           xyz (strcat "X="
                       (rtos (nth 1 koord) 2 3)
                       "\nY="
                       (rtos (nth 0 koord) 2 3)
                       (if
                         (= pod_z "Y")
                          (strcat "\nZ=" (rtos (nth 2 koord) 2 3))
                          ""
                       ) ;_ end of if
               ) ;_ end of strcat
         ) ;_ end of setq
         (vl-cmdf "_mleader"  "_none" koord  pause xyz)
         (vla-put-StyleName (vlax-ename->vla-object(entlast)) "Подписи")
       ) ;_ end of while
     ) ;_ end of lambda
  ) ;_ end of vl-catch-all-apply
  (kpblc-error-restore-sysvar)
) ;_ end of defun
(princ)

 ;|==============================================================
*    Восстанавливаются системные переменные. Значения системных переменных
* должны храниться в глобальном списке *kpblc-sysvar-list*. Если списка нет
* (nil), происходит просто выход.
*    Параметры вызова:
*  Нет
*    Примеры вызова:
(kpblc-error-restore-sysvar)
==============================================================|;
(defun kpblc-error-restore-sysvar ()
  (if *kpblc-sysvar-list*
    (foreach item *kpblc-sysvar-list*
      (_kpblc-sysvar-set (car item) (cadr item))
    ) ;_ end of foreach
  ) ;_ end of if
  (setq *kpblc-sysvar-list* nil)
  (gc)
) ;_ end of defun

;|================================================================
*    Сохраняется текущее значение системных переменных. Список
глобальный (*kpblc-sysvar-list*)
* При условии, что заданы значения, они устанавливаются.
*    Поскольку список *kpblc-sysvar-list* не обнуляется, в нем
хранится история изменения
* значений переменных.
*    Параметры вызова:
*  *kpblc-sysvar-list*  список системных переменных, состояние
которых надо сохранить.
*      Список состоит из подсписков (Переменная Значение)
*      В списке могут повторяться Переменные. В таком случае будет
*      установлено последнее значение.
*      Если в качестве второго параметра используется nil, то значение
*      системной переменной просто сохраняется.
*    Примеры вызова:
(kpblc-error-sysvar-list (list '("cmdecho" 0) '("blipmode")
'("osmode" 503)))
==============================================================|;
(defun kpblc-error-save-sysvar (sysvar-list)
  (foreach item sysvar-list
    (setq *kpblc-sysvar-list*
           (cons (list (car item) (getvar (car item)))
                 *kpblc-sysvar-list*
           ) ;_ end of cons
    ) ;_ end of setq
    (if (cadr item)
      (_kpblc-sysvar-set (car item) (cadr item))
    ) ;_ end of if
  ) ;_ end of foreach
) ;_ end of defun
;|*******************************************************************************
*    Установка системных переменных. Замена стандартному (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

Browning Zed · 20.02.2018, 19:50

VVA,
Попробовал запустить код. Поначалу программа ругалась на отсутствие функции _kpblc-sysvar-set. Через поиск нашел ее на сайте и прописал в лисп. Теперь, после запуска, команда сразу возвращает "nil". В чем может быть причина?

VVA · 21.02.2018, 00:17

Обновил #4

Browning Zed · 21.02.2018, 15:39

Вот теперь все фурычит. Буду разбираться с работой этих функций. Благодарю!

VVA · 23.02.2018, 11:36

Browning Zed, В двух словах логика работы такая:
1. kpblc-error-save-sysvar - запоминаем значение интересующих нас переменных
2. Используем отливщик ошибок vl-catch-all-apply, где и происходит взаимедействие с пользователем. Если произошло исключение (ошибка в коде, пользователь прервал команду и т.п.)
то функция вернет отчет об ошибке, но прерывания самой команды не произойдет
3. kpblc-error-restore-sysvar восстанавливает значение сохраненных в п.1 переменных независимо как завершилось выполнение п.2

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Нужно на событие завершения открытия документа выполнить нек. команды	Phelicks	Программирование	2	19.11.2009 15:27
VBA в 2010 автокаде не дожидается завершения предыдущей команды	NomadV	Программирование	2	13.11.2009 22:30
Как программно подождать завершения команды	DonVik	Программирование	7	05.12.2008 15:23
Проблемма после команды MOVE	LUCKY	AutoCAD	6	12.07.2007 10:25
Прозрачные команды	Vova	AutoCAD	17	21.06.2006 05:33

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