[Krieger]

Такой вопросик:
Как сделать набор элементов состоящих, допустим, только из линии?
Т.е. ssget, только выбирать функция должна только то что надо.

[Кулик Алексей aka kpblc]

(ssget "_X" '((0 . "LINE")) - выберет линии по всему файлу
(ssget '((0 . "LINE"))) - отфильтрует отрезки из выбора пользователя

[Лентяй]

Код:

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

(ssget "X" '((0 . "LINE")))

[Лентяй]

kрЫс, ишо раз поперед дяди сунешься - накажу ! Вот только в Питер приеду...

[Krieger]

А какие функции работают с буфером обмена?

[Кулик Алексей aka kpblc]

> Лентяй : Ай-яй-яй, мама, попка, больно!
> Krieger : Сугубо ИМХО. Кад не очень качественно работает с буфером обмена, да и в многодокументном режиме лисп может вызвать несколько труднопонятных ошибок: тут функция загружена, тут - нет. Тут такие значения, тут - эдакие. Наверняка можно решить по другому (а если нельзя, то попробуй использовать функции vl-bb-*, работающие с внедокументными переменными, либо setenv / getenv, что тоже не фонтан - это же все обнулять надо, а в какой момент выполнять обнуление - кто знает?)... Чего надо сделать?

[Krieger]

Ну дык: скопировать выбранные примитивы, а потом вставить куда надо.
Все что пришло на ум
(command "_Copybase" HP a "")
(command "_Pasteclip" EP)
hp и ep - точки, а - набор примитивов.

[Krieger]

Можно создать блок, потом вставить куда надо, потом его удалить.
Как это будет выглядеть на лиспе? Через command?

[Кулик Алексей aka kpblc]

Так это проще сделать так, я думаю:

Код:

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

(defun test-copy (/ selset)
  (setq selset (ssget '((0 . "LINE"))))
  (if selset
    (command "_.copy" selset "" pause pause)
    ) ;_ end of if
  ) ;_ end of defun

---
Добавлено:
Вставлять как блок можно, конечно, только вряд ли это требуется в этой задаче. А если сильно надо, то тогда уж смотреть на ruCAD с его решениями.

[Лентяй]

Krieger: Ну дык: скопировать выбранные примитивы, а потом вставить куда надо.

Не понял :? ! их что - в другой файл копировать надо? Тогда - ActivX-ом их, болезных!

[Кулик Алексей aka kpblc]

> Лентяй : А разве возможно через такой метод интерактивно получить точку вставки в неактивном документе? Ее же надо как-то хитро задавать ИМХО... В общем, головняк. Я б постарался не связываться.

[Krieger]

Сообщение от Лентяй Не понял :? ! их что - в другой файл копировать надо? Тогда - ActivX-ом их, болезных!

Да нет, все там-же.

kpblc
Малость не то, надо какой-то аналог ctrl+c, ctrl+v

А зачем там функция if?

[Кулик Алексей aka kpblc]

IF - чтобы отследить, был ли выбор. Если выбора не было, то ничего не делается. Так что ничего сверхъестественного
Если надо именно полный аналог, то тогда действительно без создания временного анонимного блока не обойтись (а потом его разбивать)...

[Лентяй]

Krieger: Да нет, все там-же

Вторично не понял - на хрена тогда бувер? Или между копированием и вставкой предполагаются какие-нить иные действия?

А зачем там функция if?

А это - вредное влияние Fatty и Apelsinov'а. Все - от неуверенности в себе и работе своих программ.

[Кулик Алексей aka kpblc]

А также ShaggyDoc, Alasher, {Smirnoff}... Если есть возможность сделать неправильно, рано или поздно найдется Кулибин, который именно так и сделает. Функция должна быть надежна, как шпала. Или как топор - кому как больше нравится . Но работать она должна всегда и в любых режимах.
От компа за лишнюю проверку не убудет, а мне поспокойнее.

[Krieger]

Сообщение от Лентяй Или между копированием и вставкой предполагаются какие-нить иные действия?

Точно! Извиняюсь, что не смог нормально сформулировать сразу.

[Лентяй]

Krieger: Точно! Извиняюсь, что не смог нормально сформулировать сразу.

Предупреждать надо! Я тут прикинул - можно нарисовать связку из двух функций. Одна собирает объекты для копирования, вторая - собственно копирует. Только вот вызов будет производится раздельно. Продолжать ли? Если да, то нужен ли фильтр примитивов и какой? Отвечать бысрто, а то уйду спать[sm1202].

[Лентяй]

Krieger, ловите прогу, ибо добр аз есмь днесь. Первая создает набор для копирования, вторая - копирует.

Код:

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

(defun C:Df_Copy ( / sss)
  (setq adoc (vla-get-ActiveDocument (vlax-get-acad-object))
        sss (vla-get-SelectionSets adoc)
        df_css (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-item (list sss "df_css")))
              (vla-add sss "df_css") (vla-item sss "df_css")));setq
  (if (> (vla-get-count df_css) 0) (vla-clear df_css))
  (prompt "\nSelect Objects")
  (vla-SelectOnScreen df_css (vlax-safearray-fill (vlax-make-safearray vlax-vbinteger '(0 . 0)) '(0)) 
    (vlax-safearray-fill (vlax-make-safearray vlax-vbvariant '(0 . 0)) (list "*Line")))
);Df_Copy
;
(defun C:Df_Pst ( / util pt0 pt1)
  (setq util (vla-get-utility adoc)
        pt0 (vla-getpoint util nil "Specify base point of displacement: ")
        pt1 (vla-getpoint util nil "Specify second point of displacement: "))
  (vlax-for obj df_css (vla-copy obj) (vla-move obj pt0 pt1))
);Df_Pst

DF - значит "Deffered" - задержанный (-ая). Фильтр "*Lines" можно заменить на любой другой, или отменить вовсе. Для этого нужно стереть все, что после (vla-SelectOnScreen df_css . Состав набора сохраняется, пока не будет создан новый набор. Пользуйтесь на здоровье и не забывайте денно и нощно благодарить меня за то, что я есть. [sm3514] Если что - свистите. [sm1400]

[Krieger]

Лентяй
Спасибо, пригодится.

Для этого нужно стереть все, что после (vla-SelectOnScreen df_css

Для чего? Если правильно понял это чтоб вообще фильтра небыло.

Не совсем ctrl+c, т.к. после удаления примитивов которые значатся в наборе копировать будет нечего.

[Krieger]

Еще такой вопросик:
Существует набор A из одного объекта (примитива):
(setq A (ssget))
Как узнать его имя (Entity name)?

[Елпанов Евгений]

Код:

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

(setq ss (ssget)
      name(ssname ss 0)
      )

[Ratmir]

Уважаемые мастера и гуру по AutoCAD не сможете ли вы объяснить как на LISP написать функцию в которой указываешь примитивы (не только Line, PLine но и Cirle, Arc..) а она выдает точки пересечения этих примитивов. Для отрезков я как понимаю есть стандартная функция, [ insers ] а для других примитивов?

[Krieger]

И от меня вопросик:
В DXF коде (по entget) полилинии имеем координаты вершин, как их от туда вытащить, ведь все имеют один ключ? По assoc выдается только первая вершина, а как с остальными?

[vk]

> Ratmir

Для других примитивов есть метод IntersectWith, он доступен через vla- функции. Иногда глючит.
Есть еще довольно безглючный метод, его описание можно найти в школьных учебниках геометрии


> Krieger

Можно удалить из списка все ненужные группы, тогда останутся нужные
Функция vl-remove-if-not вполне годится для этого.

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

Код:

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

           (setq ptl (apply 'append ;_ список точек для вывода
                            (mapcar '(lambda (el)
                                       (if (= 10 (car el))
                                         (list (cdr el))
                                       ) ;_  if
                                     ) ;_  lambda
                                    (entget e)
                            ) ;_  mapcar
                     ) ;_  apply
           ) ;_  setq

[VVA]

Или так

Код:

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

(while (setq el (member (assoc 10 el) el))
  (setq ptl (append ptl (list (cdar el))))
  (setq el (cdr el))
)

[Лентяй]

Сообщение от Ratmir Уважаемые мастера и гуру по AutoCAD не сможете ли вы объяснить как на LISP написать функцию в которой указываешь примитивы (не только Line, PLine но и Cirle, Arc..) а она выдает точки пересечения этих примитивов. Для отрезков я как понимаю есть стандартная функция, [ insers ] а для других примитивов?

Ну хрена ли мне с вами делать - держите прогу. Для себя писал, теперь вот вам отдаю ... Пользуйтесь на здоровье, да не забывайте денно и нощно сугубо и трегубо багодарить меня, любимого, за то, что я есть.

Код:

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

(defun IntPtLst (Fst Nxt / sa PtLst)
  (setq sa (vlax-variant-value (vla-IntersectWith fst nxt acExtendNone)) n 0)
  (cond (sa (while (< n (vlax-safearray-get-u-bound sa 1))
              (setq PtLst (cons (mapcar '(lambda (m) (vlax-safearray-get-element sa m))
                                  (list n (1+ n) (+ 2 n))) PtLst)
                    n (+ 3 n))));sa
        (T nil));cond
 (reverse PtLst)

Fst, nxt - объекты, соотно первый т второй. PtLst - список трехмерных точек пересечения объектов.[/code]

[Krieger]

vk

; error: bad argument type: lentityp nil

VVA

((40 . 0.0) (41 . 0.0) (42 . 0.0) (210 0.0 0.0 1.0))

[VVA]

VVA Цитата: ((40 . 0.0) (41 . 0.0) (42 . 0.0) (210 0.0 0.

0 1.0))
Так это остаток от списка, а список точек накапливается в ptl

Код:

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

(while (setq el (member (assoc 10 el) el)) 
  (setq ptl (append ptl (list (cdar el)))) 
  (setq el (cdr el)) 
)
(princ "\nКоординаты:")(princ ptl)(princ)

[vk]

Сообщение от Krieger vk ; error: bad argument type: lentityp nil

Ename примитива в переменную е не запихнули наверно...

[Ratmir]

Лентяй спасибо за функцию.
Возможно у меня кривые руки (Lisp не так давно занимаюсь, а изучал его институте так давно –(, что все забыл ), но как vla- функции заставить работать? Ниже привожу код и сообщение об ошибке. Данный пример я для себя делаю чтобы разобраться как работают некоторые функции и немного научится Lisp.

;;; -----------------------------------------------------------------------------------------------
;;; Функция объединяющая "Extend" и "Trim" если необходимо работать с несколькими примитивами
;;; Сначала выбираем с какой функцией работать ("Trim" - по умолчанию)
;;; Указываем границу (выбирается только одна граница) до которой примитивы будут редактироваться
;;; Линией указываем какие примитивы пересекающие ее будут редактироваться
;;;
;;; Аналог функций "Extrim" в "Express Tolls"
;;;
;;; Trim and Extend.LSP
;;;
;;; Исходник взят из книги "The ABC's of AutoLISP" Автор: George Omura.
;;; Функцию IntPtLst разработал Лентяй (Сан-Франциско) - сайт www.DWG.ru
;;; Пояснения и изменения: Ratmir
;;;
;;; -----------------------------------------------------------------------------------------------



(defun c:ExTr (/ x y u sset1 count mcount icount imcount int1 obj sa PtLst)
(graphscr)
(grclear)
(initget "Extend Trim")
(setq EorT (getkword "\Extend или <Trim>: "))
(if (equal EorT "")(setq EorT "Trim"))
(princ "\n Выбирите границу...")
(setq obj (car (entsel)))
(setq x (getpoint "\n Укажите начальную точку оси которая будет пересекать примитивы для редактирования: "))
(setq y (getpoint x "\n Укажите конечную точку оси: "))
(setq sset1 (ssget "c" x y))
(setq count 0)
(if (/= sset1 nil)
(progn
(setq mcount (sslength sset1))
(while (< count mcount)
(setq elst (ssname sset1 count)
);конец setq

;;; ----------------------
;;; -- Функция IntPtLst --
;;; ----------------------

(setq sa (vlax-variant-value (vla-IntersectWith elst obj acExtendNone)) n 0)
(cond (sa (while (< n (vlax-safearray-get-u-bound sa 1))
(setq PtLst (cons (mapcar '(lambda (m) (vlax-safearray-get-element sa m))
(list n (1+ n) (+ 2 n))) PtLst)
n (+ 3 n))));sa
(T nil)
);cond
(reverse PtLst)
;;; ----------------------
(setq icount 0)
(setq imcount (length PtLst))
(while (< icount imcount)
(setq int1 (nth (icount- 1) PtLst))
(if (equal EorT "Extend")
(command "_.extend" obj "" int1 "")
(command "_.trim" obj "" int1 "")
);конец if
(setq icount (1+ icount))
);конец while
(setq count (1+ count))
);конец while
);конец progn
);конец if
);конец функции ExTr

;;; -----------------------------------------------------------------------------------------------

Выдает сообщение
---------------------------------
Command: extr
Extend или <Trim>:

Выбирите границу...
Select object:
Укажите начальную точку оси которая будет пересекать примитивы для
редактирования:
Укажите конечную точку оси: ; error: bad argument type: VLA-OBJECT <Entity
name: 7ef65e98>

Command:
---------------------------------

[Ratmir]

У меня вопрос как избавиться, что бы некоторые размеры не оставались на месте, если их с объектом перемещать или копировать (слой не заморожен). Иногда при создании копии одного пространства листа, на нем изменить расположения размеров, то на источники они отображаются как на новом, но при изменении стиля они отображаются нормально

[Лентяй]

Ratmir, в вашей прграмме используются vla-функции, которые работают с ОБЪЕКТАМИ, вперемешку с LISP-функциями, которые работают с ПРИМИТИВАМИ. Поскольку вы не обеспечили преход от одного типа к другому, АвтоКАД выдает сообщение об ошибке.
С другой стороны, если вы собираетесь использовать свою программу только для отрезков (LINES), то вам моя функция не нужна, потому что она предназначена для определния точек множественных пересечений, например круг с прямоугольником или две извилистых полилинии. Ниже приводится вариант, написанный на ActiveX, т.е. с использованием vla-функций для "подравнивания" линий. Извините за английский, но при копировании русский текст крякозябрится.

Код:

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

(defun c:ExTr (/ vars adoc utl ass EorT mode ln0 ln pt)
  (vl-load-com)
  (setq vars (mapcar 'getvar '("CMDECHO" "OSMODE"))
        adoc (vla-get-activedocument (vlax-get-acad-object))
        utl (vla-get-utility adoc)
        ass (vla-get-ActiveSelectionSet adoc));setq
  (if (/= (vla-get-count ass) 0) (vla-clear ass))
  (vla-InitializeUserInput utl 128 "Extend Trim")
  (setq EorT (vla-getKeyWord utl "\Select Mode [Extend/Trim]: <Trim>"))
  (if (= EorT "") (setq EorT "Trim"))
  (setq mode (if (= EorT "Trim") acExtendNone acExtendOtherEntity))
  (vla-getEntity utl 'ln0 nil "Select Line to Extend to or Trim at: ")
  (vla-highlight ln0 t)         
  (prompt "\nSelect Line(s) to Extend or Trim: ")
  (vla-SelectOnScreen ass)
  (princ (strcat "\nSelected " (itoa (vla-get-count ass)) " lines"))
  (vlax-for ln ass
    (setq pt (vlax-invoke ln0 'IntersectWith ln mode))
    (if (= (vla-get-ObjectName ln) "AcDbLine")
      (if (= Eort "Trim")
        (vlax-put-property ln (if (< (vlax-curve-getParamAtPoint ln pt)
           (/ (vla-get-length ln) 2)) 'StartPoint 'EndPoint) (vlax-3d-point pt))
        (mapcar '(lambda (x) (if (equal (vlax-curve-getClosestPointTo ln pt) (vlax-get ln x))
                   (vlax-put-property ln x (vlax-3d-point pt)))) '(Startpoint EndPoint)));if
      (alert "\nThis Service for Lines Only!")));vlax
  (vla-update ln0)
  (vla-clear ass)
  (mapcar '(lambda (x y) (setvar x y)) '("CMDECHO" "OSMODE") vars)
);end

Если вам нужен вариант для полилиний, сообщите и я что-нить придумаю.
Успехов!

[vk]

но при копировании русский текст крякозябрится

Известный глюк Виндовс. Перед копированием надо переключить раскладку клавиатуры на RU.

[Лентяй]

Спасибо, в следующий раз обязательно попробую.

[Ratmir]

Лентяй спасибо за ответы. Функция, которую вы дали, иногда странно обрезает Line. Для обрезания и удлинения только примитивов Line я использую следующую функцию.
;; -------------------------
(defun c:ExTr (/ x y u sset1 count mcount icount pt1 pt2 int1 obj)
(graphscr)
(grclear)
(initget "Extend Trim")
(setq EorT (getkword "\Extend или <Trim>: "))
(if (equal EorT "")(setq EorT "Trim"))
(princ "\n Выбирите границу...")
(setq obj (car (entsel)))
(setq x (getpoint "\n Укажите начальную точку оси которая будет пересекать примитивы для редактирования: "))
(setq y (getpoint x "\n Укажите конечную точку оси: "))
(setq sset1 (ssget "c" x y))
(setq count 0)
(if (/= sset1 nil)
(progn
(setq mcount (sslength sset1))
(while (< count mcount)
(setq elst (entget (ssname sset1 count))
mtypeLine (cdr (assoc 0 elst))
)
(if (= mtypeLine "LINE")
(progn
(setq pt1 (cdr (assoc 10 elst))
pt2 (cdr (assoc 11 elst))
int1 (inters x y pt1 pt2 T)
)
(if (equal EorT "Extend")
(command "_.extend" obj "" int1 "")
(command "_.trim" obj "" int1 "")
)
)
(princ "\n Выбран не Line")
)
(setq count (1+ count))
)
)
)
)
;; -------------------------
Но не для всех примитивов можно использовать функцию assoc и inters. Вычислять с помощью формул геометрии, точки пересечения разных примитивов утяжеляет функцию (для меня).
Вопрос не подскажите сайт или литературу (в свободном распространении) по LISP, где много примеров и подробно их разбирают, а то если и нахожу по одно и тоже (рисование дорожки с плиткой). Хотелось более лучше изучить LISP, сейчас разбираюсь по книге George Omula “The ABC’s of AutoLISP” (с трудом ).

P.S. Поздравляю всех девушек сайта www.DWG.ru с наступающем 8 МАРТА (по новому стилю) и всех кто празднует 23 февраля по старому стилю. :P

[Krieger]

Как узнать на лиспе, выбраны элементы в данный момент или нет? В зависимости от того выбраны они или нет должно выполняться то или иное действие. Если элемент выбран, то его слой будет меняться, если нет будет устанавливаться другой слой текущим.

[Кулик Алексей aka kpblc]

Проверяй длину и наличие выбора:

Код:

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

(if (setq selset (ssget "_I"))
;;; Бла-бла-бла
)

[Krieger]

Почему такой код, если его вставить в ком строку работает, а с кнопки нет?

Код:

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

(vl-cmdf "change" "Previous" "" "Properties" "layer" "NewLayer" "")

[Krieger]

Вставляем блок, потом взрываем. Как потом выбрать объекты которые были в блоке?

[Кулик Алексей aka kpblc]

Я бы попробовал примерно так:

Код:

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

;|=============================================================================
*    Функция возвращает список имен примитивов, входящих в блок.
*    Параметры вызова:
*	block-name	имя блока. Если блока с таким именем в базе нет,
*			возвращает nil
*    Примеры вызова:
(_kpblc-get-block-content (cdr (assoc 2 (entget(car(entsel))))))
=============================================================================|;
(defun _kpblc-block-get-content (block-name / result item block_cont_next)
  (if (setq item (tblsearch "block" block-name))
    (progn
      (setq block_cont_next (cdr (assoc -2 item)))
      (while block_cont_next
	(setq result	      (cons block_cont_next result)
	      block_cont_next (entnext block_cont_next)
	      ) ;_ end of setq
	) ;_ end of while
      ) ;_ end of progn
    ) ;_ end of if
  result
  ) ;_ end of defun

[Лентяй]

kpblc:

Я бы попробовал примерно так:

Хорошие дети так не поступают! [sm2001] Хорошие дети поступают так: [sm2001]

Код:

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

(defun C:DbrFnd ( / adoc util obj)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object))
	util (vla-get-utility adoc))
  (vla-getEntity utli 'obj nil)
  (setq ents (vlax-safearray->list (vlax-variant-value (vla-explode obj))))
  (foreach ent ents (print ent))
);

Или так:

Код:

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

(defun ents (obj)
  (vlax-safearray->list (vlax-variant-value (vla-explode obj)))
 );

Алаверды!

[Krieger]

to kpblc

* Примеры вызова: (_kpblc-get-block-content (cdr (assoc 2 (entget(car(entsel))))))

перепутано get с block
Спасибо.

to Лентяй
Твой пост для Крыса?
Если не только для него, то объясни шо с этим делать. Не все-ж такие умные.

Код:

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

error: bad argument type: VLA-OBJECT nil

[Лентяй]

Сообщение от Krieger to Лентяй Твой пост для Крыса? Если не только для него, то объясни шо с этим делать. Не все-ж такие умные. Код: [Выделить все] error: bad argument type: VLA-OBJECT nil

Шо делать. шо делать - ачепятку исправить, вот шо Четвертая строка должна быть:

Код:

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

(vla-getEntity util 'obj nil "Выбрать блок, который взорвать нахер : " )

,
в смысле "утиль". Тогда будет ляпота, щастя и благорастворение воздУхов.

[aldt]

ГУРУ_ActiveX!!!
Подскажите пожалуйста как средствами ActiveX получить доступ к PolyFaceMeshVertex и PolyFaceRecord?

Заранее благодарен!

[Кулик Алексей aka kpblc]

Код:

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

(setq mesh (vlax-ename->vla-object (car (entsel))))
(vlax-dump-Object mesh t)
; IAcadPolygonMesh: AutoCAD PolygonMesh Interface
; Property values:
;   Application (RO) = #<VLA-OBJECT IAcadApplication 00b9b5e4>
;   Coordinate = ...Indexed contents not shown...
;   Coordinates = (1217.91 400.307 0.0 1397.39 2234.75 0.0 ... )
;   Document (RO) = #<VLA-OBJECT IAcadDocument 01128f90>
;   Handle (RO) = "E5"
;   HasExtensionDictionary (RO) = 0
;   Hyperlinks (RO) = #<VLA-OBJECT IAcadHyperlinks 062c2e14>
;   Layer = "0"
;   Linetype = "ByLayer"
;   LinetypeScale = 1.0
;   Lineweight = -1
;   MClose = 0
;   MDensity = 0
;   MVertexCount (RO) = 2
;   NClose = 0
;   NDensity = 0
;   NVertexCount (RO) = 2
;   ObjectID (RO) = 2130059112
;   ObjectName (RO) = "AcDbPolygonMesh"
;   OwnerID (RO) = 2130058488
;   PlotStyleName = "ByLayer"
;   TrueColor = #<VLA-OBJECT IAcadAcCmColor 062c2c40>
;   Type = 0
;   Visible = -1
; Methods supported:
;   AppendVertex (1)
;   ArrayPolar (3)
;   ArrayRectangular (6)
;   Copy ()
;   Delete ()
;   Explode ()
;   GetBoundingBox (2)
;   GetExtensionDictionary ()
;   GetXData (3)
;   Highlight (1)
;   IntersectWith (2)
;   Mirror (2)
;   Mirror3D (3)
;   Move (2)
;   Rotate (2)
;   Rotate3D (3)
;   ScaleEntity (2)
;   SetXData (2)
;   TransformBy (1)
;   Update ()
T

Это? Хотя я и не гуру ActiveX

[Лентяй]

Я думаю. что имелось в виду

Код:

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

(vla-getEntity util 'obj nil "Выбрать сеть : " )
(if (= (vla-get-ObjectName obj) ""AcDbPolygonMesh")
    (setq prp (vlax-get-property obj '*ИМЯ_СВОЙСТВА*)));if

А дальше делай с этим свойствам. что тебе нравится...

[aldt]

Kpblc и Лентяй
Спасибо за ответ, но мне нужен доступ к FaceRecord и FaceVeertex ?
Свойства:
; IAcadPolyfaceMesh: IAcadPolyfaceMesh Interface
; Property values:
; Application (RO) = #<VLA-OBJECT IAcadApplication 00d077b4>
; Coordinate = ...Indexed contents not shown...
; Coordinates = (9.0 10.0 0.0 8.2 10.0 0.0 ... )
; Document (RO) = #<VLA-OBJECT IAcadDocument 0141ac48>
; Handle (RO) = "4C5"
; HasExtensionDictionary (RO) = 0
; Hyperlinks (RO) = #<VLA-OBJECT IAcadHyperlinks 1284d2b4>
; Layer = "0"
; Linetype = "CONTINUOUS"
; LinetypeScale = 1.0
; Lineweight = -1
; Material = "ByLayer"
; NumberOfFaces (RO) = 112
; NumberOfVertices (RO) = 130
; ObjectID (RO) = 2130370280
; ObjectName (RO) = "AcDbPolyFaceMesh"
; OwnerID (RO) = 2130369968
; PlotStyleName = "ByLayer"
; TrueColor = #<VLA-OBJECT IAcadAcCmColor 1284d240>
; Visible = -1
Они отсутствуют в свойствах, через ent* функции доступ к ним возможен это подпримитивы
то что представлено вами это PolygonMesh а мне нужен PolyFaceMesh

[Кулик Алексей aka kpblc]

Есть предложение - приложить файлик и показать, как ты добирался до этих элементов.
Провокационный вопрос: если можно добраться через (entget), то зачем использовать именно vla?

[Лентяй]

Сообщение от kpblc Провокационный вопрос: если можно добраться через (entget), то зачем использовать именно vla?

Затем, что мне! ТАК!! НДРАВИЦЦА!!!

[Krieger]

Моя программа выполняет несколько действий:
Сначала отключаем привязки, потом что-то чертим (через функцию command), восстанавливаем привязки. Пользователь после нажатия кнопки увидел полученный результат, но он ему не понравился и нажимает ctrl+z - ничего не происходит, нажимает еще раз - начерченный объект исчезает. На этом он успокаивается и продолжает работать дальше и весьма скоро замечает что привязки-то не работают.
Вообщем вопрос, как сделать чтобы ctrl+z отменял всю пользовательскую функцию скопом, за раз.

[Кулик Алексей aka kpblc]

Одним из следующих способов:
1. либо поставить (command "_.undo" "_begin") в начале и (command "_.undo" "_end") в конце. Лично мне такой подход просто не очень нравится, но это дело вкуса
2. Либо получить указатель на активный документ (setq adoc (vla-get-activedocument (vlax-get-acad-object))) и опять же поставить метки начала и конца:
(vla-startundomark adoc)
;; чего-то творим
(vla-endundomark adoc)

[Krieger]

Спасибо.
А в чем-нибудь проявляется преимущество одного способа над другим?

[Кулик Алексей aka kpblc]

Да в общем-то нет. Просто выполнение (command) при cmdecho=1 оставляет следы в ком.строке, а (vla) - нет. Все равно ж из функции выход "тихий" (т.е. в конце стоит (princ))?

[Krieger]

Сообщение от kpblc Все равно ж из функции выход "тихий" (т.е. в конце стоит (princ))?

Ну, эхо я отключаю, а (princ) мне по баробану...

Например:

Код:

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

;;;---------------------------------------
;;;Функция: Kr_AngleWeld (layer / pt1 pt2 pt3 c an scx scy C1 C2 C3 C4 C5);
;;;---------------------------------------
;;;Описание: функция отрисовывает угловой заводской катет шва, а точнее просто вставляет блок правильно отмасштабированный и повернутый
;;;Параметры: layer - слой
;;;Пример: (Kr_AngleWeld "сварка")
;;;---------------------------------------

(defun Kr_AngleWeld (layer / pt1 pt2 pt3 c an scx scy C1 C2 C3 C4 C5)
	(setq pt1 	(getpoint "\nУкажите вершину треугольника")
	      pt2	(getpoint pt1 "\nУкажите катет")
	      pt3	(getpoint pt1 "\nУкажите второй катет")
	      c		(- (max (angle pt1 pt2) (angle pt1 pt3)) (min (angle pt1 pt2) (angle pt1 pt3)))
	      an	(- (+ (/ c 2) (min (angle pt1 pt3) (angle pt1 pt2))) (/ (* pi 90) 180))
	      scy	(/ (cos (/ c 2)) 0.70710678)
	      scx	(/ (sqrt (- 2 (* 2 (cos (/ c))))) 1.41421356)
	      C1 	(Getvar "Osmode")
	      C2 	(Getvar "AUTOSNAP")
	      C3 	(Getvar "Orthomode")
	      C4 	(Getvar "Clayer")
	      C5	(Getvar "Cmdecho")
  )
  (setvar "Cmdecho" 0)
  (command "_.undo" "_begin")
  (command "_-Layer" "_Make" layer "")
  (setvar "Osmode" 0)
  (setvar "AUTOSNAP" 0)
  (setvar "Orthomode" 0)
  (setvar "Clayer" layer)
  (command "_-insert" "PSK_Svarka" pt1 scx scy (/ (* an 180) pi))
  (setvar "Osmode" C1)
  (setvar "AUTOSNAP" C2)
  (setvar "Orthomode" C3)
  (setvar "Clayer" C4)
  (setvar "Cmdecho" C5)
  (command "_.undo" "_end")
  (command "_scale" "_L" "" pt1 pause)
 );end defun

Для блока:
[ATTACH]1152769334.dwg[/ATTACH]

[Кулик Алексей aka kpblc]

Гхм... Я б и рад файлик посмотреть, но 2007-й не установлен...
Попробуй такой код, у меня вроде как сработало:

Код:

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

;|=============================================================================
*    Функция отрисовки шва.
*    Параметры вызова:
*	layer-name	имя слоя, на который идет вставка. nil -> вставляется
*			на текущий слой
*    Примеры вызова:
(_kpblc-weld-seam nil)
=============================================================================|;
(defun _kpblc-weld-seam
       (layer-name / adoc weld_seam blk_ent ins_pt cath1 cath2)
  (vl-load-com)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (vla-startundomark adoc)
  ;; Проверяем, если ли вообще блок сварочного шва.
  (if (not (tblobjname "block" "weld_seam"))
    (progn ; Блок не найден, создаем, а что делать?
      (setq weld_seam (vla-add (vla-get-blocks adoc)
			       (vlax-3d-point '(0. 0. 0.))
			       "weld_seam"
			       ) ;_ end of vla-add
	    ;; Теперь засовываем в этот блок солид
	    blk_ent   (vla-addsolid
			weld_seam
			(vlax-3d-point '(0. 0. 0.))
			(vlax-3d-point '(1. 0. 0.))
			(vlax-3d-point '(0. 1. 0.))
			(vlax-3d-point '(0. 0. 0.))
			) ;_ end of vla-AddSolid
	    ) ;_ end of setq
      (vla-put-layer blk_ent "0")
      (vla-put-color blk_ent 0)
      (vla-put-lineweight blk_ent aclnwtbyblock)
      (vla-put-linetype blk_ent "byBlock")
      ) ;_ end of progn
    ) ;_ end of if
  ;; Теперь вставляем блок:
  (if (setq ins_pt (getpoint "\nТочка вершины треугольника <Выход> : "))
    (progn
      (if (not (setq cath1 (getpoint ins_pt "\nПервый катет шва (горизонт.) <1> : ")))
	(setq cath1 (list (+ (car ins_pt) 1.) (cadr ins_pt) (caddr ins_pt)))
	) ;_ end of if
      (if (not (setq cath2 (getdist ins_pt "\nВторой катет шва (верт.) <1> : ")))
	(setq cath2 1.)
	) ;_ end of if
      (setq weld_seam (vla-insertblock
			(if (and (zerop (vla-get-activespace adoc))
				 (= :vlax-false (vla-get-mspace adoc))
				 ) ;_ end of and
			  (vla-get-paperspace adoc)
			  (vla-get-modelspace adoc)
			  ) ;_ end of if
			(vlax-3d-point ins_pt)
			"weld_seam"
			(distance ins_pt cath1)
			cath2
			1.
			(angle ins_pt cath1)
			) ;_ end of vla-insertblock
	    ) ;_ end of setq
      ;; И меняем его настройки
      (if layer-name
	(vla-add (vla-get-layers adoc) layer-name)
	(setq layer-name (getvar "clayer"))
	) ;_ end of if
      (vla-put-layer weld_seam layer-name)
      (vla-put-color weld_seam 256)
      (vla-put-lineweight weld_seam aclnwtbylayer)
      (vla-put-linetype weld_seam "ByLayer")
      ) ;_ end of progn
    ) ;_ end of if
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun

===
Добавлено:
Чуток подправил код - там было непонятно, какой катет каким будет

[Krieger]

:shock:
Молодо - зелено.

у меня вроде как сработало

Дык и моя прекрасно работает (теперь вот и undo добавил).
Хотя может действительно создавать блоки не отходя от кассы...

Блок в 2000-м:
[ATTACH]1152780812.dwg[/ATTACH]

[Кулик Алексей aka kpblc]

Сообщение от Krieger :shock: Молодо - зелено.

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

[Krieger]

Сообщение от kpblc Сообщение от Krieger :shock: Молодо - зелено. :?:

Это я про себя. (в ActivX пока не бум-бум).

Сообщение от kpblc Насчет блока... Можно, конечно, и полилинию туда засобачить, и штриховку. Просто я со сваркой пока не воевал особо, вот и сделал как мог

Это как раз не принципиально. Блок выложил чтоб ты мог мою прогу посмотреть. У тебя треугольники получаются всегда прямоугольные, а у меня под любой угол подстраиваются. См. рис. Ну да ладно.

Подскажи как найти в списке стилей (например dimstyle), стиль который бы содержал в названии слова data?
[ATTACH]1152845400.gif[/ATTACH]

[ShaggyDoc]

По структуре программы для рисования разреза шва.

1. Должен быть отрисован разрез с заданным катетом, а в программах запрашиваются точки, то есть размер катета вычисляется. Для получения требуемого катета надо достаточно сложно указать точку, например, со смещением. Иначе будет "на глаз".

Лучше хранить значение катета (например, обычный 6 мм), и только при его изменении - сохранять. Или 2 размера, если они могут быть разные

2. При запросе вершины выводить текущий катет и иметь опцию для его изменения.

3. Зациклить ввод точки вершины (с выходом из цикла при пустом вводе), так как таких треугольничков обычно надо сразу несколько нарисовать, зачем же вызывать заново программу.

4. Сам треугольник все-таки лучше блоком. А если завтра захочется треугольничек "с брюшком", то не надо переписывать достаточно сложное программное создание определения блока.

5. Запрашивать не точки катета, а его ориентацию (поворот). При этом ориентация может указываться проще, чем одновременное указание конца катета для определения его размера.

6. А если шов не в виде прямоугольного треугольника, а косого? Этот вариант тоже надо учитывать. В этом случае может быть запрос и направления второго катета, но тогда не блоком рисовать.

И, конечно, обработка ошибок. Чтоб программа была надежной, как лом.

В варианте Kr_AngleWeld, "прекрасно работает" пока программу использует сам автор. Достаточно прервать при выполнении любого ввода и далее будет прерывание функции. А обработчика прерывания нет. К тому же зачем-то после вставки еще и ручное масштабирование выполняется. Тоже не защищенное от ошибки. Если при запросе "Укажите катет" запрашивался не размер катета, а только его направление, то так и надо спрашивать. Но зачем же дублировать?

[Krieger]

Ну вот, а начиналось все:

Сообщение от Krieger Вообщем вопрос, как сделать чтобы ctrl+z отменял всю пользовательскую функцию скопом, за раз.

Сообщение от ShaggyDoc 1. Должен быть отрисован разрез с заданным катетом, а в программах запрашиваются точки, то есть размер катета вычисляется. Для получения требуемого катета надо достаточно сложно указать точку, например, со смещением. Иначе будет "на глаз". Лучше хранить значение катета (например, обычный 6 мм), и только при его изменении - сохранять. Или 2 размера, если они могут быть разные 2. При запросе вершины выводить текущий катет и иметь опцию для его изменения.

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

3. Зациклить ввод точки вершины (с выходом из цикла при пустом вводе), так как таких треугольничков обычно надо сразу несколько нарисовать, зачем же вызывать заново программу.

Согласен. Надо доделать. Кстати как грамотно выйти при пустом вводе из функции while?

4. Сам треугольник все-таки лучше блоком. А если завтра захочется треугольничек "с брюшком", то не надо переписывать достаточно сложное программное создание определения блока.

Бум вставлять.

5. Запрашивать не точки катета, а его ориентацию (поворот). При этом ориентация может указываться проще, чем одновременное указание конца катета для определения его размера. 6. А если шов не в виде прямоугольного треугольника, а косого? Этот вариант тоже надо учитывать. В этом случае может быть запрос и направления второго катета, но тогда не блоком рисовать.

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

И, конечно, обработка ошибок. Чтоб программа была надежной, как лом.

Согласен.

В варианте Kr_AngleWeld, "прекрасно работает" пока программу использует сам автор.

Я не один пользуюсь, пока проблема возникла только с отменой, которая теперь решена.

Достаточно прервать при выполнении любого ввода и далее будет прерывание функции. А обработчика прерывания нет.

Ну и шут с ним, чем это грозит здесь? Отключение и включение привязок стоит таким образом, что при обрыве функции это ни чем не грозит. А так..., ну высветится сообщение об ошибке...

К тому же зачем-то после вставки еще и ручное масштабирование выполняется. Тоже не защищенное от ошибки. Если при запросе "Укажите катет" запрашивался не размер катета, а только его направление, то так и надо спрашивать. Но зачем же дублировать?

Вот тут да, если оборвать масштабирование треугольник останется с катетом=1 и потом его уже надо удалять. А зачем масштабирую уже сказал, причем это масштабирование должно буть визуальным - перемещаю курсор - увеличивается катет.

Из истории:
Сначала вставлял просто блок - прямоугольный треугольник и был у меня ма-а-а-ахонький макросик:

Код:

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

^C^C_-INSERT;Svarka;\;;\

и был доволен
Потом оказалось что этого мало и надо бы сделать для разных углов (не только прямоугольные). Да еще иногда масштабировать.
И написал макросик посложнее:

Код:

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

^C^C^P(setq pt1 (getpoint) pt2 (getpoint pt1) pt3 (getpoint pt1));\\\_Cal;C=Ang(pt1,pt2,pt3);_Cal;an=(C/2+Ang(pt1,pt2))-90;(setq scy (/ (cos (* (/ c 2 180) pi)) 0.70710678) scx (/ (sqrt (- 2 (* 2 (cos (* (/ c 180) pi))))) 1.41421356));_-insert;svarka;!pt1;!scx;!scy;!an;(setq pt2 nil pt3 nil c nil an nil scx nil scy nil);_scale;_L;;!pt1;\(setq pt1 nil)

Причем это урезанный вариант. И был еще больше доволен.
Потом решил таки переделать в lsp. И теперь там 30строк. У Крыса в два раза больше. И оказалось что все хреново.

[Кулик Алексей aka kpblc]

> Krieger : Ну извини, на что хватило, то и сделал Работа-то тоже висит - типа сделать там надо btw, я в ActiveX тоже не Копенгаген, что с удовольствием подтвердит Лентяй
Насчет стилей:
Список размерных стилей можно получить, например, так:

Код:

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

  (vlax-for item
	    (vla-get-dimstyles (vla-get-activedocument (vlax-get-acad-object)))
    (setq dimstylelst (append dimstylelst (list (vla-get-name item))))
    ) ;_ end of vlax-for

И делай со списком что хочешь Например, чтоб получить имена стилей с "*data*" внутри, можно и таким воспользоваться:

Код:

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

(setq	dimstylelst
	 (vl-remove-if-not
	   '(lambda (x) (wcmatch (strcase x t) "*data*"))
	   dimstylelst
	   ) ;_ end of vl-remove-if-not
	) ;_ end of setq

> ShaggyDoc : Я так понимаю, что в основном критика мне адресована?
> Krieger :

Кстати как грамотно выйти при пустом вводе из функции while

Как обычно

Код:

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

(while (setq ins_pt (getpoint "\nТочка вставки <Выход> : "))
;; Тра-ля-ля...
)

[ShaggyDoc]

Вот как такая программа делается с использованием функций ruCAD. Показываю не для того, чтобы применять (внутри используются спецфункции). Просто, чтобы продемонстрировать подход к структуре программы (цикл, возможность выбора опций во время ввода).

Все проверки, блокировки, обработка ошибок спрятаны внутри спецфункций ru-*, загружаемых в главной библиотеке.

Рисование треугольника производится просто солидом, без создания блока.

Код:

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

(defun ru-weld-catet (layer_name / catet old_layer pnt_vertex solid)
;; (ru-weld-catet "сварка")
;; Восстанавливаем значение по умолчанию,
;; причем переводим его из миллиметров на бумаге в единицы рисунка
  (setq catet (ru-conv-millimeter-in-paper-to-unit
                (atof (ru-user-read-last-param "catet_weld_on_paper" "2.0"))
              ) ;_ end of ru-conv-millimeter-in-paper-to-unit
  ) ;_ end of setq
;; Делаем текущим заданный слой. Если такого слоя нет, он будет создан
;; если был заблокирован - разблокируется
  (if layer_name
    (progn (setq old_layer (getvar "clayer"))
           (ru-layer-current layer_name)
    ) ;_ end of progn
  ) ;_ end of if
;; В цикле выполняем запрос вершины
;; При этом указывается величина катета, а в контекстном меню создается пункт Катет,
;; при выборе которого можно изменить величину катета.
;; Если уже был нарисован треугольник, дополнительно появляется опция Отмени,
;; при выборе которой последний нарисованный треугольник стирается.
;; Для выхода из цикла появляется действие по умолчанию Выход.
;;
;|
Примерный протокол работы:

СВАРНОЙ ШОВ: Катет 2 мм на бумаге. Вершина треугольника  [Катет]<Выход>:
Направление первого угла:
Направление второго угла:
СВАРНОЙ ШОВ: Катет 2 мм на бумаге. Вершина треугольника  
[Катет/Отмени]<Выход>:К
Катет шва, мм на бумаге  <2.0>:3
СВАРНОЙ ШОВ: Катет 3 мм на бумаге. Вершина треугольника  [Катет/Отмени]<Выход>:
Направление первого угла:
Направление второго угла:
СВАРНОЙ ШОВ: Катет 3 мм на бумаге. Вершина треугольника  [Катет/Отмени]<Выход>:О

СВАРНОЙ ШОВ: Катет 3 мм на бумаге. Вершина треугольника  [Катет]<Выход>:
|;
  (while (setq pnt_vertex
                (ru-get-point-or-exit
                  (strcat "СВАРНОЙ ШОВ: Катет "
                          (rtos (ru-conv-unit-to-millimeter-in-paper catet) 2 2)
                          " мм на бумаге. Вершина треугольника"
                  ) ;_ end of strcat
                  (if solid
                    "Катет Отмени"
                    "Катет"
                  ) ;_ end of if
                ) ;_ end of ru-get-point-or-exit
         ) ;_ end of setq
    (cond
      ((= pnt_vertex "Катет")
       ;; Запрос нового размера с значением по умолчанию
       (setq catet (ru-conv-millimeter-in-paper-to-unit
                     (ru-get-dist
                       "Катет шва, мм на бумаге"
                       (ru-conv-unit-to-millimeter-in-paper catet)
                       nil
                     ) ;_ end of ru-get-dist
                   ) ;_ end of ru-conv-millimeter-in-paper-to-unit
       ) ;_ end of setq
      )
      ((= pnt_vertex "Отмени")
       ;; Удаление последнего треугольника
       (ru-obj-ent-ss-erase solid)
       (setq solid nil)
      )
      ((ru-is-point pnt_vertex)
       ;; Рисование треугольника солидом
       (setq solid (ru-obj-add-solid
                     pnt_vertex
                     (polar pnt_vertex
                            (angle pnt_vertex
                                   (ru-get-point-reguired
                                     "Направление первого угла"
                                     pnt_vertex
                                   ) ;_ end of ru-get-point-reguired
                            ) ;_ end of angle
                            catet
                     ) ;_ end of polar
                     (polar pnt_vertex
                            (angle pnt_vertex
                                   (ru-get-point-reguired
                                     "Направление второго угла"
                                     pnt_vertex
                                   ) ;_ end of ru-get-point-reguired
                            ) ;_ end of angle
                            catet
                     ) ;_ end of polar
                     pnt_vertex
                   ) ;_ end of ru-obj-add-solid
       ) ;_ end of setq
      )
    ) ;_ end of cond
  ) ;_ end of while
  (if old_layer
    (ru-layer-current old_layer)
  ) ;_ end of if
  ;; Сохранение значения катета
  (ru-user-write-last-param "catet_weld_on_paper" (rtos (ru-conv-unit-to-millimeter-in-paper catet) 2 3))
  (ru-app-end)
  (princ)
) ;_ end of defun

[aldt]

Есть minЗначение и maxЗначение, необходимо вывести
шкалу значений (цветом) по диапазонам.
(vlisp)может кто-то решал уже данную проблему.

[Krieger]

Цикличность я добавил, обработку ошибок сделал, пустой ввод обрабатывается, проверку наличия слоя сделал. На первое время сойдет, а чтобы сделать как советует ShaggyDoc мне еще работать и работать :cry: , но к этому надо стремиться.

[ShaggyDoc]

to kpbls >

ShaggyDoc : Я так понимаю, что в основном критика мне адресована?

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

Я вообще сюда влез не ради критики конкретных кодов, а чтобы подтолкнуть на другой подход, на создание более надежных программ.

Функция Kr_AngleWeld удовлетворяет автора - и хорошо. Она проста и без всяких "закавыков". И всегда можно подправить себе (undo включить и т.п.). Для массового, "отчужденного" использования надо делать сложнее внутри (это скрыто от пользователя) и проще и гибче "снаружи"

> Krieger

мне еще работать и работать

Да не так уж много - вот kpbls не очень давно начал с LISP разбираться, а уже может сделать программу любой сложности. Ему бы только время, да постановку, если тема плохо знакома. "Я так думаю" (С)

[Евгений А.]

Господа, хорошие!!! Есть ли какая-нибудь приличная (!) альтернатива команде "_area" для вычисления площади поверхности твёрдого тела. (Хотелось бы ActiveX методы) Проблема c "_area" - не могу её применить для тел лежащих внутри блоков, не открывая редактор блока, а это очень сильно замедляет программу если блоков выше крышы!!!
[sm1400]
????

[vk]

Сообщение от Евгений А. ...альтернатива команде "_area" для вычисления площади поверхности твёрдого тела. (Хотелось бы ActiveX методы) Проблема c "_area" - не могу её применить для тел лежащих внутри блоков, не открывая редактор блока...

Ежели блок предполагается вставлять с одинаковыми масштабными коэффициентами по осям, то скорей всего особо много вычислять то ничего не надо... Ввести в состав блока скрытый атрибут к примеру, да прописать туда площадь при единичном масштабе. Это достаточно сделать один раз, а потом только читать значение атрибута. Остальное вроде чистая математика...
Как вариант - прицепить значения непосредственно к телам (например, в XDATA) после их создания или при создании блока.

[Кулик Алексей aka kpblc]

Можно по идее попробовать получить примитив через (nentsel) и к нему уже применять _area

[Евгений А.]

Сообщение от vk .... прописать туда площадь при единичном масштабе. Это достаточно сделать один раз, а потом...

Именно этот момент и получается очень медпенным - программе приходится открыть редактор блока, потом его закрыть, а тут на тебе - регенерация всего рисунка (большого). Целых три тормоза (даже если выключать регенерацию)....

-> kpblc
Команда: (setq ename (car (nentsel)))(print ename)(command "_area" "О" ename)
;выбираю вложенное тело:
Выберите объект:
<Имя объекта: 7ef70e50> _area
Первая угловая точка или [Объект/Добавить/Вычесть]: О
Выберите объекты: <Неверное имя объекта: 7EF70E50>
nil
"_area" по всей видимости дружит только с примитивами экрана (как например "ssget"

[Кулик Алексей aka kpblc]

Похоже на особенность функциклирования _area. У меня тоже не сработало

[VVA]

>Евгений А.
Если попробовать так

Код:

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

(defun s_area ( / sset vla-list name ObjNme Sum_area)
  (setq Sum_area 0)
(if (setq sset (ssget "_X" ))
  (progn 
    (setq vla_list (mapcar (function vlax-ename->vla-object)
	            (vl-remove-if (function listp)
		      (mapcar (function cadr) (ssnamex sset))))
	  sset nil )
  (foreach item vla_list
    (setq name (vla-get-ObjectName item))
    (cond
      ((member name '("AcDb3dSolid")) ;_Довить объекты, площадь которых считаем
	(if (not (VL-CATCH-ALL-ERROR-P
	    (VL-CATCH-ALL-APPLY
	      '(lambda ()(vl-cmdf "_.AREA" "_O" (vlax-vla-object->ename item))))))
	  (setq Sum_area (+ Sum_area (getvar "AREA"))))
       )
      ((= name "AcDbBlockReference")
       (foreach memb (vlax-invoke item 'Explode)
	  (setq ObjNme (vla-get-ObjectName memb))
	  (cond
	    ((member ObjNme '("AcDb3dSolid" ))
		(if (not (VL-CATCH-ALL-ERROR-P
		    (VL-CATCH-ALL-APPLY
		      '(lambda ()(vl-cmdf "_.AREA" "_O" (vlax-vla-object->ename memb))))))
		  (setq Sum_area (+ Sum_area (getvar "AREA"))))
	       )
	   ((eq ObjNme "AcDbBlockReference")
	    nil
	    ;Пропускаем вложенные блоки, если надо - делай рекурсию
	    ;http://www.autocad.ru/cgi-bin/f1/board.cgi?t=25113OT
	    )
	   (T nil))
	  (vla-Delete memb))
	 )
       )
       );_foreach item
    
    ));_if
  (princ "\nСуммарная площадь= ")(princ Sum_area)(princ)
  )

[vk]

Сообщение от Евгений А. Сообщение от vk .... прописать туда площадь при единичном масштабе. Это достаточно сделать один раз, а потом... Именно этот момент и получается очень медпенным - программе приходится открыть редактор блока, ....

Один вопрос, зачем открывать/закрывать?

[Евгений А.]

-> VVA Очень интересно, почему после (vlax-invoke item 'Explode) само вхождение остаётся в рисунке? (думал оно автоматом удаляется!)
Работает довольно быстро, большое спасибо, но моя программа как вы и хотели вначале должна создать именно атрибут с площадью тела в блоке. Есть на входе <имя примитива> 3dsolid в описании блока, нужна его площадь. Я делаю примерно так:

Код:

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

(entmake (entget (ename)))
(command "_area" "Î" (entlast))
(setq area (getvar "area"))
(entdel (entlast))

Работает довольно быстро, но ведь это всё попытки обмануть Автокад, хотелось бы чего-нибудь проще (элегантнее).
А по поводу открывать-закрывать - это пример.

[VVA]

Очень интересно, почему после (vlax-invoke item 'Explode) само вхождение остаётся в рисунке?

Потому что в helpe написано

Remarks Depending on the type of compound object you're exploding, different results occur. Refer to theEXPLODE command topic in the AutoCAD Command Reference for a detailed list of explodable objects and their results. You do not have to explode a block in order to manipulate its constituent entities. All block definitions have an Item method that allow you to manipulate the entities within the block without exploding the block definition itself

[Евгений А.]

->VVA Пардон!!! обознался (VA)
Я кстати немецкий когдато изучал, а с английским PROMT выдаёт такую белиберду:
Вы не должны взорвать блок, чтобы управлять его объектами непосредственной составляющей. Все выделения блока имеют метод Элемента{Пункта}, которые позволяют Вам управлять объектами в пределах блока, не взрывая выделение блока непосредственно.

Да и вообще я с Автокадом и В. Лиспом только-только начал знакомиться...

[VVA]

вначале должна создать именно атрибут с площадью тела в блоке.

Я бы создавал в конце, по анализу Sum_area >0. Вдруг в блоке нет солидов?
А насчет атрибута, на форуме были лиспы по созданию блоков методами ActiveX как из примитивов так и из существеющих блоков. Поищи. А еще лучше спроси у kpblca. У него этого добра есть.
Например здесь
http://www.arcada.com.ua/forum/viewt...er=asc&start=0
сообщение Добавлено: Пт 23 Июн , 2006 12:37
и здесь http://my.opera.com/kpblc/blog/
Скачай Cadware и посмотри, там лисп, есть чего подсмотреть :wink:

Можно сделать проще, включить в новый блок обработанный + артибут с его площадью.

[VVA]

которые позволяют Вам управлять объектами в пределах блока, не взрывая выделение блока непосредственно

Зерно здесь.
Вы не дожны взрывать/ расчленять (бррр уголовшина) блок чтобы манипулировать с его примитивами. Все блоки (определения блоков) имеют метод Item, который позволяет манипулировать элементами блока без его взрывания.
Использование vla-item

[Кулик Алексей aka kpblc]

Но в таком случае ты работать будешь с описанием блока, а не с конкретной вставкой (а для вставки могут быть установлены разные коээфициенты масштабирования, соответственно площадь будет уже другой).

[Евгений А.]

->VVA :roll: Немного о разном говорим. Мне этот вопрос (area) интересен в целях образования. Как чего писать (за что спасибо!) это одно , а вот новая идея это другое. Эта часть программы у меня давно уже готова и работает, но осталось чувство что можно было бы лучше.
Ведь как работает "area" с телом - наверно, извлекает из тела грани, из них замкнутые полилинии, а дальше считает (как-то) площадь замкнутой полилинии (например, как vlax-curve-getArea), а где-то програмисты поленились или лоханулись и теперь у меня такая вот проблема. Может есть идеи с vlax-curve-getArea ??? Хотелось бы тут копать!!!

[Кулик Алексей aka kpblc]

Так ета... (vlax-curve-*), по-моему, работает только с кривыми, насколько я знаю. Солиды это другое.

[VVA]

Поковыряй с помощью этого
Пособие по расшифровке DXF регионов и солидов
И здесь обсуждали
http://www.autocad.ru/cgi-bin/f1/board.cgi?t=23596eY

[Евгений А.]

->kpblc
Это не мой случай, поэтому о масштабах думать не надо. Программа об этом думает на предыдущих этапах.
Всё верно, но ведь тела - это набор граней, а они вершинами, как и полилинии. (Всё ж только зашифровано, а это очень не удобно!)

[Евгений А.]

->VVA
Отличные ссылки!!!
Большое спасибо, думаю то что надо. Обязательно что-нибудь сварганю. Только наверно попозже, когда закончу со своим проектом!

[point111]

как контролировать ESC (или любую другую клавишу) во время выполнения LISP программы?

пример:

Код:

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

(defun test (/)
(setq name_temp_layer "000")

(lay_m);|создание и установк текущим временного слоя|;
(setq dist_m (getdist "укажите расстояние: "))

;|а вот если сейчас нажать ESC, то прога остановится, в чертеже останется временный слой, а его надо в любом случае убить, т.е. запустиь (exitproc_m)|;

(alert (rtos dist_m 2 5))
(exitproc_m) ;|возвращение на текущий слой, уничтожение временного слоя|;
)






;|создание и установк текущим временного слоя, определение параметров слоя|;
(defun lay_m (/)
  (setq curent_layer (getvar "clayer"))
  (setq curent_color (getvar "CECOLOR"))
  (command "_layer" "_make" name_temp_layer "")
  (setq color_temp_layer 50) ;|цвет временного слоя|;
  (command "_layer" "_color" color_temp_layer "")
  (setvar "CECOLOR" "256")
  (command)
) ;|defun lay|;


;|возвращение на текущий слой, уничтожение временного слоя|;
(defun exitproc_m (/)
  (setvar "clayer" curent_layer)
  (setvar "CECOLOR" curent_color)
  (command "_purge" "_la" name_temp_layer "_y" "_y")
  (gc)
) ;|exitproc|;

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

процедура зачиски меня не интересует, я её напишу, но вот перехват нажатия кнопок (с последующим вызовом определенной процедуры) я нигде не нашел.

[ShaggyDoc]

"На все случаи жизни" корректный выход по ESC не получится. При нажатии ESC в работу включается стандартная функция *error*. Обычно ее переопределяют. В общем случае именно здесь должно быть восстановление всех требуемых параметров. И соответствующая структура программы - не делать досрочного выхода через exit и quit в разных местах, а всегда делать единственный штатный выход с завершением всех логически требуемых действий.

В Lisp, в отличие от других систем программирования, функции типа Exit вываливают сразу из программы, а не в структуру более высокого уровня.

Самое лучшее - написать "низкоуровневые" функции для любого ввода (то есть момента, когда пользователь реально может прервать программу). А обработчики досрочных прерываний оставить на случаи, когда пользователь прерывает "зависшие" длительные действия.

Подробно обо всем этом см. книгу "САПР на базе AutoCAD - как это делается" - здесь цитировать нет времени.

Там используется единственная низкоуровневая функция ввода, заменитель всех get*-функций. Позволяет вводить все, что угодно с опциональными значениями по умолчанию, ключевыми словами, базовыми точками и т.д. Нажатие ESC во время ввода блокируется, но всегда имеется возможность штатного выхода по умолчанию или в контекстном меню.

Что касается обработки любых клавиш, то это возможно с помощью функции grread. Она позволяет делать экзотичные действия, но в рядовых ситуациях применять ее не стоит.

Подобные функции сделаны и для выбора примитивов - чтобы проконтролировать осознанно ли отказался пользователь от указания объекта, или просто промахнулся. В таких случаях можно использовать анализ системной переменной ERRNO.

Кроме того, имеется замечательная функция vl-catch-all-error-p (и vl-catch-all-apply), позовляющая отлавливать любые ошибки (вплоть до деления на 0), не разрушая программу. Она же предотвращает неправильные движения "шаловливых ручек". Если заключить vl-catch-all-error-p в свою функцию-обертку, то можно и предотвращать ошибки, и получать о них внятные сообщения, и предусматривать правильный дальнейший ход программы.

[Krieger]

Как сделать возможность выбора опций при указке точки (getpoint)\объекта (entsel)? Т.е. например:
(while (setq (getpoint "\nУкажите начальную точку [Delta] <Выход> :"))
--
);end while
Так вот если не нажал enter и не указал точку, но ввел ключевое слово, например delta, надо будет указать эту delta, после чего вернуться указке точки.

Что-то наподобие того о чем говорил ShaggyDoc в 62-м посте:

Примерный протокол работы: СВАРНОЙ ШОВ: Катет 2 мм на бумаге. Вершина треугольника [Катет]<Выход>: Направление первого угла: Направление второго угла: СВАРНОЙ ШОВ: Катет 2 мм на бумаге. Вершина треугольника [Катет/Отмени]<Выход>:К Катет шва, мм на бумаге <2.0>:3 СВАРНОЙ ШОВ: Катет 3 мм на бумаге. Вершина треугольника [Катет/Отмени]<Выход>: Направление первого угла: Направление второго угла: СВАРНОЙ ШОВ: Катет 3 мм на бумаге. Вершина треугольника [Катет/Отмени]<Выход>:О СВАРНОЙ ШОВ: Катет 3 мм на бумаге. Вершина треугольника [Катет]<Выход>: |; (while (setq pnt_vertex (ru-get-point-or-exit (strcat "СВАРНОЙ ШОВ: Катет " (rtos (ru-conv-unit-to-millimeter-in-paper catet) 2 2) " мм на бумаге. Вершина треугольника" ) ;_ end of strcat (if solid "Катет Отмени" "Катет" ) ;_ end of if ) ;_ end of ru-get-point-or-exit ) ;_ end of setq

Но у него это все завернуто в ru-get-point-or-exit.

[Кулик Алексей aka kpblc]

Комбинацию (initget) И (getpoint), наверное? Я не уверен, потому как не особо работал с такими задачами...

[Krieger]

Как их комбинировать? Вот в чем вопрос.
Ну напишу я перед getpoint (initget 0 "Delta") и getpoint все равно точку просит и ругается если это не точка, соответственно запомнить результат не могу.

[Кулик Алексей aka kpblc]

Код:

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

(defun test (/ res)
  (initget 128 "Настройки наФиг _ O F")
  (setq res (getpoint "\nTest [Настройки/наФиг] <Выход> : "))
  (cond
    ((= (type res) 'str)
     (cond
       ((= (strcase res) "O")
        (princ "\nНастройки")
        )
       ((= (strcase res) "F")
        (princ "\nНас послали...")
        )
       ) ;_ end of cond
     )
    ((= (type res) 'list)
     (princ "\nА вот и точка...")
     )
    ) ;_ end of cond
  res
  ) ;_ end of defun

[nmr]

to krieger



(while (not flag)
(initget "Line Scale" 128)
(setq t1 (getpoint "\nНачальная точка или[Line/Scale]: "))
(cond
((eq t1 "Scale") (setq brkscale (getreal "\nМасштаб символа разрыва= "))
(princ (strcat "\nМасштаб= " (rtos brkscale 2 0))))
((eq t1 "Line") (setq protobreakln (car (entsel))
protobreakln-elist (entget protobreakln)
t1 (cdr (assoc 10 protobreakln-elist))
t2 (cdr (assoc 11 protobreakln-elist))
flag t)
)
((eq (type t1) 'list) (setq flag t)
(setq t2 (getpoint t1 "\nКонечная точка-> ")))));end while

[Krieger]

Спасибо, все просто.

[Krieger]

Еще вопросики:
1. После использования функции (entmod) изменяемый объект пропадает с экрана (но выделяется) и появляется только после регенерации (_regen). Регенерацию после каждого изменения объекта в больших чертежах делать накладно. Можно ли регенерировать отдельный объект? Пробывал функцию redraw - непомогло.
2. Почему не загружается VLX приложение функцией load, если не указать полный путь к файлу (однако путь прописан в путях поддержки)? Может есть какие аналоги - пробежаться по путям доступа и найти мое приложение?
3. Как сравнить два списка? Одинаковые - T, нет - nil.
4. Как определить вес линий назначенный слою.

[Кулик Алексей aka kpblc]

1. Попробуй (entupd) либо (vla-update).
2. Может, (findfile)?
3.

Код:

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

(setq lst '(1 2 3 4 5. 6.56) lst2 '(1 2 3. 4. 5. 6.56) lst3 '(2 3))
_$ (= lst lst2)
nil
_$ (eq lst lst2)
nil
_$ (equal lst lst2)
T
_$ (equal lst lst3)
nil

4. Не очень понял вопрос, но попробуй так:

Код:

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

(defun get-lw (ent / res)
              ;|
*    Определяет вес линии объекта. Возвращает либо строку, либо значение
* веса линии, умноженное на 100. В случае ошибки возвращает nil
*    Параметры вызова:
*	ent	указатель на запрашиваемый объект: vla, ename либо строка.
		строка воспринимается как имя слоя.
|;
  (if (vl-catch-all-error-p
        (vl-catch-all-apply
          '(lambda ()
             (cond
               ((= (type ent) 'vla-object)
                (setq ent (vlax-vla-object->ename ent))
                )
               ((= (type ent) 'str)
                (setq ent (tblobjname "layer" ent))
                )
               ) ;_ end of cond
             (setq res (cond
                         ((= (cdr (assoc 0 (entget ent))) "LAYER")
                          (setq res (cdr (assoc 370 (entget ent))))
                          (cond
                            ((= res -3)
                             "Default"
                             )
                            ((= res -2) "ByBlock")
                            ((= res -1) "ByLayer")
                            (t res)
                            ) ;_ end of cond
                          )
                         ((cdr (assoc 370 (entget ent))))
                         (t "ByLayer")
                         ) ;_ end of cond
                   ) ;_ end of setq
             ) ;_ end of lambda
          ) ;_ end of vl-catch-all-apply
        ) ;_ end of vl-catch-all-error-p
    (setq res nil)
    ) ;_ end of if
  res
  ) ;_ end of defun

[Евгений А.]

1) После Entmod используй Entupd.
2) Поищи по форуму - что-то было. (по идее должно находить)
3) (equal список1 список2 погрешность)
4) AktiveX - свойство Lineweight, для DXF - группа 370
___________
ps: опоздал...

[ForestX]

Очень надеюсь на вашу помощь в решении задачи:

С помощью представления cond или case определить функцию, которая возвращает в качестве значения столицу заданного аргумента государств.
Реализовать на Lisp300.

Заранее благодарен.

-----------------------------------------------------------

В Xlisp удалось реализовать таким образом:

Код:

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

		(defun stolica (strana)
           (case strana (Russia 'Moscow)
                               (Italy 'Rom))) 


Вывод:

(stolica 'Russia)

Необходимо переделать под Lisp300.