[Red Nova]

Со школы не ладится у меня с программированием. Все предметы щелкал, а на экзамене по информатике (Visual foxpro) программку типа суммирования столбцов списал у соседа (это уже в университете).
Не смотря на эте намерен научится писать программы для Автокада на лиспе, скачал книгу Хювенена, несколько примеров создания программ, но после получасового “смотрения” таких книг мое мышление явно притормаживает.
Решил пойти другим путем.
Нашел самый короткий лисп из моей коллекции, и прошу программистов с этого форума пошагово объяснить какой символ что означает. Надеюсь на вашу помощь.

Код:

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

(defun c:make-blocks-explodeable (/ adoc)
  (vl-load-com)
  (vla-startundomark
    (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
    ) ;_ end of vla-startundomark
  (vlax-for blk_def (vla-get-blocks adoc)
    (if (and (equal (vla-get-isxref blk_def) :vlax-false)
             (equal (vla-get-islayout blk_def) :vlax-false)
             ) ;_ end of and
      (vl-catch-all-apply '(lambda () (vla-put-explodable blk_def :vlax-true)))
      ) ;_ end of if
    ) ;_ end of vlax-for
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun

_____________________________________________________________________________________________________________

Прошло много лет и топик теперь представляет из себя площадку для обучения азов программирования для многих начинающих.
Так что начинающие лиспогрызы приветствуются .

[Jerald]

Не знаю, может неправильно его "одел"?

(defun C:77 (/)
Command: filedia
Enter new value for FILEDIA <1>: 0
Command: saveas
Current file format: AutoCAD 2007 Drawing
Enter file format [R14(LT98&LT97)/2000(LT2000)/2004(LT2004)/2007(LT2007)/Standards/DXF/Template] <2007>: dxf
Current DXF settings: Precision= 16 Format= ASCII Preview= No Version= 2007
Enter decimal places of accuracy (0 to 16) or [Binary/select Objects/Preview/Version] <16>: 16
Save drawing as <C:\Users\a.kulik\Documents\Drawing1.dxf>:
Command: filedia
Enter new value for FILEDIA <0>: 1
)

Команда: 77
; ошибка: no function definition: LT98&LT97

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

Код:

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

 (defun ss (/ filename sysvar)
  (if (setq filename (getfiled "Path to save" "" "dxf" 1))
    (progn (setq sysvar (vl-remove nil
                                   (mapcar (function (lambda (x / tmp)
                                                       (if (setq tmp (getvar (car x)))
                                                         (progn (setvar (car x) (cdr x)) (cons (car x) tmp))
                                                         ) ;_ end of if
                                                       ) ;_ end of lambda
                                                     ) ;_ end of function
                                           '(("sysmon" . 0) ("filedia" . 0))
                                           ) ;_ end of mapcar
                                   ) ;_ end of vl-remove
                 ) ;_ end of setq
           (vl-catch-all-apply (function (lambda () (vl-cmdf "_.saveas" "dxf" "16" filename))))
           (foreach item sysvar (setvar (car item) (cdr item)))
           ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of defun

----- добавлено через 48 сек. -----
Код не проверял, не до того как-то (

[Red Nova]

Помогите отфильтровать список пожалста.
Имею список такого типа:

(("1" "1a" "4" "18'-2 3/4"" "#5" "19") ("1" "1b" "3" "32'-4 1/4"" "#5" "19") ("2" "1a" "11" "20'-10 1/4"" "#5" "19") ("2" "1b" "4" "14'-2 1/4"" "#5" "19") ("2" "1c" "2" "9'-1 1/4"" "#5" "19") ("3" "1c" "2" "9'-1 1/4"" "#5" "19") ("3" "1d" "4" "9'-4 1/2"" "#5" "19") ("3" "1d" "1" "9'-4 3/4"" "#5" "19"))

Требуется удалить все элементы списка кроме тех что начинаются на определенное значение. К примеру если это 2, то от списка нужно оставить:

(("2" "1a" "11" "20'-10 1/4"" "#5" "19") ("2" "1b" "4" "14'-2 1/4"" "#5" "19") ("2" "1c" "2" "9'-1 1/4"" "#5" "19"))

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

Код:

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

 (vl-remove-if-not (function (lambda(x) (= (car x) "2"))) '(("1" "1a" "4" "18'-2 3/4"" "#5" "19") ("1" "1b" "3" "32'-4 1/4"" "#5" "19") ("2" "1a" "11" "20'-10 1/4"" "#5" "19") ("2" "1b" "4" "14'-2 1/4"" "#5" "19") ("2" "1c" "2" "9'-1 1/4"" "#5" "19") ("3" "1c" "2" "9'-1 1/4"" "#5" "19") ("3" "1d" "4" "9'-4 1/2"" "#5" "19") ("3" "1d" "1" "9'-4 3/4"" "#5" "19")) )

[Red Nova]

Спасибо, работает.
Тогда задачка по сложнее. Застрял ...
В списке следующего вида нужно перемножить каждый второй элемент подсписка на каждый третий и записать результат в конец списка.

(("1" "4" "18'-2 3/4\"" "#5" "19") ("2" "11" "20'-10 1/4\"" "#5" "19") ("3" "2" "9'-1 1/4\"" "#5" "19"))

Так что в результате будет:

(("1" "4" "18'-2 3/4\"" "#5" "19" "72' 11\"") ("2" "11" "20'-10 1/4\"" "#5" "19" "229' 43/4\"") ("3" "2" "9'-1 1/4\"" "#5" "19" "18' 21/2\""))

Скорее всего нужно копать mapcar, lambda и foreach. Погрызу их пока тут нет отзыва.
Длины у меня в футах и дюймах. Надеюсь это не критично при математических вычислениях.

И еще вопрос скажем так общеобразовательного толка. Как правильно называть лист в котором каждый элемент представляет из себя лист сам по себе. То есть такие как у меня. А-то все что я нахожу для работы с листами в основном для обычных листов. Может не так ищу.... ?

----- добавлено через ~3 ч. -----
Вот к чему я пока пришел.

Код:

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

 (defun testit (/ nxl lst newlst)
;(setq lst '(("1" "4" "18'-2 3/4\"" "#5" "19") ("2" "11" "20'-10 1/4\"" "#5" "19") ("3" "2" "9'-1 1/4\"" "#5" "19")))
 (setq lst '(("1" "4" "18" "#5" "19") ("2" "11" "20" "#5" "19") ("3" "2" "9" "#5" "19")))
 (setq lst
 (foreach n lst
  (setq nxl (list (princ (* (read (nth 1 n)) (read (nth 2 n))))))
  (append n nxl)
 )
 )
  (princ lst)
)
)

Вопрос 1. Вычисление провел, но не пойму как при записи результата обратно в лист добавить двойные кавычки. К примеру сейчас у меня лист получается такой
(("1" "4" "18" "#5" "19" 72) ("2" "11" "20" "#5" "19" 220) ("3" "2" "9" "#5" "19" 18))
а нужно так
(("1" "4" "18" "#5" "19" "72") ("2" "11" "20" "#5" "19" "220") ("3" "2" "9" "#5" "19" "18"))

Вопрос 2. foreach провел нужные действия, но на выходе я имею только последний элемент листа ("3" "2" "9" "#5" "19" 18), как вернуть весь лист?

Вопрос3. Как видите в коде я закомментил лист где длина в футах и дюймах, так как они не считались. Есть вариант проводить вычисления в империальном виде?

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

1. Изучай значение символа "\"
2. Преобразовывай неметрические данные в метрические, потом умножай - дели - складывай - вычитай, и результат обратно в дюймы/футы/ярды

[Red Nova]

Спасибо
По пункту 1 из моих вопросов.
Для добавления двойных кавычек мне нужно было понять что элемент с кавычками это string а без оных это integer. Дальше поиском нашел функцию itoa, которая и производит соответствующую конвертацию.

По пункту 2 из моих вопросов. Ты его пропустил, у тебя сразу потом про мой третий вопрос ))).
Пока не сумел вернуть по окончанию foreach весь список. Как и раньше писал возвращает только последний обработанный элемент листа.
То есть вместо
(("1" "4" "18" "#5" "19" "72") ("2" "11" "20" "#5" "19" "220") ("3" "2" "9" "#5" "19" "18"))
на выходе
("3" "2" "9" "#5" "19" "18")
ХЕЛП плиз.

Вот последний вариант кода.

Код:

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

 (defun testit (/ nxl lst newlst)
 (setq lst '(("1" "4" "18" "#5" "19") ("2" "11" "20" "#5" "19") ("3" "2" "9" "#5" "19")))
 (setq lst
 (foreach n lst
  (setq nxl (list (itoa (* (read (nth 1 n)) (read (nth 2 n))))));How can I convert   into a string with lisp
  (append n nxl)
 )
 )
  (princ lst)
)

По пункту 3. Пока продолжил в децимальной системе. Потом переконвертирую, или вообще в децимальной оставлю.

[Дима_]

Сообщение от Red Nova Пока не сумел вернуть по окончанию foreach весь список

Для этого есть mapcar.

[Red Nova]

По поводу пункта 2 придумал такой вариант. mapcar таки не использовал.

Код:

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

 (defun testit (/ nxl lst newlst)
;(setq lst '(("1" "4" "18'-2 3/4\"" "#5" "19") ("2" "11" "20'-10 1/4\"" "#5" "19") ("3" "2" "9'-1 1/4\"" "#5" "19")))
 (setq lst '(("1" "4" "18" "#5" "19") ("2" "11" "20" "#5" "19") ("3" "2" "9" "#5" "19")))
 (foreach n lst
  (setq nxl (list (itoa (* (read (nth 1 n)) (read (nth 2 n))))));How can I convert   into a string with lisp
  
  (setq newlst (append (list (append n nxl)) newlst))
  )
  (setq lst (reverse newlst))
)

[Дима_]

А если попробывать с:

Код:

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

 (defun testit2()
(mapcar '(lambda (n) (reverse (cons (itoa (* (read (nth 1 n)) (read (nth 2 n)))) (reverse n))))
         '(("1" "4" "18" "#5" "19") ("2" "11" "20" "#5" "19") ("3" "2" "9" "#5" "19"))))

ops. К вечеру глаз замылился - этож лисп:

Код:

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

 (defun testit2()
(mapcar '(lambda (n) (reverse (cons (itoa (* (read (cadr n)) (read (caddr n)))) (reverse n))))
         '(("1" "4" "18" "#5" "19") ("2" "11" "20" "#5" "19") ("3" "2" "9" "#5" "19"))))

[kacugu]

или попробовать с append

Код:

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

 
(defun c:testit (/ lst newlst)
(setq lst '(("1" "4" "18" "#5" "19") ("2" "11" "20" "#5" "19") ("3" "2" "9" "#5" "19")))
(setq newlst
	(mapcar
		'(lambda (x)
			(append x
				(list(itoa(* (atoi(cadr x)) (atoi(caddr x)))))))lst))
(princ)
)

[Дима_]

Сообщение от kacugu или попробовать с append

про append 1-го элемента см. здесь начиная с #12.

[Red Nova]

Гдеж вы были пока я не нашел решение Шучу, самому всегда интересно ковыряться. Вот только если бы на счет itoa подсказали это бы сэкономило мне несколько часов.
Тогда раз уж вас тут так много объясните кто-нибудь почему у меня vlide постоянно на лямбдах выводит в новое окно сообщение

;;; Copied to window at 8:14 PM 9/24/16 (LAMBDA (X) (ZEROP (SETQ I (1- I)))) ;;; End of text

Я потом не могу просмотреть last value после лямбды. Приходиться при помощи ctr+f8 пропускать кусок а дальше в окне последнего значение

'(LAMBDA (X) (ZEROP (SETQ I (1- I))))

Это можно в настройках убрать?

----- добавлено через ~2 ч. -----
Идем дальше.
Теперь у меня задача провести сравнение всех элементов списка и если первые элементы одинаковы провести группирование (суммирование последних элементов списка).
То есть имеем список типа:

Код:

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

 (("1" "#5" "19" "225") ("1" "#5" "19" "463") ("1" "#5" "19" "1164.75") ("2" "#5" "19" "2653.75") ("2" "#5" "19" "585") ("3" "#5" "19" "2653.75") ("3" "#5" "19" "585") ("3" "#5" "19" "227.5"))

На выходе требуется получть:

Код:

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

 (("1" "#5" "19" "1852.75") ("2" "#5" "19" "3238,75") ("3" "#5" "19" "3466.25"))

Есть идеи?

P.S. По поводу прошлого кода, использовал код от Димы с #3010, но пришлось заменить itoa на rtos чтоб работала с дробными...

[VVA]

Сообщение от Red Nova Есть идеи?

Есть. Немного изменить под твой список

----- добавлено через ~2 ч. -----
Как вариант

Код:

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

 
(defun any2float (item)
  (cond
    ((eq (type item) 'STR)(atof item))
    ((eq (type item) 'INT) item)
    ((eq (type item) 'REAL) item)
    (t 0)
    )
  )
(defun MakeUniqueMembersOfListWithCount  ( lst / OutList head countelt)
 ;;; lst - список списков, где последний элемент списка - число или число в строковом представлении
;;Применение
;;(MakeUniqueMembersOfListWithCount '((1 1)(2 1)(3 1)(1 2)(2 1)(3 3)))
;; Вернет ((1 3) (2 2) (3 4))
  
  (while lst
    (setq head (car lst)
	  countelt 0
          lst (vl-remove-if '(lambda(pt)(if (equal (reverse(cdr(reverse pt)))(reverse(cdr(reverse head))) 1e-6)(setq countelt (+ countelt (any2float(last pt)))) nil)) lst)
          OutList (append OutList (list (reverse(cons countelt (cdr(reverse head))))))))
  OutList
  )

На твоем примере

Код:

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

 

(setq srclst '(("1" "#5" "19" "225") ("1" "#5" "19" "463") ("1" "#5" "19" "1164.75") ("2" "#5" "19" "2653.75") ("2" "#5" "19" "585") ("3" "#5" "19" "2653.75") ("3" "#5" "19" "585") ("3" "#5" "19" "227.5")))
(MakeUniqueMembersOfListWithCount srclst)

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

Сообщение от Red Nova почему у меня vlide постоянно на лямбдах выводит в новое окно сообщение

Вместо '(lambda( .... )) используй (function (lamdba( ... )), тогда точки останова корректно срабатывают.

[Red Nova]

VVA, Спасибо . На тесте все работало, но при применении в команде дало сбой почему-то. Если интересно, во вложении код и файл на котором тестил (команда RN_SlabtableTotal)
Тут мне еще Lee Mac вариант подкинул. Так работает без ошибок.

Код:

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

     (defun mergelist ( l / a r x )
        (foreach x l
            (if (setq x (cons (list (car x) (cadr x) (caddr x)) (distof (last x)))
                      a (vl-some '(lambda ( y ) (if (vl-every '= (car x) (car y)) y)) r)
                )
                (setq r (subst (cons (car a) (+ (cdr a) (cdr x))) a r))
                (setq r (cons x r))
            )
        )
        (reverse (mapcar '(lambda ( x ) (reverse (cons (rtos (cdr x)) (reverse (car x))))) r))
    )

Кулик Алексей aka kpblc Спасибо, попробую.

[VVA]

Сообщение от Red Nova но при применении в команде дало сбой почему-то

Может быть потому, что в ф-ции последний элемент остается числом, а в твоем примере - строка
Добавил rtos

Код:

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

(defun MakeUniqueMembersOfListWithCount  ( lst / OutList head countelt)
 ;;; lst - список списков, где последний элемент списка - число или число в строковом представлении
;;Применение
;;(MakeUniqueMembersOfListWithCount '((1 1)(2 1)(3 1)(1 2)(2 1)(3 3)))
;; Вернет ((1 3) (2 2) (3 4))
  
  (while lst
    (setq head (car lst)
	  countelt 0
          lst (vl-remove-if '(lambda(pt)(if (equal (reverse(cdr(reverse pt)))(reverse(cdr(reverse head))) 1e-6)(setq countelt (+ countelt (any2float(last pt)))) nil)) lst)
          OutList (append OutList (list (reverse(cons (rtos countelt 4 6)(cdr(reverse head))))))))
  OutList
  )

----- добавлено через ~3 мин. -----
PS Проверил - работает. Правда к командам (command) и опциям пришлось добавить префиксы "_"
PPS Обрати внимание на цифру 4 в rtos

[Red Nova]

VVA, Спасибо. О футах и дюймах при применении rtos я уже нашел.

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

Код:

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

 (defun testit ()
(rtos (reduce #'+ (mapcar 'distof (mapcar 'car '(("225") ("560") ("463") ("755") ("1164.75") ("2653.75") ("585") ("153.75") ("2653.75") ("585") ( "227.5"))))))
  )

Command: (testit) ; error: no function definition: REDUCE

_________________________________
Добавил

Как я понял покопавшись - reduce это привилегия Emacs Lisp
Так что сделал так:

Код:

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

 (defun test8 (/ lst tot)
(setq tot 0)  
(foreach n (mapcar 'distof (mapcar 'car '(("225") ("560") ("463") ("755") ("1164.75") ("2653.75") ("585") ("153.75") ("2653.75") ("585") ( "227.5"))))
          (setq tot (+ n tot))
  )
  )

[VVA]

Сообщение от Red Nova дальше нужно суммировать

Код:

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

(setq lst '(("225") ("560") ("463") ("755") ("1164.75") ("2653.75") ("585") ("153.75") ("2653.75") ("585") ( "227.5")))
(setq sum (apply '+(mapcar 'atof (mapcar 'car lst))))

[Red Nova]

Спасибо, я apply без тебя не нашел. Пришлось извращаться )).

Кок можно проверить (вернуть T / nil) есть ли блок с определенным именем в файле (точнее проверить вставлен ли блок в файл)?

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

Так есть определение блока или есть вхождение блока?

[VVA]

Сообщение от Red Nova можно проверить (вернуть T / nil) есть ли блок с определенным именем в файле (точнее проверить вставлен ли блок в файл)?

Другими словами есть ли описание блока в таблице блоков в файле.

Код:

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

(tblobjname "BLOCK" "TEST")

где "TEST" - имя блока

[Red Nova]

Уточняю. Определение блока мне не важно. Нужно проверить вхождение. Когда подкидываете нужных терминов становится проще

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

Отлично... Вхождение куда? В пространство модели? Листа? Другого блока?

[skkkk]

Сообщение от Red Nova Кок можно проверить (вернуть T / nil) есть ли блок с определенным именем в файле (точнее проверить вставлен ли блок в файл)?

Код:

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

(if (ssget "_X" '((0 . "INSERT") (2 . "TEST"))) T nil)

где "TEST" - имя блока

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

skkkk, если блок в блоке, то набор вернет nil

[Red Nova]

Вхождение в пространство модели. Блоков в блоках нет.

skkkk

Код:

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

 (defun test ()
  (if (ssget "_X" '((0 . "INSERT") (2 . "BMP Plan PT")))
    (princ "hello"))
  )

Command: (test ) nil

Что не так?
Блок прикрепил.

[VVA]

Сообщение от Red Nova Что не так?

Блок динамический

Код:

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

;; Returns list of the Anonymous names taken by a Dynamic Block (if any)  -  Lee Mac 2011  -  www.lee-mac.com
;; Arguments:  block  - name of Dynamic Block.

(defun AnonymousInstancesof ( block / def rec nme ref lst )
  (while (setq def (tblnext "BLOCK" (null def)))
    (if (= 1 (logand 1 (cdr (assoc 70 def))))
      (progn
        (setq rec
          (entget
            (cdr
              (assoc 330
                (entget
                  (tblobjname "BLOCK" (setq nme (cdr (assoc 2 def))))
                )
              )
            )
          )
        )
        (while (setq ref (assoc 331 rec))
          (if
            (and
              (eq block (vla-get-effectivename (vlax-ename->vla-object (cdr ref))))
              (not (member nme lst))
            )
            (setq lst (cons nme lst))
          )
          (setq rec (cdr (member (assoc 331 rec) rec)))
        )
      )
    )
  )
  (reverse lst)
)
(defun LM:BlockList->Str ( lst del / f )
  ;; © Lee Mac 2011

  (defun f ( s ) (if (wcmatch s "`**") (strcat "`" s) s))
  
  (if (cdr lst)
    (strcat (f (car lst)) del (LM:BlockList->Str (cdr lst) del))
    (f (car lst))
  )
)

Пример

Код:

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

(ssget "_X"
  (list
    (cons 0 "INSERT")
    (cons 2 (LM:BlockList->Str (cons "BMP Plan PT" (AnonymousInstancesof "BMP Plan PT")) ","))
    (cons 410 (getvar "CTAB"))
  )
)

[Red Nova]

Пока не работает

Код:

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

 (defun test ()
  (if
    (ssget "_X"
  (list
    (cons 0 "INSERT")
    (cons 2 (LM:BlockList->Str (cons "BMP Plan PT" (AnonymousInstancesof "BMP Plan PT")) ","))
    (cons 410 (getvar "CTAB"))
  )
)
    (princ "hello")
    )
  )

Command: (test) ; error: ActiveX Server returned the error: unknown name: EffectiveName

_____________________
Добавил.
Нашел решение

Код:

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

 (defun test ( / js)
      (setq js (strcat "`**," "BMP Plan PT"))
       (if (ssget "x" (list (cons 0 "INSERT") (cons 2 js))) 	; selecting entire drawing
	     (princ "hello")
	      )
  (princ)
  )

_____________________
Потестил еще и снова добавил
Нет вру, так всегда возвращает T

[skkkk]

Red Nova, памятуя о твоей любви к динамическим блокам я должен был сразу догадаться, что он будет именно таким. У меня даже проскочила такая мысль, но в моменте отвлекли, а когда вернулся, она уже потерялась.
Тут во втором посте тоже есть код, вроде как раз тот, что тебе нужен. Но этот вариант, по-моему, ничем не лучше предложенного VVA, правда, я не проверял.
Offtop:

Сообщение от Кулик Алексей aka kpblc skkkk, если блок в блоке, то набор вернет nil

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

[VVA]

Сообщение от Red Nova error: ActiveX Server returned the error: unknown name: EffectiveName

Попробуй этот рецепт

Команда: (test) hello"hello"

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

Offtop:

Сообщение от skkkk Может, я и не прав, но считаю, что создавать блок, включая в его состав другие блоки - дурной тон. Кроме, пожалуй, случаев быстрого создания временных блоков (перетаскиванием правой кнопкой мыши) со случайным именем, которые нужны в небольшой отрезок времени для проведения манипуляций с некоторым набором объектов. Такие блоки я всегда обязательно взрываю и прибираюсь за ними.

Ну, ситуации бывают разные

[Red Nova]

skkkk
Спасибо , код по твоей ссылке помог

VVA
Спасибо, хотя предложенное лечение так и не помогло

Кулик Алексей aka kpblc
Уж прости что я иногда не умею правильно объяснять. Зато ты умеешь над такими как я измываться

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

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

[Prosto100]

Подскажите почему при вызове mleader через (command) подавляется встроенный текстовый редактор, а ввод текста происходит через командную строку?

[Сергей812]

Сообщение от Prosto100 Подскажите почему при вызове mleader через (command) подавляется встроенный текстовый редактор, а ввод текста происходит через командную строку?

пример вызова покажите - в каком режиме хоть запускаете?

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

Вообще-то я остерегся бы командными методами строить мультивыноски: http://autolisp.ru/2015/01/21/mleader_create_order/

[Prosto100]

Сообщение от Сергей812 пример вызова покажите - в каком режиме хоть запускаете?

Проблема в том что если вызывать _mleader через командную строку - то все ОК, и окно встроенного текстового редактора открывается, а если в той же командной строке ввести (command "_mleader"), то AutoCad предлагает ввести текст выноски через командную строку.

[Сергей812]

Prosto100, да, есть такое) А почему через тот же Lisp ActiveX не построить выноску?

[Prosto100]

Сообщение от Сергей812 Prosto100, да, есть такое) А почему через тот же Lisp ActiveX не построить выноску?

Все, разобрался - для активации редактора при использовании command(_.mtext) нужно предварительно ввести (initdia), а для mleader подходит (initcommandversion)!

[RNB]

Код:

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

(defun c:RBmleader ()
  (setvar "cmdecho" 0)
  (vl-cmdf "_-layer" "_make" "-Vynoska" "")
  (if (= (type
	   (vl-catch-all-apply
	     (function
	       (lambda ()
		 (command "_mleader" pause pause "")
	       ) ;_ end of lambda
	     ) ;_ end of function
	   ) ;_ end of vl-catch-all-apply
	 ) ;_ end of type
	 'list
      ) ;_ end of =
    (princ)
    (princ)
  ) ;_ end of if
  (vl-cmdf "_layerp")
  (vl-cmdf "_pselect" "_l" "" "_mleadercontentedit")
  (setvar "cmdecho" 1)
  (princ)
) ;_ end of defun

Ламерский код построения мультивыноски с заданным слоем. Моим потребностям удовлетворяет.

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

Опять забыл про обработку ошибок и метки начала/конца отмены...

[RNB]

Сообщение от Кулик Алексей aka kpblc Опять забыл про обработку ошибок и метки начала/конца отмены...

Каюсь, никак руки не доходят доделать по-человечески

[Red Nova]

Использую этот код для выбора динамических блоков с определенным именем. Есть простой метод вернуть их количество?

[Nike]

http://forum.dwg.ru/showthread.php?t=17333

[Сергей812]

getblockselection по сути ssget с фильтром, а что возвращает ssget? - набор она возвращает)

[Red Nova]

Nike, спасибо, хоть и не совсем ответ на мой вопрос, но пригодится на будущее ։)

______________________________________________________________________________

Помогите плиз код осилить. Никак не могу соединить эти два списка нужным образом.
Требуется провести сравнение между списками. Ищем совпадение по первому элементу подсписков. При нахождении проводим вычитание между соответствующими вторыми элементами.
Возвращаем результирующий список.

Пример списков:
(setq lstA '(("1" "57") ("2" "69") ("3" "89") ("4" "95") ("5" "89") ("6" "82") ("B" "49")))
(setq lstB '(("1" "53") ("3" "42") ("B" "22")))

Ожидаемый результат:
'(("1" "4") ("2" "69") ("3" "47") ("4" "95") ("5" "89") ("6" "82") ("B" "27")

Пока что мое нерабочее издевательство над кодом выглядит так:
*гнилыми помидорами не кидаться

Код:

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

 
(defun c:SubstractEC ( / lstA lstB lst lstn x sum floor)
  (setq lstA '(("1" "57") ("2" "69") ("3" "89")))
  (setq lstB '(("1" "53") ("3" "22")))
  (setq x 0)
  (setq floor (car (car lstA)))
  (setq sum (distof (cadr (car lstA))))
  (setq lst '())
  (foreach n lstB
    (if (= (car n) floor)
        (setq sum (- sum (distof (cadr n)))
	      lstn (append (list (car n)) (list (rtos sum 2 0)))
	      lst (append lst (list lstn))

	      x (+ 1 x)
	      floor (car (nth x lstA))
	      sum (distof (cadr (nth x lstA)))
	      )
        (setq x (+ 1 x)
	      floor (car (nth x lstA))
	      sum (distof (cadr (nth x lstA)))
	   )
     )
  )
  (princ lst)
  (princ)
)

Добавил.

Вот, нашел такой вариант.

Код:

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

 (defun SEC ( a b / c )
        (if a
            (if (setq c (assoc (caar a) b))
                (cons (cons (caar a) (list (rtos (- (distof (cadar a)) (distof (cadr c))) 2 0))) (SEC (cdr a) b))
                (cons (car a) (SEC (cdr a) b))
            )
        )
    )

[George_D]

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

Код:

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

  (defun c:Example_AddTable()
    ;; This example adds a table in model space
    (setq acadObj (vlax-get-acad-object))
    (setq doc (vla-get-ActiveDocument acadObj))

    (setq pt (vlax-3d-point 0 0 0))

    (setq modelSpace (vla-get-ModelSpace doc))
    (setq MyTable (vla-Addtable modelSpace pt 5 5 10 30))
    (vla-ZoomExtents acadObj)
)

----- добавлено через ~26 мин. -----
Разобрался:

Код:

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

 (vla-Deleterows MyTable 0 1)

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

Сообщение от George_D как создавать таблицу сразу без первой строки , предназначенной для имени таблицы.

Создать стиль, в котором отсутствует заголовок таблицы. Кажется, так.

[fah]

Доброго времени суток! Друзья! Такой вопрос, есть ли тут человек, который владеет Лиспом на профессиональном уровне? Срочно нужна помощь в написании скрипта для автокада. Программа почти дописана, остались некоторые тонкие моменты. Если вкратце, то суть в том, что нужно вытащить блоки с их атрибутами в формате vla , чтоб их можно было тем самым перенести в Excel, на данный момент это получается сделать так, что выделяются все блоки и выносится информации о каждом. Но нужно, чтоб блок можно было выбирать рамкой. Буду благодарен за помощь.

[Сергей812]

Сообщение от fah блоки с их атрибутами в формате vla

что это за чудесный формат?

Сообщение от fah Программа почти дописана

И где она? Если вызывает трудности извлечение атрибутов выделенных блоков, то чем же занимается почти написанная программа тогда?

[Alan]

Сообщение от fah суть в том, что нужно вытащить блоки с их атрибутами

Самое простое - применить команды _ATTOUT и _ATTIN

Сообщение от fah блок можно было выбирать рамкой

Ну там это делается...
Забрать файлик в EXCEL поманипулировать и отдать назад... без программирования.
Метод описан и продемонстрирован не раз!

[fah]

Требуют именно написать скрипт для автоматизированного перемещения информации о блоке с атрибутами в эксель...(
Я всё время работал в автокаде, но никак не с программированием...

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

fah, слабо верится, что на работе требуют написать скрипт. Больше похоже на учебную задачу. На работе обычно пофигу, как ты решил проблему - главное, решил.

[Сергей812]

Да и собственно

Сообщение от fah на данный момент это получается сделать так, что выделяются все блоки и выносится информации о каждом. Но нужно, чтоб блок можно было выбирать рамкой

в чем загвоздка то? Получили набор блоков и обрабатываете его - это уже все готово, судя по посту. А как формируете набор блоков - это уже вопрос интерфейса пользователя.

[fah]

Сообщение от Кулик Алексей aka kpblc fah, слабо верится, что на работе требуют написать скрипт. Больше похоже на учебную задачу. На работе обычно пофигу, как ты решил проблему - главное, решил.

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

[fah]

Сообщение от Сергей812 Да и собственно в чем загвоздка то? Получили набор блоков и обрабатываете его - это уже все готово, судя по посту. А как формируете набор блоков - это уже вопрос интерфейса пользователя.

Проблема в том, что я не знаю, Каким образом сделать этот выбор блока выделением рамкой. Нашёл функцию ssget, вроде она почти по теме, но довести до конца не удаётся.
да и информация в эксель пока не выводится, эту проблему пытается решить другой сотрудник, моя же задача сделать выбор конкретного блока.

[Сергей812]

Сообщение от fah Каким образом сделать этот выбор блока выделением рамкой. Нашёл функцию ssget, вроде она почти по теме, но довести до конца не удаётся.

так выкладывайте свой кусок кода - что не получается)

----- добавлено через ~2 мин. -----
Offtop:

Сообщение от fah эту проблему пытается решить другой сотрудник,

ждем новых участников форума с вопросами вывода в эксель)

[fah]

Собственно вот код:

p.s. выложил картинкой, потому что не удалил комментарии. Пусть лучше всё будет видно.

[Сергей812]

1. типичная задача сбора данных для спецификации - извлечение данных чего не используете то?
2. думал, что выбор осуществляете ssget с ключем X и фильтром на вставки блоков. У вас свой подход)

[fah]

Сообщение от Сергей812 1. типичная задача сбора данных для спецификации - извлечение данных чего не используете то? 2. думал, что выбор осуществляете ssget с ключем X и фильтром на вставки блоков. У вас свой подход)

Выбор пока никак не осуществляется( если сможете помочь с кодом для выбора используя ssget, буду рад помощи!

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

Во-первых, ошибка в кавычках "_C". Во-вторых, откуда берутся x и y? И в третьих, изучи разницу между апострофом и функцией list

[fah]

Сообщение от Кулик Алексей aka kpblc Во-первых, ошибка в кавычках "_C". Во-вторых, откуда берутся x и y? И в третьих, изучи разницу между апострофом и функцией list

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

[Сергей812]

Сообщение от fah Выбор пока никак не осуществляется( если сможете помочь с кодом для выбора используя ssget, буду рад помощи!

сейчас на том же озоне книга Полещука "AutoLISP и Visual LISP в среде AutoCAD" стоит чуть больше 300р без пересылки - там все эти вопросы рассмотрены. Если ваше чудо начальство требует программу от непрограммистов (вы сами "подставились" скорее всего неосторожными разговорами), то пускай раскошелиться) Во вторых, задачу такого уровня проще было бы написать на VBA в экселе самом, имхо - по COM подцепляетесь к активному документу, грабите вставки блоков - сохраняя в массиве записей имя блока и количество его вставок. Затем формируете нужное количество строк в динтаблице и выводите туда массив записей в соответствующие две колонки. На другом листе есть вторая динтаблица со всеми нужными данными для заполнения спецификации - формулами по имени блока подтягиваете все остальные данные для спецификации. Из экселя можно и стандартные функции выбора примитивов на чертеже вызвать - если нужно только часть чертежа обработать. Ну это уже тема не данной ветки)

[fah]

Сообщение от Сергей812 сейчас на том же озоне книга Полещука "AutoLISP и Visual LISP в среде AutoCAD" стоит чуть больше 300р без пересылки - там все эти вопросы рассмотрены. Если ваше чудо начальство требует программу от непрограммистов (вы сами "подставились" скорее всего неосторожными разговорами), то пускай раскошелиться) Во вторых, задачу такого уровня проще было бы написать на VBA в экселе самом, имхо - по COM подцепляетесь к активному документу, грабите вставки блоков - сохраняя в массиве записей имя блока и количество его вставок. Затем формируете нужное количество строк в динтаблице и выводите туда массив записей в соответствующие две колонки. На другом листе есть вторая динтаблица со всеми нужными данными для заполнения спецификации - формулами по имени блока подтягиваете все остальные данные для спецификации. Из экселя можно и стандартные функции выбора примитивов на чертеже вызвать - если нужно только часть чертежа обработать. Ну это уже тема не данной ветки)

Эту книгу пытаюсь изучать, она в pdf есть у меня. Просят именно в лиспе сделать, ибо осталось разобраться с выборкой рамкой конкретного блока и выводом в эксель. Vba и прочие языки не подойдут( если кто сможет мне варианты с выбором дописать, было бы очень хорошо, например, тот же ssget до логичного вывода.

[Сергей812]

Сообщение от fah Эту книгу пытаюсь изучать, она в pdf есть у меня. Просят именно в лиспе сделать, ибо осталось разобраться с выборкой рамкой конкретного блока и выводом в эксель. Vba и прочие языки не подойдут( если кто сможет мне варианты с выбором дописать, было бы очень хорошо, например, тот же ssget до логичного вывода.

что выведете в эксель то? имена блоков и их количество?

[Alan]

Тема "Спецификация оборудования" обсуждалась 100500 раз... Сам писал программы для этого
В "Поиск"! Например http://forum.dwg.ru/showthread.php?t...E2%E0%ED%E8%FF

[fah]

Сообщение от Alan Тема "Спецификация оборудования" обсуждалась 100500 раз... Сам писал программы для этого В "Поиск"! Например http://forum.dwg.ru/showthread.php?t...E2%E0%ED%E8%FF

основная задача автоматизировать спецификацию настолько, чтобы она готовая без забивания каких-либо данных переносилась в excel

[Сергей812]

Сообщение от fah основная задача автоматизировать спецификацию настолько, чтобы она готовая без забивания каких-либо данных переносилась в excel

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

[Alan]

Сообщение от fah чтобы она готовая без забивания каких-либо данных переносилась в excel

Для этого существует БКК (большая красная кнопка)
Мы писали программы для получения спецификации оборудования разными способами,
но остановились всё-таки на работе с Базой оборудования.
Пример, спецификации уже приводил. Еще раз прилагаю для fah (правда по ВК, но это не принципиально).

[Сергей812]

Offtop:

Сообщение от Alan Мы писали программы для получения спецификации оборудования разными способами, но остановились всё-таки на работе с Базой оборудования. Пример, спецификации уже приводил. Еще раз прилагаю для fah (правда по ВК, но это не принципиально).

сама постановка вопроса: один не программист пытается написать сбор информации о блоках с чертежа (хотя кода уже готового под это написано на лиспе...), второй видимо более опытный не программист пытается написать вывод в excel. Неизвестно кто пишет поддержку БД для заполнения спецификации полностью. И кто руководит этим праздником жизни в целом. Успехов им в этом интересном деле.

[trushev]

Отлаживая LISP программу в 6130 строк столкнулся с непонятным явлением.
При загрузке программы выдается сообщение:
Команда: (load "dr")
; ошибка: no function definition: F_PLVP.
Функция в файле программы имеется, синтасические ошибки в ней отсутствуют.
В результате поиска обнаружил в 4230 строке абсолютно в другой функции лишнюю скобку.
Удивило, что автокад не распознал не соблюдение баланса скобок.
Кто-нибудь сталкивался с подобным явлением, в каких случаях оно возникает?

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

Я бы подумал о том, чтобы "разбить" такой здоровый код на несколько функций. И их загружать чохом (благо лиспы по поиску файлов с определенным расширением в каталоге и подчиненных каталогах уже есть). Дешево и сердито, отлаживать проще...

[trushev]

Кулик Алексей aka kpblc, Код разбит на 17 вложенных функций. Удивляет, что автокад выдает ошибку не на лишнюю скобку (как на самом деле) а на неопределенную функцию.
Или корректная работа ограничена размером файла программы?

[Сергей812]

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

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

VLIDE отслеживает парность скобок и предоставляет чуть более удобные (по сравнению с обычным блокнотом) средства ввода функций и вызова справки по ним. Ну и еще по мелочи. ОСтальное - прерогатива программиста.

[Alan]

Сообщение от trushev автокад выдает ошибку не на лишнюю скобку (как на самом деле) а на неопределенную функцию

Так оно и есть!
До функции дело не доходит. Проверяй скобки форматированием кусков или подпрограмм

[trushev]

Offtop: На форуме не раз звучала мысль, что написание программы на LISP'е подобно написанию картины.
Отладка, скорее поддержка между делом, своих программ от 6000 до 40000 строк, созданных еще до 2005 года особых затруднений у меня не вызывает.
Понимаю, я дремучий мастодонт, но новых технологий написания мне уже не освоить.

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

Offtop: Если бы у меня было время, я бы глянул на эти многотысячнострочные коды... Но увы

[Сергей812]

Кстати, бесплатный Notepage++ в плане интерфейса более продвинутый, чем встроенный в акад редактор лиспа) Он позволяет и сворачивать функции, и подсказки (причем распознает и переменные в коде и тоже их выводит в списке подсказок).

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

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

[trushev]

Спасибо всем за отклики.

[kurstep]

Здравствуйте, есть ли у кого-нибудь лисп позволяющий пользоватся командой РАСТЯНУТЬ (_STRETCH) на штриховке - чтоб штриховка не перемещалась а нормально растягивалась?

[Alan]

Сообщение от Сергей812 Кстати, бесплатный Notepage++ в плане интерфейса более продвинутый

Знаю о его существовании и использовании вместо штатного VLIDE.
Но позволяет ли он пошаговую отладку, выводит ли текущие значения переменных и т.п.?
Когда-то давно смотрел, но он меня не поразил, ну или я что-то не заметил...

[Сергей812]

Сообщение от Alan Но позволяет ли он пошаговую отладку, выводит ли текущие значения переменных и т.п.? Когда-то давно смотрел, но он меня не поразил, ну или я что-то не заметил...

Он просто редактор, может чуть более удобный, чем встроенный в акад. Сразу видны принадлежность скобок друг другу (во встроенном надо хоткеи щелкать), встроенный словарь операндов и т.д. Я в лиспе пишу очень мало, в основном Net и иногда простые вещи через COM в связке Excel-Акад.

[trushev]

Сообщение от Alan пошаговую отладку, выводит ли текущие значения переменных

При отладке в стороннем текстовом редакторе для этих целей пользуюсь своей функцией, вставляя ее в код в требуемые точки останова:

Код:

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

(defun tect (kat / f)
  (setq f (open "aa" "w"))
  (princ kat f)
  (close f)
  (setq f (open "aa" "r"))
  (alert (read-line f))
  (close f)
)

Пример запуска (tect (list "T1" " X1 = " x1 " X2 = " x2))
где: T1 - номер точки останова, x1 x2 ... - список переменных STR, REAL, LIST, ... которые нужно проверить.
Применима при отладке диалогов в action_tile при вставке в тело (strcat ... "(tect (list \"T1\" \" X1 = \" x1 \" X2 = \" x2))")

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

Сугубо ИМХО: для отладки использовать лог - не самое лучшее решение. В VLIDE (если, конечно, ведется разработка именно под AutoCAD, а не под "клонкад") есть масса возможностей. Это раз. Второе: вставлять код напрямую в dcl - порочная практика. Нарисуй нормальную callback-функцию и используй ее при вызове диалога.

[Alan]

Сообщение от trushev При отладке в стороннем текстовом редакторе для этих целей пользуюсь своей функцией, вставляя ее в код в требуемые точки останова:

Такое я прошел лет 20 назад, использовал редактор от Turbo-Pascal

Сообщение от Сергей812 Он просто редактор, может чуть более удобный, чем встроенный в акад.

Понятно... Мне не подходит, Word получше как редактор . А для отладки VLIDE при всём его убогости

[Red Nova]

Подскажите плиз. Как можно получить и задать определенный параметр динамического блока (в моем случае линейный)? Задумал команду для изменения длины нескольких динамических блоков на подобии stretch. Не уверен возможно ли это, а может кто-то уже реализовал...

[kacugu]

http://lee-mac.com/dynamicblockfunctions.html
если во время вставки блока, то:
1. http://forum.dwg.ru/showthread.php?t=18018
2. http://forum.dwg.ru/showpost.php?p=166681&postcount=36

[Red Nova]

kacugu. Спасибо. Посмотрим

[quazi]

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

Код:

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

 (command "_-HATCHEDIT" "DR" "H")

становится как надо.
Вот еще нашел код, выбирающий все штриховки, может пригодится:

Код:

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

 (sssetfirst nil (ssget "_x" '((0 . "HATCH"))))

[Сергей812]

Ну так продолжайте изыскания - пускай сначала код корявый будет. Что получаете при вызове (ssget "_x" '((0 . "HATCH"))) - набор штриховок в текущем пространстве. Читайте дальше, как работать с наборами в лиспе.

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

Кто сказал, что при (ssget "_X") получаем только текущее пространство?

[Сергей812]

Да, сорри, ошибочно написал - что только текущее пространство. Если нужно, например, только с пространства модели получить - то в фильтр добавляем (67 . 0).

[quazi]

Сообщение от Сергей812 Ну так продолжайте изыскания - пускай сначала код корявый будет. Что получаете при вызове (ssget "_x" '((0 . "HATCH"))) - набор штриховок в текущем пространстве. Читайте дальше, как работать с наборами в лиспе.

Здесь нашел как обработать выделение http://www.lee-mac.com/selsetprocessing.html и особо не разбираясь получилось вот:

Код:

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

 (defun c:test1 (/ e i n s)
  (if (setq s (ssget "_x" '((0 . "HATCH"))))
    (progn
      (setq i 0
	    n (sslength s)
      )
      (while (< i n)
	(setq e	(ssname s i)
	      i	(1+ i)
	)
	(command "_-HATCHEDIT" e "DR" "H")
      )
    )
  )
  (princ)
)

Вроде работает.
Скажите, может по другому лучше сделать было?
Был уверен, что в лиспе не нужно было цикла в явном виде, а просто хитро вставить одну функцию в другую достаточно

[Сергей812]

сразу же два примечания к коду:
1. ВАЖНО: как закончили работать с набором (s в вашем случае), так сразу его закрыли (освободили) - путем присвоения nil. Максимальное количество одновременно открытых наборов конечно, а сами они уничтожаться только при закрытии рисунка.
2. Желательно: вставить проверку набора на nil (нет штриховок) и об этом сообщать пользователю. А если набор существует - то тогда пошли обрабатывать.
ну и можно вставить маркеры начала и конца блока отмены соответственно.

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

Сообщение от Сергей812 ВАЖНО: как закончили работать с набором (s в вашем случае), так сразу его закрыли (освободили) - путем присвоения nil. Максимальное количество одновременно открытых наборов конечно, а сами они уничтожаться только при закрытии рисунка.

Необязательно: набор хранится как локальная переменная и будет уничтожен после выхода из функции / команды

Сообщение от Сергей812 Желательно: вставить проверку набора на nil (нет штриховок) и об этом сообщать пользователю. А если набор существует - то тогда пошли обрабатывать

Тут согласен. В библиотеке готовых функций были решения по преобразованию набора в список.

Сообщение от Сергей812 можно вставить маркеры начала и конца блока отмены соответственно.

Не можно, а нужно
Ну и еще: есть command, а есть command-s. В зависимости от того, под какую версию идет разработка, это может быть критичным.

[Сергей812]

Сообщение от Кулик Алексей aka kpblc Необязательно: набор хранится как локальная переменная и будет уничтожен после выхода из функции / команды

а храниться набор или имя набора в локальной переменной? У Полещука написано, что имя набора сохраняется в переменной. А в функциях (работы с набором) фигурирует просто "набор" без уточнения.

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

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

----- добавлено через 52 сек. -----
Где-то был код (то ли на .NET, то ли на лиспе), который показывал ограничения по количеству наборов. Можно и самому сделать такой кодик.

[Сергей812]

В общем, нестыковка с Полещуком получается по наборам. Простенький lisp

Код:

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

 (defun Set_SSGet ( / )
  (setq lSet (ssget "_X"))
  (princ (strcat "\nЭлементов в наборе: " (itoa (sslength lSet))))
  (princ "\n")	
  (princ lSet)	
  ;(setq lSet nil)
  (princ)
)

(defun c:Test_SS ( / )
  (repeat 10000 (Set_SSGet))
)

Переменную lSet убрал из локальных вообще - все равно создает 10000 наборов с разными ссылками/именами, и не чихает. Естественно, на чертеже должен быть хотя бы один примитив. Или если одной и тоже переменной присваивать новый набор - то старый автоматически закрывается?

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

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

[VVA]

Сообщение от Сергей812 сразу же два примечания к коду:

И третье. Штриховки могут быть на заблокированном слое

Сообщение от Сергей812 Если нужно, например, только с пространства модели получить - то в фильтр добавляем (67 . 0).

Если нужно в текущем пространстве (что логично при использовании command), то можно к фильтру ssget добавить (cons 410 (getvar "CTAB"))

Код:

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

(defun c:test1 (/ e i s)
  (vl-load-com)
  (if (setq s (ssget "_x" (list (cons 0 "HATCH")(cons 410 (getvar "CTAB")))))
    (progn
      (setq i -1)
      (while (and
               (< (setq i (1+ i))(sslength s)) ;_цикл по примитивам в наборе
               (setq e	(ssname s i))          ;_достаем примитив из набора
               (vlax-write-enabled-p (vlax-ename->vla-object e)) ;_проверяем на возможность
                                                                 ;_модификации объекта
               )
        (command "_-HATCHEDIT" e "_DR" "_H")
      )
    )
    (alert "Штриховок не обнаружено")
  )
  (princ "\nОбработано ")(princ i)(princ " штриховок") 
  (princ)
)

[kurstep]

Сообщение от quazi Добрый день! Помогите пожалуйста, нужно все штриховки в чертеже поместить за их собственные контуры. LISPа не знаю, вот мои попытки: Предварительно выделяю одну штриховку и выполняю Код: [Выделить все] (command "_-HATCHEDIT" "DR" "H") становится как надо. Вот еще нашел код, выбирающий все штриховки, может пригодится: Код: [Выделить все] (sssetfirst nil (ssget "_x" '((0 . "HATCH"))))

я делаю так

Код:

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

  (defun c:шт ()
   (sssetfirst nil (ssget "_x" '((0 . "HATCH"))))
(command "ПОРЯДОК" "А")
)

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

kurstep, твоя команда не сработает на английской версии AutoCAD. Да и вообще работать будет только на русской.

----- добавлено через 49 сек. -----
И как она сработает, если штриховки будут еще и на заблокированных слоях, или в пространствах листов - тоже неизвестно.

[Vladimir_Sergeevich]

Сообщение от Кулик Алексей aka kpblc И как она сработает, если штриховки будут еще и на заблокированных слоях, или в пространствах листов - тоже неизвестн

Как это неизвестно? в этом случае как раз все понятно: что сможет обработает и выдаст предупреждение, что "столько то объектов на заблокированном слое".
Хотя... Если ничего не путаю, "ПОРЯДОК" (DRAWORDER), обработает и заблокированные слои

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

Vladimir_Sergeevich, если я не ошибаюсь, команда обрабатывает только текущее пространство. А ты тут приказываешь обработать и неактивные пространства.

[Vladimir_Sergeevich]

Это тогда вопрос, что сможет подцепить sssetfirst...
Выделить то выделяет, но "Не находятся в текущем пространстве: 93."

[Inferi]

Всем привет, почему не работает конструкция типа:

Код:

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

 (foreach units '("кг" "кВт" "м")
(vl-string-search units "N=0,55кВт")
)

[gomer]

Сообщение от Inferi почему не работает конструкция

потому что нет метров в киловаттах

[Vladimir_Sergeevich]

Inferi, а на основании чего получен вывод, что не работает? работает: на первом проходе даст nil, на втором 6, на третьем снова nil.
Ну и на выходе foreach выдает:

Сообщение от gomer потому что нет метров в киловаттах

[VVA]

Сообщение от Vladimir_Sergeevich работает: на первом проходе даст nil, на втором 6, на третьем снова nil.

Демонстрация слов Vladimir_Sergeevich,

Код:

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

(mapcar (function(lambda(x)(vl-string-search x "N=0,55кВт"))) '("кг" "кВт" "м"))

$ (mapcar (function(lambda(x)(vl-string-search x "N=0,55кВт"))) '("кг" "кВт" "м")) (nil 6 nil) _$

Если нужно проверить, есть ли что-либо из списка '("кг" "кВт" "м")) в строке, то можно применить такую конструкцию

Код:

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

(apply 'or (mapcar (function(lambda(x)(vl-string-search x "N=0,55кВт"))) '("кг" "кВт" "м")))

Возвращает T или NIL

[Neo]

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

[Сергей812]

Сообщение от Neo подскажите как вывести на экран обновляемое "окно" с текстом. текст собираю, как конкатенацию текстов выбранных мышкой. хочу чтобы на экране, в процессе работы, отображался результирующий текст. Это может быть или обновляемое окно или мтекст с привязкой к координатам экрана, а не чертежа. если не с помощью лиспа, то в каком направлении искать?

а чем вас вывод в комстроку не устраивает?

[frostmourn]

Neo, попробуйте тут посмотреть, как сделано- http://lee-mac.com/text2mtext.html

[Neo]

спасибо frostmourn. посмотрел, вроде даже понял как привязать текст к координатам мыши. мне бы, привязаться к кордиаминам угла видимой части экрана. пока нашел, что команда "STATUS" выдает Display shows.
пока и сделал вывод в командную строку. хочу выводить одновременно текущий и предыдущий обработанные тексты. в комстроке получается сильно загружено

[frostmourn]

Сообщение от Neo мне бы, привязаться к кордиаминам угла видимой части экрана.

Это проще. Здесь http://forum.dwg.ru/showpost.php?p=905056&postcount=6 функция _get-viewctr-size.

[Red Nova]

Имею блок панели и рамки маркера (смотри вложение).
Сам блок маркера не содержит атрибутов. Это скорее рамка вокруг атрибута самого блока панели.
Намерен написать команду для быстрого выравнивания блока маркера по положению и ширине атрибута при его вставке.

Предполагаемый алгоритм:
1. Получить координаты атрибута и вставить соответственно маркер.
2. Вычислить угол наклона атрибута в зависимости от угла поворота блока и угла параметра атрибута.
3. Получить ширину текста атрибута и назначить динамическую ширину блока маркера соответственно.

С первыми двумя пунктами проблем не должно возникнуть.
А вот как получить ширину атрибута не знаю.
В зависимости от значения полей внутри атрибута ширина будет каждый раз разная.

Идеи?

[VVA]

Red Nova,

Сообщение от Red Nova А вот как получить ширину атрибута не знаю.

В этой теме рассматривали варианты

[Inferi]

Всем привет! Есть список координат '((x1 y1 z1) (x2 y2 z2) (x3 y3 z3) (x4 y4 z4)). Как вернуть (x1 y1 z1) (x2 y2 z2) (x3 y3 z3) (x4 y4 z4), то есть как бы раскрыть внешние скобки? Была идея:

Код:

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

 (mapcar 'princ '((x1 y1 z1) (x2 y2 z2) (x3 y3 z3) (x4 y4 z4)))

Но потом понял что mapcar возвращает все тот же список.

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

Inferi, а тебе зачем?

[trushev]

Сообщение от Inferi Есть список координат '((x1 y1 z1) (x2 y2 z2) (x3 y3 z3) (x4 y4 z4)).

Вероятная причина: координаты точек тоже списки, а этого не видно.

[ShaggyDoc]

Сообщение от Inferi Как вернуть (x1 y1 z1) (x2 y2 z2) (x3 y3 z3) (x4 y4 z4), то есть как бы раскрыть внешние скобки? Была идея:

Слово "вернуть" - неверное. Возвращает результат функция в виде какого-то единственного значения, а вернуть четыре значения не сможет. Это единственное значение и есть список списков координат.

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

[VVA]

Сообщение от Inferi Есть список координат '((x1 y1 z1) (x2 y2 z2) (x3 y3 z3) (x4 y4 z4)). Как вернуть (x1 y1 z1) (x2 y2 z2) (x3 y3 z3) (x4 y4 z4), то есть как бы раскрыть внешние скобки?

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

Либо поэлементно с помощью foreach

Код:

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

(foreach pt  '((x1 y1 z1) (x2 y2 z2) (x3 y3 z3) (x4 y4 z4))
(princ "\nPoint ")(princ pt)
)

[ShaggyDoc]

Сообщение от VVA Либо поэлементно с помощью foreach

Совершенно верно. А как именно - зависит от того, как организована вся программа. Надо ли отдельно по нескольку раз использовать подсписки, т.е. назначать им какие-то имена переменных (по-бейсиковски) или всё можно в одном foreach проделать (по-лисповски).
Потому Кулик Алексей aka kpblc первым делом и спросил "а тебе зачем"?

[Inferi]

Спасибо всем за объяснение, было ошибочное мнение, что можно "скормить" всю конструкцию, раскрыв перед этим скобки, функции inters. Обошелся обычными car, cadr и прочее.

[Inferi]

Доброго времени суток! Создаю полилинию через vla, с помощью метода vla-SetBulge преобразую линейные сегменты в дуговые, вопрос следующий: можно ли не командными методами заштриховать полилинию с дуговыми сегментами?

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

Можно, почему нет? Создаешь объект штриховки, задаешь ему OuterLoop (если не ошибаюсь), потом выполняешь Evaluate.

[Inferi]

Разобрался, спасибо!

Код:

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

 
(setq hatchObj (vla-AddHatch model_space acHatchPatternTypePreDefined "SOLID" :vlax-true acHatchObject))
(setq myPolyObj (vlax-ename->vla-object (car (entsel))))
(setq outerLoop (vlax-make-safearray vlax-vbObject '(0 . 0)))
(vlax-safearray-put-element outerLoop 0 myPolyObj)
(vla-AppendOuterLoop hatchObj outerLoop)
(vla-Evaluate hatchObj)
(vla-Update hatchObj)

[kurstep]

Здравствуйте , подскажите как удалить все вхождения блока и сам блок определенного имени (допустим "nameblock") - причем блок находится и в модели и в листах

[Сергей812]

в инете достаточно примеров удаления заданного по имени блока на лиспе) В чем вызвано затруднение то?

[kurstep]

Если вы мне скинете ссылку я буду очень благодарен, я честно искал но не нашел(

[VVA]

Сообщение от kurstep искал но не нашел(

Delete Blocks
Lisp routine to delete blocks
Lisp for filtering certain blocks and delete them
Delete Block from multiple Layouts
Remove / Delete Block from multiple Layouts at the same time

[Inferi]

Доброго времени суток! Подскажите, возможно ли запустить функцию, имя которой которой хранится в переменной. Например я использую функцию суммирования воздуховодов (duct_sum), в первом случае нужно после ее вызова открыть диалог (duct), во-втором диалог (draw_duct_reducer). Хотел передать в качестве аргумента (duct_sum / "(duct)"), и (duct_sum / "(draw_duct_reducer)") соответственно, и в конце кода функции (duct_sum) открыть соответствующие диалоги. Возможна ли такая реализация или стоит избегать таких "костылей"?

[Дима_]

Сообщение от Inferi Подскажите, возможно ли запустить функцию, имя которой которой хранится в переменной

Можно:

Код:

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

 
(defun abc (x) (+ x x))

(apply (read "abc") '(5))

Сообщение от Inferi или стоит избегать таких "костылей"?

Да

[VVA]

Сообщение от Inferi возможно ли запустить функцию, имя которой которой хранится в переменной.

как вариант

Код:

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

(defun draw_duct_reducer ()(alert "draw_duct_reducer")(princ))
(defun duct()(alert "duct")(princ))
(defun duct_sum (x / func)
  (if (= x 1)(setq func duct)(setq func draw_duct_reducer))
  (func)
  (princ)
  )

пример

Код:

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

(duct_sum 1)
(duct_sum 2)

----- добавлено через ~4 мин. -----
почитал еще раз, наверное так

Код:

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

(defun draw_duct_reducer ()(alert "draw_duct_reducer")(princ))
(defun duct()(alert "duct")(princ))
(defun duct_sum (x func)
  (func)
  (princ)
  )

Пример

Код:

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

(duct_sum 1 duct)
(duct_sum 2 draw_duct_reducer)

[Vladimir_Sergeevich]

Всем доброго времени суток!
Столкнулся с весьма любопытной ситуацией. Рисую полилинию с помощью vla-addLightWeightPolyline. Пока система координат лежит в одной плосткости (ось z смотрит вверх) все нормально, никаких проблем. НО! Тут столкнулся со случаем, когда пск перевернута вверх тормашками (ось z ушла вниз) и вдруг передавемый список вида

Код:

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

 ((-0.168002 259.556 0.0) (-1.96325 260.428 0.0) (-3.83184 261.135 0.0) (-5.75204 261.691 0.0) (-7.70688 262.111 0.0) (-9.68363 262.413 0.0) (-11.6731 
262.616 0.0) (-13.6692 262.739 0.0) (-15.6682 262.803 0.0) (-17.668 262.826 0.0) (-19.668 262.829 0.0))

воспринимается как

Код:

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

 ((0.168002 259.556 0.0) (1.96325 260.428 0.0) (3.83184 261.135 0.0) (5.75204 261.691 0.0) (7.70688 262.111 0.0) (9.68363 262.413 0.0) (11.6731 
262.616 0.0) (13.6692 262.739 0.0) (15.6682 262.803 0.0) (17.668 262.826 0.0) (19.668 262.829 0.0))

Почему vla-addLightWeightPolyline при перевернутой ПСК зеркалит координаты относительно начала координат по оси X??

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

При работе с ActiveX, насколько я помню, координаты передаются в МСК. Попробуй создавать через entmake, с одновременным заданием 210 группы. Ну или потом меняй свойство Normal.

[Vladimir_Sergeevich]

Алексей, список номер раз и так в мск. Но, при перевернутой СК, воспринимается как отзеркаленный.
Попробуй поставить (vl-cmdf "_.ucs" "_3" '(0 0) '(10 0) '(10 -10)) и отрисуй vla-addLightWeightPolyline.
Я почти списал у Полещука:

Код:

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

 (if (not owner) (setq owner (sad-get-CurrentSpace))) ;;если не указано другого - активное пространство активного документа	
(setq pt_lst ;;convert to 2d-point-list
	(apply 
		'append 
		(mapcar 
			'list 
			(mapcar 'car pt_lst)
			(mapcar 'cadr pt_lst)
		) 
	) 
	i 0
) 
(if (> (length pt_lst) 2)
  (setq obj 
	(vla-addLightWeightPolyline	
		owner 
		(vlax-make-variant
			(vlax-safearray-fill
				(vlax-make-safearray
					vlax-vbDouble
					(cons 0 (1- (length pt_lst)) )
				) 
				pt_lst
			)
		) 
	)
  ) 

з.ы. действительно "Normal = (0.0 0.0 -1.0)"
з.з.ы что то тут не чисто...

Код:

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

 Команда: (vla-put-normal (vlax-ename->vla-object (car (entsel))) (vlax-3d-point '(0.0 0.0 0.0)) )
Выберите объект: ; ошибка: Ошибка Automation. Неверный ввод

ага, сам дурак... (0.0 0.0 1.0)

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

Я ж говорю - потом поменяй свойство Normal

[Vladimir_Sergeevich]

И все ж таки интересно, почему этот vla-addLightWeightPolyline кушает координты в WCS, а нормаль цепляет текущую?
Проверку на "нормальность" результата дописал...

[Nike]

Уважаемые знатоки, а из можно ли из LISP залезть в открытый документ Word и что-нибудь там поковырять, например, вставить текст в таблицу, двинуть курсор? Покажите примеры, пожалуйста!

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

Можно. Залезай

[Nike]

Как вставить текст нашел - http://forum.dwg.ru/showthread.php?t=5993&page=2

А передвинуть курсор, например в таблице (сделать TAB) если можно, как?

[trir]

а зачем?

[Nike]

trir, таблицу заполнять

[krok64]

Курсор двигается функциями Selection.MoveRight (Left, Up, Down), с параметром Unit на сколько двигать (например wdCell - 1 ячейка)

[trir]

а сделать экспорт csv?

[Nike]

Сообщение от krok64 Курсор двигается функциями Selection.MoveRight (Left, Up, Down), с параметром Unit на сколько двигать (например wdCell - 1 ячейка)

на VBA я знаю как, мне бы из LISP

Сообщение от trir а сделать экспорт csv?

[krok64]

Сообщение от Nike на VBA я знаю как, мне бы из LISP

А через vlax-invoke-method дергать VBA методы не получится?

[VVA]

Сообщение от Nike на VBA я знаю как, мне бы из LISP

По твоей ссылке выше есть пример на лиспе

;;;Делаем Word видимым (setq work_range (vlax-invoke-method ActiveDocument 'range 0 0)) (vlax-invoke-method work_range "insertafter" text ;_ end strcat ) ;_ end vlax-invoke-method ) ;_ end progn

[Nike]

Спасибо, получилось - (vlax-invoke-method (vlax-get-property msw "Selection") "MoveRight" wdCell

Ух, теперь такого натворю!!

----- добавлено через ~13 мин. -----
Натворил - из крайней правой ячейки курсор вылетает из таблицы и далее в программе ошибка.

Как бы всё-таки TAB в Word передать?

[krok64]

Сообщение от Nike Натворил - из крайней правой ячейки курсор вылетает из таблицы и далее в программе ошибка.

Не забывай вставлять пустые строки Selection.InsertRowsBelow(1) и тогда все будет хорошо

[Nike]

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

так вот при Selection.MoveRight Unit:=wdCell из крайней правой ячейки курсор прыгает первую ячейку следующей строки (если строки нету то создается, как при TAB)
а если я это же делаю лиспом (vlax-invoke-method (vlax-get-property ... "Selection") "MoveRight" wdCell)
то курсор не переходит в следующую ячейку, а вываливается из таблицы вправо и мыргает там.

[krok64]

Попробуй вместо константы wdCell число 12

[Nike]

krok64, ура, работает!

[Red Nova]

Доброго.

Подскажите плиз как в указанной точке можно назначить цвет блоку (строка 53).
Блок в списке vla-объектов (не уверен верно ли я выразился).
Подопытный блок прикрепляю.

*Добавил используемые функции от LeeMac

**Добавил еще
Нашел: vla-put-Color

Код:

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

  (defun c:test ( / blkselection vlablkselection hiddenlength CurrentThickness CurrentSpan CurrentLoading RebarSize lstThickness lstRebar tbl ColumnNumber)

  (vl-load-com)
  (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object)))) ;_ end of vla-startundomark

  (setq blkselection (getblockselection "BMP Plan ComSlab"))
  (setq vlablkselection (LM:ss->vla blkselection))  

 (foreach n vlablkselection
  (progn  
  (setq hiddenlength (LM:getdynpropvalue n "Hidden Length"))
  (setq CurrentThickness (distof (LM:vl-getattributevalue n "THICKNESS")))
  (setq CurrentSpan (/ (+ hiddenlength (/ CurrentThickness 2)) 1000))
  (setq CurrentLoading (distof (LM:vl-getattributevalue n "LOADING")))

  (setq lstThickness 	'(260	270	280	290	300	310	320	330))
  (setq lstRebar 	'("10M"	"15M"	"20M"	"25M"	"30M"	"35M"))
  (setq tbl '(
			(6.20	6.20	6.20	6.40	6.40	6.50	6.50	6.50)  ;10
			(7.00	7.00	7.00	7.20	7.20	7.20	7.20	7.40)  ;15
			(7.60	7.80	7.80	7.80	8.00	8.00	8.00	8.00)  ;20
			(8.60	9.00	9.00	9.00	9.20	9.20	9.20	9.20)  ;25
			(8.80	9.20	9.50	9.80	10.20	10.20	10.20	10.40) ;30
			(9.20	9.50	9.80	10.20	10.20	10.20	10.20	10.40) ;35
			))
  (cond ((= CurrentThickness (nth 0 lstThickness)) (setq ColumnNumber 0))
	((= CurrentThickness (nth 1 lstThickness)) (setq ColumnNumber 1))
	((= CurrentThickness (nth 2 lstThickness)) (setq ColumnNumber 2))
	((= CurrentThickness (nth 3 lstThickness)) (setq ColumnNumber 3))
	((= CurrentThickness (nth 4 lstThickness)) (setq ColumnNumber 4))
	((= CurrentThickness (nth 5 lstThickness)) (setq ColumnNumber 5))
	((= CurrentThickness (nth 6 lstThickness)) (setq ColumnNumber 6))
	((= CurrentThickness (nth 7 lstThickness)) (setq ColumnNumber 7))
	)

  (setq tbl (mapcar (function (lambda (x)
			      (nth ColumnNumber x)
			      )) tbl))
  ;'(6.2 7.0 7.8 9.0 9.2 9.5)

  (cond ((<= CurrentSpan (nth 0 tbl)) (setq RebarSize (nth 0 lstRebar)))
	((and (> CurrentSpan (nth 0 tbl)) (<= CurrentSpan (nth 1 tbl))) (setq RebarSize (nth 1 lstRebar)))
	((and (> CurrentSpan (nth 1 tbl)) (<= CurrentSpan (nth 2 tbl))) (setq RebarSize (nth 2 lstRebar)))
	((and (> CurrentSpan (nth 2 tbl)) (<= CurrentSpan (nth 3 tbl))) (setq RebarSize (nth 3 lstRebar)))
	((and (> CurrentSpan (nth 3 tbl)) (<= CurrentSpan (nth 4 tbl))) (setq RebarSize (nth 4 lstRebar)))
	((and (> CurrentSpan (nth 4 tbl)) (<= CurrentSpan (nth 5 tbl))) (setq RebarSize (nth 5 lstRebar)))
	((and (> CurrentSpan (nth 5 tbl)) (<= CurrentSpan (nth 6 tbl))) (setq RebarSize (nth 6 lstRebar)))
	((and (> CurrentSpan (nth 6 tbl)) (<= CurrentSpan (nth 7 tbl))) (setq RebarSize (nth 7 lstRebar)))
	(t (setq RebarSize "X"))  
	)

  (LM:vl-setattributevalue n "REBAR" RebarSize)
;òóò íóæíî íàçíà÷èòü öâåò
  
   );progn
  );foreach

  (vla-endundomark adoc) ;;; undomark bottom mark
  (command "regen")
 )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Get Attribute Value  -  Lee Mac
;; Returns the value held by the specified tag within the supplied block, if present.
;; blk - [vla] VLA Block Reference Object
;; tag - [str] Attribute TagString
;; Returns: [str] Attribute value, else nil if tag is not found.

(defun LM:vl-getattributevalue ( blk tag )
    (setq tag (strcase tag))
    (vl-some '(lambda ( att ) (if (= tag (strcase (vla-get-tagstring att))) (vla-get-textstring att)))
        (vlax-invoke blk 'getattributes)
    )
)

;; Set Attribute Value  -  Lee Mac
;; Sets the value of the first attribute with the given tag found within the block, if present.
;; blk - [vla] VLA Block Reference Object
;; tag - [str] Attribute TagString
;; val - [str] Attribute Value
;; Returns: [str] Attribute value if successful, else nil.

(defun LM:vl-setattributevalue ( blk tag val )
    (setq tag (strcase tag))
    (vl-some
       '(lambda ( att )
            (if (= tag (strcase (vla-get-tagstring att)))
                (progn (vla-put-textstring att val) val)
            )
        )
        (vlax-invoke blk 'getattributes)
    )
)

;; Get Dynamic Block Property Value  -  Lee Mac
;; Returns the value of a Dynamic Block property (if present)
;; blk - [vla] VLA Dynamic Block Reference object
;; prp - [str] Dynamic Block property name (case-insensitive)

(defun LM:getdynpropvalue ( blk prp )
    (setq prp (strcase prp))
    (vl-some (function (lambda ( x ) (if (= prp (strcase (vla-get-propertyname x))) (vlax-get x 'value))))
        (vlax-invoke blk 'getdynamicblockproperties)
    )
)

;; Set Dynamic Block Property Value  -  Lee Mac
;; Modifies the value of a Dynamic Block property (if present)
;; blk - [vla] VLA Dynamic Block Reference object
;; prp - [str] Dynamic Block property name (case-insensitive)
;; val - [any] New value for property
;; Returns: [any] New value if successful, else nil

(defun LM:setdynpropvalue ( blk prp val )
    (setq prp (strcase prp))
    (vl-some
       '(lambda ( x )
            (if (= prp (strcase (vla-get-propertyname x)))
                (progn
                    (vla-put-value x (vlax-make-variant val (vlax-variant-type (vla-get-value x))))
                    (cond (val) (t))
                )
            )
        )
        (vlax-invoke blk 'getdynamicblockproperties)
    )
)

;;------------=={ SelectionSet -> VLA Objects }==-------------;;
;;                                                            ;;
;;  Converts a SelectionSet to a list of VLA Objects          ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  ss - Valid SelectionSet (Pickset)                         ;;
;;------------------------------------------------------------;;
;;  Returns:  List of VLA Objects, else nil                   ;;
;;------------------------------------------------------------;;

(defun LM:ss->vla ( ss / i l )
    (if ss
        (repeat (setq i (sslength ss))
            (setq l (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) l))
        )
    )
)

;; Inverse Sine (ArcSin)
;; Args: -1 <= x <= 1

(defun asin (x)
  (cond ((< 1. (abs x)) nil)
        ((equal (abs x) 1. 1e-9)
         (* x (/ pi 2.)))
        (t (atan (/ x (sqrt (- 1 (expt x 2))))))))

;; Inverse Cosine (ArcCos)
;; Args: -1 <= x <= 1

(defun acos (x)
  (cond ((< 1. (abs x)) nil)
        ((zerop x) (/ pi 2.))
        (t (atan (/ (sqrt (- 1 (expt x 2))) x)))))

; select dynamic block by name

(defun getblockselection ( blk )
    (ssget ;"_X"
        (list '(0 . "INSERT")
            (cons 2
                (apply 'strcat
                    (cons blk
                        (mapcar '(lambda ( x ) (strcat ",`" x))
                            (LM:getanonymousreferences blk)
                        )
                    )
                )
            )
        )
    )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun testifblockexists ( blk / )
       (ssget "_X"
        (list '(0 . "INSERT")
            (cons 2
                (apply 'strcat
                    (cons blk
                        (mapcar '(lambda ( x ) (strcat ",`" x))
                            (LM:getanonymousreferences blk)
                        )
                    )
                )
            )
        )
     ) 	
 );defun

(defun LM:getanonymousreferences ( blk / ano def lst rec ref )
    (setq blk (strcase blk))
    (while (setq def (tblnext "block" (null def)))
        (if
            (and (= 1 (logand 1 (cdr (assoc 70 def))))
                (setq rec
                    (entget
                        (cdr
                            (assoc 330
                                (entget
                                    (tblobjname "block"
                                        (setq ano (cdr (assoc 2 def)))
                                    )
                                )
                            )
                        )
                    )
                )
            )
            (while
                (and
                    (not (member ano lst))
                    (setq ref (assoc 331 rec))
                )
                (if
                    (and
                        (entget (cdr ref))
                        (= blk (strcase (LM:al-effectivename (cdr ref))))
                    )
                    (setq lst (cons ano lst))
                )
                (setq rec (cdr (member (assoc 331 rec) rec)))
            )
        )
    )
    (reverse lst)
) ; end of defun

;; Effective Block Name  -  Lee Mac
;; ent - [ent] Block Reference entity

(defun LM:al-effectivename ( ent / blk rep )
    (if (wcmatch (setq blk (cdr (assoc 2 (entget ent)))) "`**")
        (if
            (and
                (setq rep
                    (cdadr
                        (assoc -3
                            (entget
                                (cdr
                                    (assoc 330
                                        (entget
                                            (tblobjname "block" blk)
                                        )
                                    )
                                )
                               '("AcDbBlockRepBTag")
                            )
                        )
                    )
                )
                (setq rep (handent (cdr (assoc 1005 rep))))
            )
            (setq blk (cdr (assoc 2 (entget rep))))
        )
    )
    blk
) ; end of defun

[trushev]

Всем доброго дня!

Не могу добиться обновленного отображения значений полей edit_box.

При открытом диалоговом окне выполняю последовательно расчет нескольких участков. Данные каждого участка последовательно загружаются в поля edit_box. Для каждого участка выполняется расчет и ход расчета визуально отображается в диалоговом окне. Но не наблюдается обновления картинки полей edit_box диалогового окна после загрузки параметров следующего участка.
Что не так?
Локализированный код проблемы прилагаю:
Файл tect.lsp

Код:

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

(defun vp_gid (
               /
               dlg ;имя файла описания диалоговых окон
               sww ;Список параметров по участкам
                sw ;список исходных данных текущего элемента расчета
               f
                       ;
            f_okvp ;Функция действий при выборе клавиши РАСЧЕТ (поля "ok" в функции vp_gid)
              )
              ;Функция действий при выборе клавиши РАСЧЕТ (поля "ok")
              ;
              (defun f_okvp (sww ;поэлементный список исходных данных
                             /
                             sw ;список исходных данных текущего элемента расчета
                              m
                              n
                            )
                            ;
                     (while (car sww)
                            (setq m 10000000
                                  n 0
                                 sw (car sww)
                            )
                            ;
                            ;Присвоение полям окна значений из текущего элемента 
                            ;списка sw
                            ;
                            (foreach k '("f" "z" "q20")
                                        (set_tile k (car sw))
                                        (setq sw (cdr sw))
                            );foreach k
                            ;
                            ;Выполнение расчета
                            ;
                            (while (> m 0.0)
                                     ;
                                     ;Визуальная индикация хода расчета
                                     ;
                                   (if (> n 1000000)
                                       (progn
                                       (set_tile "tx1" (strcat "Элемент N " (rtos m 2 0)))
                                       (setq n 0)
                                       );progn
                                   );if (> n 100000)
                                   (setq m (1- m)
                                         n (1+ n)
                                   )
                            );while (> m 0.0)
                                   ;
                            (setq sww (cdr sww))
                     );while
                        ;
              );defun f_okvp
              ;
              ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
              ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
              ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
              ;
              (setq dlg (load_dialog "tect.dcl")
                      f 4
              )
              (while (= f 4)
                          ;
                          ;Список параметров по участкам
                          ;
                     (setq sww (list '("1" "2" "3")
                                     '("10" "20" "30")
                                     '("11" "21" "31")
                                     '("12" "22" "32")
                               )
                     )
                     (if (new_dialog "dvp_gd" dlg)
                         (progn
                         (foreach k '("f" "z" "q20")
                                     (set_tile k "Пусто")
                         );foreach k
                       ;
                       ;Клавиша расчет
                         (action_tile "ok" (strcat "(f_okvp sww) "
                                                  "(done_dialog 4))"
                                           );strcat
                         );action_tile
                       ;                                                    
                         (setq f (start_dialog))
                         );progn
                       ;ИНАЧЕ сбой работы программы 
                         (alert (strcat "Сбой функции открытия диалогового окна"
                                        "\n"
                                        "\n  \"РАСЧЕТ ВОДОТОКА\""
                                )
                         )
                     );if (new_dialog "dvp_gd" dlg)
                       ;
              );while (= f 4)
              (unload_dialog dlg)
);defun vp_gid

Файл tect.dcl

Код:

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

dvp_gd : dialog {label = "РАСЧЕТ ВОДОТОКА";
             alignment = centered;
       spacer_1;
       : boxed_column {label = "ИСХОДНЫЕ ПАРАМЕТРЫ ВОДООТВОДА";            
           : edit_box {edit_width = 5; edit_limit = 5; key = "f";
                            label = "Площадь водосбора, га";
           }
           : edit_box {edit_width = 5; edit_limit = 5; key = "z";
                            label = "Коэффициент покрова разных видов поверхности";
           }
           : edit_box {edit_width = 5; edit_limit = 5; key = "q20";
                            label = "Интенсивность дождя с карты, л/с";
           }
           spacer_1;
       }
       spacer_1;
       : boxed_column {label = "РЕЗУЛЬТАТ РАСЧЕТА ЭЛЕМЕНТА";
              spacer_1;
              : text_part {alignment = left; width = 30; key = "tx1";}
              spacer_1;
       }
       spacer_1;
       : row {
          : spacer {width = 3;}
          : button {
             fixed_width = true;
                   width = 8;
               alignment = centered;
                   label = "РАСЧЕТ";
                     key = "ok";
          }
          : spacer {width = 3;}
          : button {
             fixed_width = true;
                   width = 8;
               alignment = centered;
               is_cancel = true;
                   label = "ВЫХОД";
                     key = "canc";
          }
          : spacer {width = 3;}
       }
       spacer_1;
}

[LcH]

Добрый день!
Хочу задать вопрос.

----- добавлено через ~6 мин. -----
(defun c:ByTemplateM ()
; Создать лист по шаблону
; Открывается диалоговое окно - Выбор шаблона из файла
;
(initdia) ; !!!! - открывается диалог
(command "._layout" "_template")
(princ)
)

Может подскажете, можно ли задать заранее на каком каталоге откроется диалоговое окно "Выбор шаблона из файла".
Я посмотрела, что путь от предыдущего сеанса работы сохраняется в реестре в профиле пользователя Автокада.

Спасибо, если кто-то откликнется на мой вопрос.

[VVA]

Сообщение от LcH что путь от предыдущего сеанса работы сохраняется в реестре в профиле пользователя Автокада.

Как вариант попробовать поменять значение в профиле (vl-registry-read vlax-product-key и vl-registry-write в помощь)
Пример для русского Автокада

Код:

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

(setq current_profile (vl-registry-read (strcat "HKEY_CURRENT_USER\\" (vlax-product-key) "\\Profiles")))
(setq InitialDirectory (vl-registry-read (strcat "HKEY_CURRENT_USER\\" (vlax-product-key) "\\Profiles\\" current_profile "\\Dialogs\\Выбор шаблона из файла") "InitialDirectory"))
(vl-registry-write (strcat "HKEY_CURRENT_USER\\" (vlax-product-key) "\\Profiles\\" current_profile "\\Dialogs\\Выбор шаблона из файла") "InitialDirectory" "D:\\Temp\\")

Но это не надежный путь.
У тебя ключевое

; Создать лист по шаблону

Поэтому имя шаблона и имя листа должно быть заранее известно, тогда его сразу и грузить

Код:

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

(command "_.LAYOUT" "_T" (findfile "ИГО3.dwt") "A4-A3.")

Если листов несколько, грузить все

Код:

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

(command "_.LAYOUT" "_template" (findfile "Форматы МИП ИГО.dwt") "*")

Использовать другой способ, например Steal from Drawing

This program allows the user to import (humourously: 'steal') items from another drawing into the current drawing. Upon running the program with the command syntax 'Steal' at the AutoCAD command-line, the user is prompted to select a drawing file (dwg/dwt/dws) from which to steal items. Following a valid selection, if the selected drawing contains items not already present in the current drawing, a dialog will appear displaying items available for import. The user may choose multiple items from a list of: Blocks ... Layouts ... Custom Properties

[LcH]

Добрый день!

Спасибо, что откликнулись, мне хотелось посоветоваться.
Явное указание имени файла шаблона (полного пути к файлу или без него) не подходит для моего случая, т.к. файлов dwt – несколько, в данном случае эти dwt содержат шаблоны оформления листов.
Параметры печати листов в одном dwt настроены на драйвер DWF6 ePlot.pc3, в другом листы тех же форматов и допустимыми формами основных надписей (согласно ГОСТ и СТО предприятия) настроены на печать через DWGToPDF.pc3. Третий файл dwt – те же листы, но настройка печати через doPDF. Есть еще dwt c динамическим блоком рамки и штампа и различными наборами для переопределения параметров печати. Хотелось, чтобы был выбор в диалоге, диалог сразу выходил на определенную папку. Хотя это, конечно, не большая проблема, папка на сервере всем известна, к тому же в диалоге "Выбор шаблона из файла" путь можно добавить в "Избранное". Просто хотят кнопку на ленте, нажав на которую, сразу получить лист, с требуемыми параметрами.
Интересно поэкспериментировать с заданием пути в реестре, но, наверно, значение "InitialDirectory" будет меняться только после закрытия и повторного запуска Автокада. Все равно, попробую.
! Большое спасибо за ссылку на "Steal from Drawing".
Как раз с этой программой попробую сейчас поработать.

[Maksim7enov]

Здравствуйте! Совсем не понимаю в лисп, но хотел бы спросить возможно ли создать по данной методике лисп для построения аксонометрических схем? Метод не знаю кому принадлежит но ОГРОМНОЕ спасибо тому кто это придумал!!
1.Повернуть систему на 315 гр.;
2.Сделать блок, либо скопировать и вставить как блок;
Вызвать, если нет панели «Свойств». Вызов панели Ctrl +1.
3.Выделить блок;
4.В панели свойств в пункте «Геометрия (Geometry):
Строка масштаб Y (Scale Y) задать 0,4142
5.Пункт «Прочее» (Misc) строка Поворот (Rotation) 22,5
6.Увеличить (Scale) весь блок в 1,306569 раз.

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

Maksim7enov, наверное, возможно. Попробуй.

[skkkk]

Maksim7enov, а имеющийся на форуме лисп Gakson не подойдет?

[Maksim7enov]

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

Код:

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

^C^C_rotate;\315;_block;1234;@;\\;__insert;1234;@;;0.4142;22.5;_scale;\@;\1.306569;

[skkkk]

Вообще интересно стало, что это за схема манипуляций с блоком такая. Реализовать подобный алгоритм довольно просто, однако я решил проверить все по пунктам - результат мне не понятен. То ли я неправильно делал, то ли у нас с автором этой методики разные понимания об аксонометрии. Результаты изобразил во вложении. Может, стоит уточнить, также об аксонометрии ЧЕГО идет речь?

[Maksim7enov]

У меня все получается. Беру объекты, поворачиваю на 315, потом создаю из них блок и меняю масштаб по Y и поворот. Масштабирую и все. Просто хотелось самому создать и все. Буду благодарен если подскажите в моем макросе возможно сделать так чтобы при масштабировании не выделять объекты а сослаться на ранее сделанный блок? т.е убрать лишний раз движение рамой выделения?

----- добавлено через ~10 мин. -----
Макрос доделал. Если кто будет пользоваться (хотя сомневаюсь) то вот:

Код:

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

^C^C_rotate;\315;_block;1234;@;\\;__insert;1234;@;;0.4142;22.5;_scale;\;@;1.306569;

[Red Nova]

Ку!
Почему vla-move у меня не работает? Или как иначе передвинуть объекты?
Файл в аттаче.

Код:

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

 (defun c:BMP_CSStretchstart2 ( / adoc blkselection vlablkselection hiddenlength pt1 pt2 dxpt ucschanged firstblockmarker *error*)

  (defun *error* ( msg )
 	(if ucschanged (command-s "_.ucs" "_prev"))        
        (princ  "\nError: Function cancelled")
        (princ)
    )

  (vl-load-com)

  (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object)))) ;_ end of vla-startundomark

  (setq blkselection (ssget '((0 . "INSERT")(66 . 1))))
  (setq vlablkselection (LM:ss->vla blkselection))

  (foreach n vlablkselection
    (if
      (LM:getdynpropvalue n "Hidden Length")
      (if
	(princ firstblockmarker)
	(progn
	  (setq hiddenlength (LM:getdynpropvalue n "Hidden Length"))
	  (setq hiddedlength (+ hiddenlength dxpt))
	  (LM:setdynpropvalue n "Hidden Length" hiddedlength)
	  (vla-move n '(0. 0. 0.) (cons dxpt '(0. 0.)))
	  )
	(progn
	  (setq firstblockmarker t)
	  (ucsobj (car (LM:ss->vla blkselection))); set new UCS
	  (setq ucschanged T) ; marker for *error* to reset UCS if routine doesn't get to it
	  (setq pt1 (getpoint "Pick Start Point:"))
	  (setq pt2 (getpoint "Pick End Point:"))
	  (setq dxpt (- (car pt2) (car pt1))); delta x between pt1 and pt2
	  (setq hiddenlength (LM:getdynpropvalue n "Hidden Length"))
	  (setq hiddedlength (+ hiddenlength dxpt))
	  (LM:setdynpropvalue n "Hidden Length" hiddedlength)
	  (vla-move n '(0. 0. 0.) (cons dxpt '(0. 0.)))
	  )
	)
      )
    )

  (command "ucs" "P" ""); return previous UCS
  (setq ucschanged nil)

  (vla-endundomark adoc) ;;; undomark bottom mark
  )


;;;

;; Get Dynamic Block Property Value  -  Lee Mac
;; Returns the value of a Dynamic Block property (if present)
;; blk - [vla] VLA Dynamic Block Reference object
;; prp - [str] Dynamic Block property name (case-insensitive)

(defun LM:getdynpropvalue ( blk prp )
    (setq prp (strcase prp))
    (vl-some (function (lambda ( x ) (if (= prp (strcase (vla-get-propertyname x))) (vlax-get x 'value))))
        (vlax-invoke blk 'getdynamicblockproperties)
    )
)

;; Set Dynamic Block Property Value  -  Lee Mac
;; Modifies the value of a Dynamic Block property (if present)
;; blk - [vla] VLA Dynamic Block Reference object
;; prp - [str] Dynamic Block property name (case-insensitive)
;; val - [any] New value for property
;; Returns: [any] New value if successful, else nil

(defun LM:setdynpropvalue ( blk prp val )
    (setq prp (strcase prp))
    (vl-some
       '(lambda ( x )
            (if (= prp (strcase (vla-get-propertyname x)))
                (progn
                    (vla-put-value x (vlax-make-variant val (vlax-variant-type (vla-get-value x))))
                    (cond (val) (t))
                )
            )
        )
        (vlax-invoke blk 'getdynamicblockproperties)
    )
)


;;------------=={ SelectionSet -> VLA Objects }==-------------;;
;;                                                            ;;
;;  Converts a SelectionSet to a list of VLA Objects          ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  ss - Valid SelectionSet (Pickset)                         ;;
;;------------------------------------------------------------;;
;;  Returns:  List of VLA Objects, else nil                   ;;
;;------------------------------------------------------------;;

(defun LM:ss->vla ( ss / i l )
    (if ss
        (repeat (setq i (sslength ss))
            (setq l (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) l))
        )
    )
)

;align the ucs according to the selected object
(defun ucsobj ( obj / insertion rotation adoc regUCS)
;(setq obj (vlax-ename->vla-object (car (entsel))))
(setq insertion (vlax-get obj 'InsertionPoint)
      rotation (vlax-get obj 'Rotation)
      adoc (vla-get-activedocument (vlax-get-acad-object))
      regUCS (vla-add
	       (vla-get-usercoordinateSystems adoc)
               (vlax-3D-point '(0 0 0))
               (vlax-3D-point (list (cos rotation) (sin rotation) 0))
               (vlax-3d-point (list (* -1 (sin rotation)) (cos rotation) 0))
               "ucs_obj")
      )
  (vla-put-origin regUCS (vlax-3d-point insertion 0 1))
  (vla-put-activeUCS adoc regUCS)
  )

[Psyakrev]

Red Nova,
Координаты начальной и конечной точки должны быть вариантами. Создавать можно через vlax-3D-point.

Код:

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

 (setq point1 (vlax-3D-point 0 0 0))
(setq point2 (vlax-3D-point x y z))
(vla-move object point1 point2)

[Red Nova]

Спасибо. С этой частью ясно. Возникла другая загвоздка. До того лисп выглядел несколько иначе и я перемещал блоки командными методами. То есть как-то так:
(command "_.move" blkselection "" "_non" '(0. 0. 0.) "_non" (cons dxpt '(0. 0.)))
При этом я менял координатную систему по текущему блоку, и тогда, все вычисления и перемещения проводились просто по оси Х.
Но при применении vla-move перемещение происходит в глобальной системе координат.
Есть вариант заставить работать vla-move в пользовательской системе координат?
Текущий вариант кода. Пример с пояснением в аттаче.

Код:

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

 
(defun c:BMP_CSStretchstart2 ( / adoc blkselection vlablkselection hiddenlength pt1 pt2 dxpt ucschanged firstblockmarker *error*)

  (defun *error* ( msg )
 	(if ucschanged (command-s "_.ucs" "_prev"))        
        (princ  "\nError: Function cancelled")
        (princ)
    )

  (vl-load-com)

  (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object)))) ;_ end of vla-startundomark

  (setq blkselection (ssget '((0 . "INSERT")(66 . 1))))
  (setq vlablkselection (LM:ss->vla blkselection))

  (foreach n vlablkselection
    (if
      (LM:getdynpropvalue n "Hidden Length")
      (if
	(princ firstblockmarker)
	(progn
	  (setq hiddenlength (LM:getdynpropvalue n "Hidden Length"))
	  (setq hiddedlength (- hiddenlength dxpt))
	  (LM:setdynpropvalue n "Hidden Length" hiddedlength)
	  (vla-move n (vlax-3D-point'(0. 0. 0.)) (vlax-3D-point (cons dxpt '(0. 0.))))
	  )
	(progn
	  (setq firstblockmarker t)
	  (ucsobj n); set new UCS
	  (setq ucschanged T) ; marker for *error* to reset UCS if routine doesn't get to it
	  (setq pt1 (getpoint "Pick Start Point:"))
	  (setq pt2 (getpoint "Pick End Point:"))
	  (setq dxpt (- (car pt2) (car pt1))); delta x between pt1 and pt2
	  (setq hiddenlength (LM:getdynpropvalue n "Hidden Length"))
	  (setq hiddedlength (- hiddenlength dxpt))
	  (LM:setdynpropvalue n "Hidden Length" hiddedlength)
	  (vla-move n (vlax-3D-point'(0. 0. 0.)) (vlax-3D-point (cons dxpt '(0. 0.))))
	  )
	)
      )
    )

  (command "ucs" "P" ""); return previous UCS
  (setq ucschanged nil)

  (vla-endundomark adoc) ;;; undomark bottom mark
  )

;;;

;; Get Dynamic Block Property Value  -  Lee Mac
;; Returns the value of a Dynamic Block property (if present)
;; blk - [vla] VLA Dynamic Block Reference object
;; prp - [str] Dynamic Block property name (case-insensitive)

(defun LM:getdynpropvalue ( blk prp )
    (setq prp (strcase prp))
    (vl-some (function (lambda ( x ) (if (= prp (strcase (vla-get-propertyname x))) (vlax-get x 'value))))
        (vlax-invoke blk 'getdynamicblockproperties)
    )
)

;; Set Dynamic Block Property Value  -  Lee Mac
;; Modifies the value of a Dynamic Block property (if present)
;; blk - [vla] VLA Dynamic Block Reference object
;; prp - [str] Dynamic Block property name (case-insensitive)
;; val - [any] New value for property
;; Returns: [any] New value if successful, else nil

(defun LM:setdynpropvalue ( blk prp val )
    (setq prp (strcase prp))
    (vl-some
       '(lambda ( x )
            (if (= prp (strcase (vla-get-propertyname x)))
                (progn
                    (vla-put-value x (vlax-make-variant val (vlax-variant-type (vla-get-value x))))
                    (cond (val) (t))
                )
            )
        )
        (vlax-invoke blk 'getdynamicblockproperties)
    )
)


;;------------=={ SelectionSet -> VLA Objects }==-------------;;
;;                                                            ;;
;;  Converts a SelectionSet to a list of VLA Objects          ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  ss - Valid SelectionSet (Pickset)                         ;;
;;------------------------------------------------------------;;
;;  Returns:  List of VLA Objects, else nil                   ;;
;;------------------------------------------------------------;;

(defun LM:ss->vla ( ss / i l )
    (if ss
        (repeat (setq i (sslength ss))
            (setq l (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) l))
        )
    )
)

;align the ucs according to the selected object
(defun ucsobj ( obj / insertion rotation adoc regUCS)
;(setq obj (vlax-ename->vla-object (car (entsel))))
(setq insertion (vlax-get obj 'InsertionPoint)
      rotation (vlax-get obj 'Rotation)
      adoc (vla-get-activedocument (vlax-get-acad-object))
      regUCS (vla-add
	       (vla-get-usercoordinateSystems adoc)
               (vlax-3D-point '(0 0 0))
               (vlax-3D-point (list (cos rotation) (sin rotation) 0))
               (vlax-3d-point (list (* -1 (sin rotation)) (cos rotation) 0))
               "ucs_obj")
      )
  (vla-put-origin regUCS (vlax-3d-point insertion 0 1))
  (vla-put-activeUCS adoc regUCS)
  )

[Psyakrev]

Нужно переводить одну систему координат в другу функцией trans.

[Browning Zed]

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

Код:

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

 (defun C:LayerOnOff ( / layers layer ss )

  (setq layers '("L1" "L2" "L3" "L4"))

  (initget 1 "L1 L2 L3 L4")
  (setq layer (getkword "\nChoose Target Layer [L1/L2/L3/L4] : "))

  (setq layer (car (member layer layers)))

    (progn
       (command "_-LAYER" "_ON" layer "")
       (princ " Слой ") (Princ layer) (princ " включен.")
    ) ; progn

    (progn
       (if (or (= (getvar "CLAYER") L1)
                 (= (getvar "CLAYER") L2)
                 (= (getvar "CLAYER") L3)
                 (= (getvar "CLAYER") L4))
             (command "_-LAYER" "_off" layer "_y" "")
             (command "_-LAYER" "_off" layer "")
       ) ; if
    (princ " Слой ") (Princ layer) (princ " выключен.")
    ) ; progn
) ; if
(princ)
)

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

У тебя полная путаница с if и progn

[Red Nova]

Psyakrev, Спасибо, попробую

[VVA]

Browning Zed, А как ты узнаешь, отключен слой или включен?
Пробуй так

Код:

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

 (defun C:LayerOnOff ( / layers layer ss )
  (initget 1 "L1 L2 L3 L4")
  (setq layer (getkword "\nChoose Target Layer [L1/L2/L3/L4] : "))
   (mip-layer-onoff (list layer) 2 nil)
(princ)
)

(defun mip-layer-onoff ( laylist what mask  / lay lays)
  ;;; (mip-layer-onoff '("Сло") 0 t)
  ;;; (mip-layer-onoff '("Слой1") 0 nil)
  ;;; laylist - список слоев (вернее масок) '("Слой" "АД")
  ;;; what - 0 - откл 1 - вкл 2 - инверсия
  ;;; mask - t - маска nil - полное совпадение
  (setq lays (mapcar 'strcase (TABLELIST "layer")))
  (foreach item (mapcar 'strcase  laylist)
    (foreach item1 (vl-remove-if-not '(lambda(x)(wcmatch (strcase x)(strcat (if mask "*" "")(strcase item)(if mask "*" "")))) lays)
      (vla-put-LayerOn (setq lay (vla-item (vla-get-Layers (vla-get-ActiveDocument (vlax-get-acad-object))) item1))
        (cond ((= what 0) :vlax-false)
              ((= what 2) (if (eq (vla-get-layeron lay) :vlax-false) :vlax-true :vlax-false))
              (t :vlax-true) ;_what=1
              )
        )
      )
  )
  )

[Browning Zed]

А как ты узнаешь, отключен слой или включен?

Я имею весьма туманное представление о языке lisp. Просто попытался скомбинировать две программки, найденные в сети, надеясь на русское "авось и прокатит". Не прокатило.

Пробуй так

К сожалению, тоже не работает. На слое L1 находятся объекты. Запускаю программу. Запрос: "Choose Target Layer", выбираю L1 - слой не включается и не отключается.

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

Код:

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

 (vl-load-com)

(defun c:layeronoff (/ adoc layers layer ss)
  (if (= (type
           (setq layer (vl-catch-all-apply
                         (function
                           (lambda () (initget 1 "L1 L2 L3 L4") (getkword "\nChoose Target Layer [L1/L2/L3/L4] <Cancel> : "))
                           ) ;_ end of function
                         ) ;_ end of vl-catch-all-apply
                 ) ;_ end of setq
           ) ;_ end of type
         'str
         ) ;_ end of =
    (progn (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
           (if (= (type
                    (setq layer (vl-catch-all-apply (function (lambda () (vla-item (vla-get-layers adoc) layer)))))
                    ) ;_ end of type
                  'vla-object
                  ) ;_ end of =
             (vla-put-layeron layer
                              (if (equal (vla-get-layeron layer) :vlax-true)
                                :vlax-false
                                :vlax-true
                                ) ;_ end of if
                              ) ;_ end of vla-put-layeron
             ) ;_ end of if
           (vla-endundomark adoc)
           ) ;_ end of progn
    ) ;_ end of if
  (princ)
  ) ;_ end of defun

[Browning Zed]

Кулик Алексей aka kpblc, спасибо, друг. Выручил! Не подскажешь ещё вариант данного лиспа кода слой надо не включить/выключить, а заморозить/разморозить?

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

Изучай объектную модель. И учти, что заморозить / разморозить активный слой невозможно. Понадобятся дополнительные проверки.

[Inferi]

Доброго времени суток, подскажите возможно ли обратиться к командной строке windows из под лиспа напрямую? На ум приходит запускать батник из лиспа, результат сохранять скажем в блокнот, а оттуда считывать данные. Всего то нужна одна строчка "WHOAMI /FQDN"

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

А чем не нравится нечто типа (getenv "userdomain")?

[Inferi]

Спасибо, в моем случае это решает вопрос.

[Alexll]

Здравствуйте. Пытаюсь распечатать лист через команду PLOT

Код:

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

 (command "_-PLOT" "Да" "Модель" "DWG To PDF.pc3" p "Миллиметры" "Альбомная" "Нет" "Рамка" )

Дальше надо ввести координаты, а этого я осилить не смог. Координаты сохранены в переменных x1,y1,x2,y2. Пробовал подставлять и просто переменные, и округлять, и через запятую, и через точку с запятой, и объединять в точечную пару. Максимум что получалось, это в качестве первой точки берет x1(а нужно x1,y1).
Даже пробовал преобразовать в строку, что бы получилось х1,y1, но ему тип переменной не понравился.
Кто подскажет как правильно ввести координаты точек?

[VVA]

Сообщение от Alexll Кто подскажет как правильно ввести координаты точек?

http://aco.ifmo.ru/~nadinet/html/lectures/lect_7.html и в этой теме почитай с поста #127

Сообщение от Alexll и объединять в точечную пару.

Можно поинтересоваться как?

[Alexll]

Спасибо, разобрался. Координаты нужно в список объединить функцией list.

Можно поинтересоваться как?

Объединял функцией cons

Код:

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

 (cons x1 y1)

[skkkk]

Кто-нибудь знает, почему в AutoCAD 2011 функции, загруженные пользователем из LISP-файла определяются системой как SUBR, хотя в документации четко обозначено, что должны бы быть USUBR?
Простейший пример (прошу проверить возвращаемое значение, у кого есть возможность):

Код:

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

(defun C:TEST () (type C:TEST))(C:TEST)

Дело в том, что мне нужно получить список именно загруженных пользователем LISP-функций, выполняю

Код:

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

 
(setq global-var-LISTofSYM (atoms-family 0))
(setq LISTofFUNC
  (vl-remove-if-not
    '(lambda (x) (= (type (eval x)) 'USUBR))
     global-var-LISTofSYM
  )
)

- и в свете вышенаписанного мне возвращается nil, что в общем-то ожидаемо. Может, есть какая-то переменная, которая разделяет и объединяет SUBR и USUBR? Или есть еще какой-то вариант получить искомый список?

[VVA]

Вот лог командной строки Автокада

Команда: (defun C:TEST () (type C:TEST))(C:TEST) SUBR Команда: Команда: (defun TEST () (type TEST))(TEST) SUBR

Вот тот же лог из окна консоли VLISP

_$ (defun C:TEST () (type C:TEST))(C:TEST) C:TEST USUBR _$ (defun TEST () (type TEST))(TEST) TEST USUBR _$

Вот что я нашел в хелпе

The USUBR data type represents functions that can be debugged with the Visual LISP debugging tools (for example, you can set breakpoints and view the values of program variables).

[Red Nova]

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

[skkkk]

Всех студентов и преподавателей с праздниками!
Привет, Red Nova! Неужто вы там уже работаете во всю?
Насчет трезвых очень не уверен, но на безтрезвье и я трезвый

Сообщение от Red Nova Ищу возможность вставить блок командой с указанием двух точек, но при этом хочу чтобы после указания первой точки блок "висел на курсоре"

Давно еще искал возможность подобной интерактивной вставки, в том числе, мультивыноски. В итоге практически вся задача сводилась к тому, чтобы просто программно "схватить за ручку". Такой возможности в лиспе я не нашел. И в общем случае подобное на лиспе нереализуемо, разве что при помощи отрисовки временных примитивов функцией grvecs. Но это тот еще "маршрут"...
Думаю, тебе надо копать в сторону чего-то посерьезней, например, технологии JIG, через .NET.
Но в частном случае с твоим "подопытным" все не так плохо: выставляешь программно PLINEWID в нужное значение, а затем инициируешь отрисовку полилинии, программно задав первую точку и интерактивно запросив вторую, берешь длину созданной полилинии и назначаешь ее блоку, разумеется, в конце полилинию удаляешь. Если важен цвет такой отрисовки, то он хранится в настройках во второй вкладке под кнопкой "Цвета". В свое время пытался изменять его программно лиспом (здесь) - у меня не получилось.

VVA, да, я нашел то же самое, но в решении моего вопроса это совсем не помогло. Видимо, единственным вариантом остается исключать все автолисп-, vla-, acet- и т.д. функции, и выдавать все, что осталось. Не сказать, что задача неподъемная, но думал, что можно это решить правильней.

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

Получить точку ввода через grread в принципе не проблема, но возникнут вопросы при обработке привязок. Насколько я помню, на theswamp.org было решение от Евгения Елпанова.

[skkkk]

Получить точку ввода - да, но как "взять" за ручку программно (нажать на нее)? Или о чем ты, Алексей?

[Red Nova]

Спасибо за советы

skkkk

Неужто вы там уже работаете во всю?

У нас праздники между их Рождеством и вторым числом. Это конечно не то же что может позволить себе "Россия - щедрая душа", но и на том рады.

а затем инициируешь отрисовку полилинии

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

Кулик Алексей aka kpblc
По моему я нашел тему Елпанова что ты описывал, вот она
https://www.theswamp.org/index.php?topic=12813.0
Просмотрел бегло, но пока не нашел как grread может ухватить за "grip" динамического блока.

Добавил.
Скорее всего бред, но пришла такая мысль. Возможно ли программно как бы кликнуть в указанную координату? Тогда можно было бы вставить дин. блок а затем задать клик туда где у него "грип". ???

[skkkk]

Сообщение от Red Nova Скорее всего бред, но пришла такая мысль. Возможно ли программно как бы кликнуть в указанную координату? Тогда можно было бы вставить дин. блок а затем задать клик туда где у него "грип". ???

Об этом я и говорил:

Сообщение от skkkk В итоге практически вся задача сводилась к тому, чтобы просто программно "схватить за ручку". Такой возможности в лиспе я не нашел.

Сообщение от skkkk Получить точку ввода - да, но как "взять" за ручку программно (нажать на нее)?

Это было бы проще всего. Может, надо еще покопать в сторону запуска стороннего приложения (как вариант - exe-файл или скрипт для AutoHotKey), которое запустится из лиспа в нужный момент и нажмет левую кнопку мыши? Но тут придется мудрить с тем, чтобы переводить точку из системы координат модели (или листа) в систему координат экрана. И тут все будет отличаться от монитора к монитору, зависеть от разрешения и Бог весть от чего еще. Помню, видел такую программу от Do$'а, но что-то так я и не смог понять всех закономерностей и допилить под это - тогда знаний явно не хватало.
Тут опять же предварительно возникнет вопрос: как программно перенести курсор в нужную точку? Лиспом мне это тоже в свое время не удалось (и тут на форуме обсуждалось). Знаю только, что можно зумировать (или панорамировать?) экран под текущее положение курсора, вычислив его с помощью функции grread. Но это все уже начинает выглядеть, как танцы на костылях, но без бубна, потому что руки уже заняты.

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

Когда-то на autolisp.ru я пытался рассмотреть вариант "динамического" изменения примитивов. Почему не применить подобный подход здесь же - не понимаю...

[Red Nova]

Сообщение от Кулик Алексей aka kpblc Когда-то на autolisp.ru я пытался рассмотреть вариант "динамического" изменения примитивов. Почему не применить подобный подход здесь же - не понимаю...

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

Код:

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

 (defun C:BPM_ApplyIT ( / *error* blk dwg obj pt1 pt2 val var oldLayer oldcolor
		   blkselection vlablkselection
		   CSblkobj CSblkvar CSblksa CSblkXY
		   CSrot CSlength CSWidth CSExtension1 CSflip ucschanged YMoveVal)

  (defun *error* ( msg )
    (if ucschanged (command-s "_.ucs" "_prev"))
    (mapcar 'setvar var val)
    (setvar "clayer" oldLayer)
    (setvar "cecolor" oldcolor)
    (if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
                 (princ (strcat "\nError: " msg))
      )
    (princ)
    )

  (vl-load-com)

  (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object)))) ;_ end of vla-startundomark

  (setq blk  "BMP Plan IT"
        var '(cmdecho attreq)
        val  (mapcar 'getvar var)
	oldLayer (getvar "clayer")
	oldcolor (getvar "cecolor") 
    )
  
  (mapcar 'setvar var '(0 0))
  
  (command "clayer" "BMP-Plan Profile")
  (command "cecolor" "20")

  (setq blkselection (ssget '((0 . "INSERT")(66 . 1))))
  (setq vlablkselection (LM:ss->vla blkselection))
  (setq vlablkselection (vl-remove-if-not (function (lambda (n) (wcmatch (LM:getvisibilitystate n) "Cut*"))) vlablkselection))
  (setq blkselection (Conv_ObjectList_To_Pickset vlablkselection))
  (setq vlablkselection (LM:ss->vla blkselection))

  (foreach n vlablkselection
    (progn
  
  
  (setq CSrot (vlax-get-property n 'Rotation))
  ;(setq CSPositionX (rtos (car CSInsertionpoint)))

  (setq CSblkvar (vla-get-insertionpoint n)
	CSblksa (vlax-variant-value CSblkvar)
	CSblkXY (vlax-safearray->list CSblksa)
	)
    
  (setq CSlength (LM:getdynpropvalue n "Length"))
  (setq CSWidth (LM:getdynpropvalue n "Cut Width"))
  (setq CSExtension1 (LM:getdynpropvalue n "Extension 1"))
  (setq CSflip (LM:getdynpropvalue n "Slab Flip"))
  (if
    (= CSflip 0)
    (setq YMoveVal CSWidth)
    (setq YMoveVal (* -1 CSWidth))
    )

  ;(command "_.-insert" blk "10,10" 1 0 0)
  (command "_.-insert" blk CSblkXY 1.000001 0 0)
  
  (setq obj (entlast))
  (setq obj (vlax-ename->vla-object obj))
  (= "AcDbBlockReference" (vla-get-objectname obj))
  (= :vlax-true (vla-get-isdynamicblock obj))

  (LM:setdynpropvalue obj "Length" CSlength)
  (LM:setdynpropvalue obj "Angle1" CSrot)
  (LM:SetVisibilityState obj "Short Tag")
  (if
    (= CSflip 0)
    (LM:toggleflipstate obj)
    )

  (ucsobj n); set new UCS
  (setq ucschanged T) ; marker for *error* to reset UCS if routine doesn't get to it
  (command "_.move" "_l" "" "_non" '(0. 0. 0.) "_non" (cons (* -1 CSExtension1) (cons YMoveVal '(0. ))))
  (command "ucs" "P" ""); return previous UCS
  (setq ucschanged nil)

  ));foreach
  
  (vla-endundomark adoc) ;;; undomark bottom mark
  (*error* nil) (princ)
)

[kurstep]

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

[Сергей812]

Сообщение от kurstep Подскажите пожалуйста как программно сделать так чтоб при выборе графического объекта автокада выделялся сразу и зависимый объект (объект этот нужно заранее также программно сделать зависимым назначить зависимым) (команда группа не подходит)

подвеситься на событие изменения выбора. А если будет выделено несколько объектов, а зависимые от них объекты находятся в разных частях чертежа - куда будет "дергаться" ВЭ?) Или отмасштабирует так, что ничего не будет видно толком?

[kurstep]

А как осуществить это подвешивание, можете скинуть ссылку на пример?, Остальные проблемы как-нибудь урегулирую)

[Сергей812]

я на лиспе фактически не пишу, поэтому могу скинуть только пример на Net.

----- добавлено через ~17 мин. -----
Полещук любезно сообщает в своей книге, что это событие SelectionChanged . Ищите в реакторах либо документа, либо редактора скорее всего.

[VVA]

Сообщение от kurstep А как осуществить это подвешивание, можете скинуть ссылку на пример?, Остальные проблемы как-нибудь урегулирую)

http://forum.dwg.ru/showthread.php?p=805477#post805477

Тема в FАQ Реакторы - что это такое?

----- добавлено через ~2 мин. -----
Пример
http://lee-mac.com/dtcurve.html

[kurstep]

Сообщение от VVA VVA

Спасибо, но мне нужно чтоб зависимый объект не перемещался за основным, а именно выделялся - т.е событие Selection Change - проблема в том, что ни в справочниках, ни у Полещука не могу найти реактор для этого события, А может ли быть такое что на Autolisp его нет, и надо программировать именно на VBA?

[skkkk]

Сообщение от kurstep Подскажите пожалуйста как программно сделать так чтоб при выборе графического объекта автокада выделялся сразу и зависимый объект (эти два объекта нужно заранее также программно сделать зависимыми ) (команда группа не подходит так как хочется сохранить ручки редактирования объектов)

А может, группа подойдет, если сделать GROUPDISPLAYMODE -> 0?

[kurstep]

Сообщение от skkkk skkkk

О!! Спасибо, то что надо -выделяются объекты группы и ручки остаются, спасибо, все легче чем я думал)
Но если кто-нибудь все-таки подскажет как решить проблему с помощью реактора буду рад

[skkkk]

1. Выделяем нужные объекты, вызываем команду (функцию), которую предварительно следует написать. Она создаст в чертеже информацию о том, какие элементы входят в нашу импровизированную группу. Каждый раз при ее вызове будет создавать новую запись. Где? Надо выбрать: пользовательские словари чертежа (ldata), пользовательские свойства документа... может еще варианты придумаются на второй взгляд. Если нужно в пределах сеанса, то просто запоминаем каждый набор в глобальной переменной.
2. Создаем реактор "прочих" событий (miscellaneous reactor) на событие pickfirstModified (предварительный набор объектов изменен):

Код:

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

 (vlr-miscellaneous-reactor 
	nil
	(list '(:VLR-pickfirstModified . pickfirstModified))
)

3. Создаем функцию, действия на событие, примерно так, не вникая в детали:

Код:

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

 (defun pickfirstModified (reac data / ss)
	(if ;;; если
		(and 
			(setq ss (cadr (ssgetfirst))) ;;; есть предварительный набор объектов
			(= (sslength ss) 1) ;;; и их количество равно 1
			;;; тут прописываем условие принадлежности 
			;;; выбранного объекта нашей импровизированной группе
		)
		(progn ;;; если условия в (and) выполняются,
			(setq ss ............) ;;; создаем набор объектов, входящих в "группу"
			(sssetfirst nil ss)   ;;; подсвечиваем его ручками
		)
	)
)

[frostmourn]

Сообщение от Red Nova Имею динамический блок, у него есть полярный параметр. Ищу возможность вставить блок командой с указанием двух точек, но при этом хочу чтобы после указания первой точки блок "висел на курсоре" По аналогии с прорисовкой обычной линии, после указания первой точки линия следует за курсором. Подопытный прикреплен.

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

[Red Nova]

frostmourn
Спасибо за помощь! Огорчает что osnap тут неполноценный и не реагирует на все привязки. Еще нет поддержки ortho / polar. А без этого теряется смысл использовать такую команду. Поняв что grread изначально не работает с привязкой я и подался в общий раздел .

[frostmourn]

Сообщение от Red Nova osnap тут неполноценный и не реагирует на все привязки.

Что есть, то есть.

Сообщение от Red Nova Еще нет поддержки ortho / polar.

Это несложно добавить.

[George_D]

Добрый день, подскажите пожалуйста, в какую кодировку преобразует строки функция vl-string->list ? ANCII? Наверно в какую то региональную версию ANCII, но какую?

[Shumak]

Здравствуйте! Имеется макрос ^C^C(SetQ Cl (Getvar "Clayer"));-Layer;Set;arrow;^C_QLEADER;\\\^C(Setvar "Clayer" Cl) (создает пустую выноску в нужном слое, и возвращает предыдущий активный слой)
Очень хотелось бы создать лисп его заменяющий.
Сначала, вдохновившись темой http://forum.dwg.ru/showthread.php?t=136285 пыталась использовать (command "_.QLEADER") в лиспе, но не разобралась как остановить выполнение qleader после задания 3х точек, чтобы он не запрашивал текст, его высоту.
Теперь обдумываю возможность создания нового примитива через entmake, c запросом точек, и извлечением текущего разм. стиля.
Буду благодарна если кто-то вразумит новичка в lisp

[Red Nova]

Как проверить имеет ли REAL число только нули после запятой? То есть может ли оно быть превращено в INTEGER и не потерять своего точного значения?
Пример
REAL 4.000 точно равно INTEGER 4
REAL 4.010 не равно INTEGER 4

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

Red Nova, ты путаешься в показаниях типах значений. int не может быть 4.01

[Red Nova]

kpblc, Верно, я имел ввиду с точностью до наоборот. Поправил. Глянь снова вопрос плиз.
Вопрос возник когда я делил два числа друг на друга и после должен был определить имеет ли результат остаток или нет. Пока что не сумел...
То есть
95.000/24.000 = 3.958 - есть остаток
96.000/24.000 = 4.000 - нет остатка

[skkkk]

Red Nova, на вскидку - то, что первым пришло в голову: выставляешь DIMZIN в 8, а затем "щупаешь" число функцией rtos (кажется, максимальное количество знаков после запятой, поддерживаемое AutoCAD'ом - 16). При таком раскладе все незначимые нули убираются и возвращается строка. Если в этой строке есть точка, значит число было нецелым.
Либо equal с нужным допуском.

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

Red Nova, а чем теме rem не нравится?

[Сергей812]

Глянул ради интереса у Полещука - он пишет "Символ языка LISP может менять в ходе своей программы тип своего значения". А при какой абсолютной величине дробной части числа оно перестает считаться вещественным? Наверняка заложена какая то константа в самом языке.

[Red Nova]

skkkk,
Сперва я тыкал DIMZIN и rtos, но что-то наверное делал не так раз не получалось.

kpblc
А как тут rem может помочь?

В итоге сделал так:

Код:

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

     (or
      (= testInteger (LM:rounddown testInteger 1))
      (= testInteger (LM:roundup testInteger 1))
      )

    ;; Round Up  -  Lee Mac
    ;; Rounds 'n' up to the nearest 'm'
     
    (defun LM:roundup ( n m )
        (cond
            ((equal 0.0 (rem n m) 1e-8) n)
            ((< n 0) (- n (rem n m)))
            ((+ n (- m (rem n m))))
        )
    )
     
    ;; Round Down  -  Lee Mac
    ;; Rounds 'n' down to the nearest 'm'
     
    (defun LM:rounddown ( n m )
        (cond
            ((equal 0.0 (rem n m) 1e-8) n)
            ((< n 0) (- n (rem n m) m))
            ((- n (rem n m)))
        )
    )

[skkkk]

Я тут тоже глянул...

Команда: (rtos 4.00001 2 16) "4.000009999999999"

А потом еще глянул...

Команда: (rtos 4.000001 2 16) "4.000001"

То есть, до пяти знаков после запятой и после пяти знаков - результат разный (DIMZIN = 8). Почему бы?

----- добавлено через ~8 мин. -----

Сообщение от Red Nova А как тут rem может помочь?

Сообщение от Red Nova ((equal 0.0 (rem n m) 1e-8) n) ((< n 0) (- n (rem n m) m)) ((- n (rem n m)))

Все еще не понимаешь, как?

Сообщение от Red Nova Сперва я тыкал DIMZIN и rtos, но что-то наверное делал не так раз не получалось.

Смотря, что делал. Я бы пояснил подробнее, но потыкав сам в этот ртос, увидел, что он неожидаемые какие-то результаты выдает, поэтому не буду.
Ну получилось то, чего хотел? Я просто изначально не вполне понял практической сути вопроса.

[Red Nova]

Сообщение от Red Nova Посмотреть сообщение ((equal 0.0 (rem n m) 1e-8) n) ((< n 0) (- n (rem n m) m)) ((- n (rem n m))) Все еще не понимаешь, как?

Я и не смотрел как работает функция от LeeMac. А оказывается все тот же rem. Только что еще покопал и таки до меня дошел ее смысл

Ну получилось то, чего хотел? Я просто изначально не вполне понял практической сути вопроса.

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

[Дима_]

Сообщение от Сергей812 Глянул ради интереса у Полещука - он пишет "Символ языка LISP может менять в ходе своей программы тип своего значения". А при какой абсолютной величине дробной части числа оно перестает считаться вещественным? Наверняка заложена какая то константа в самом языке.

Я думаю это примечание надо читать в более глобальном смысле - если более заумными словами - LISP язык с динамической типизацией.

[mkung]

Подскажите, как программно вставить блок "Block1" из файла "C:\Drawings\Drawing.dwg"? Имена известны.
Как проверить наличие блока "Block1" в файле "C:\Drawings\Drawing.dwg"?
Заранее благодарен.

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

Сообщение от mkung как программно вставить блок "Block1" из файла "C:\Drawings\Drawing.dwg"? Имена известны.

Выполнять копирование описания блока из одного документа в другой. См. vla-copyobjects

Сообщение от mkung Как проверить наличие блока "Block1" в файле "C:\Drawings\Drawing.dwg"?

Открыть файл, пройтись по коллекции блоков. Один из вариантов решения - ObjectDBX

[skkkk]

Сообщение от mkung Подскажите, как программно вставить блок "Block1" из файла "C:\Drawings\Drawing.dwg"? Имена известны.

Нужна функция импорта блока из файла

[VVA]

Сообщение от skkkk Подскажите, как программно вставить блок "Block1" из файла "C:\Drawings\Drawing.dwg"? Имена известны

Добавил в тему ссылку на Steal from Drawing

[mkung]

Всем спасибо! Примеров более чем достаточно.

[skkkk]

VVA, познакомился я как-то с этим "стилом" - выяснил один не очень приятный момент. Пробовал я "выкрасть" из файла типы линий, так он почему-то принимает имена типов линий только "в лоб" - в чистом виде, в кавычках и прямо, только строку - переменную как символ мне ему скормить мне не удалось. Это когда я допиливал программу для копирования объектов из внешней ссылки в файл. Она вылетала при попытке скопировать линию, тип которой не определен в текущем файле. Так и пришлось "красть" все типы линий. Надо будет, кстати, выложить получившееся чудо в соответствующей теме....
Offtop: VVA, кстати, цитата - не моя .

[kurstep]

Подскажите функцию на ЛИСП по сравнению сложных списков (вложенных и не не обязательно цифровых) (например такого типа как на рисунке)

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

А что ты собираешься сравнивать? Если на индентичность - то equal и вперед.

----- добавлено через ~3 мин. -----
Хотя, возможно, удастся обойтись и простым "="

[Сергей812]

а еще есть vl-every, хотя она вложенные списки не обрабатывает, похоже

[kurstep]

Да, спасибо уже разобрался, equal подходит)

[Red Nova]

Подскажите плиз, как разделить selection set на два?
Нужно выбрать один раз рамкой объекты на чертеже, затем из выбранного все блоки собрать в ssetA, а все полилинии в ssetB.
Если сделать по очереди и выбрать два раза то все понятно:

Код:

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

 (setq ssetA (ssget '((0 . "INSERT")(66 . 1))))
(setq ssetB (ssget '((0 . "*POLYLINE"))))

Вот только выбрать нужно один раз, а дальше фильтровать исходный sset.

[skkkk]

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

Код:

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

 (setq ssetA (ssadd) ;;; создаем пустой набор для блоков
	  ssetB (ssadd) ;;; и пустой набор для полилиний
	  sset (ssget)  ;;; запрашиваем у пользователя выбор рамкой 
)
(cond 
  (	sset
	(repeat (setq i (sslength sset)) ;;; повторяем столько раз, сколько объектов в наборе
		(cond 
		  (	(and 
				(wcmatch (cdr (assoc 0 (entget (setq en (ssname sset (setq i (1- i))))))) "INSERT") ;;; если объект - блок
				(= (cdr (assoc 66 (entget en))) 1) ;;; и содержит атрибуты
			)
			(ssadd en ssetA) ;;; добавляем его к набору блоков
			(ssdel en sset)  ;;; и удаляем из общего набора, чтоб в дальнейшем заново весь набор не перебирать
		  )
		) ;;; cond
	) ;;; repeat
	(repeat (setq i (sslength sset)) ;;; аналогично - с полилиниями
		(cond 
		  (	(wcmatch (cdr (assoc 0 (entget (setq en (ssname sset (setq i (1- i))))))) "*POLYLINE")
			(ssadd en ssetB)
			(ssdel en sset)
		  )
		) ;;; cond
	) ;;; repeat
	(princ 
		(strcat
			"\nБлоков с атрибутами: " (itoa (sslength ssetA))
			"\nПолилиний: " (itoa (sslength ssetB))
		)
	)
	(princ)
  )
  (	T
	(princ "\nОбъекты не выбраны")
	(princ)
  )
) ;;; cond

Можно и поизящнее, с использованием lambda и семейства vl-remove-..., предварительно преобразовав набор в список примитивов сторонними функциями (допустим, _dwgru-conv-pickset-to-list). Но мы оставим это более опытным участникам дискуссиии
Полагаю, кто-нибудь решит эту задачку за пару-тройку строк.

[Red Nova]

skkk, Спасибо за столь подробный ответ . Переварил, переосмыслил и вот сделал по своему.

Можно и поизящнее, с использованием lambda и семейства vl-remove-..., предварительно преобразовав набор в список примитивов сторонними функциями (допустим, _dwgru-conv-pickset-to-list). Но мы оставим это более опытным участникам дискуссиии Полагаю, кто-нибудь решит эту задачку за пару-тройку строк.

Ну с лямбдой я помирился )). На самом деле когда я только начинал эту тему я тогда из за нагрузки на работе так и не вник в программирование, но за последние несколько месяцев немного освоился. А вот получать свойства entity применяя assoc пока не приходилось.

Код:

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

   
(defun c:test ( / )
(setq mainselection (ssget)
	blkselection (ssadd)
	Polylines (ssadd))
  (setq mainselection (LM:ss->ent mainselection))

  (foreach n mainselection
    (if
      (and
	(wcmatch (cdr (assoc 0 (entget n))) "INSERT")
	(= (cdr (assoc 66 (entget n))) 1))
      (ssadd n blkselection)
      );if
    );foreach

  (foreach n mainselection
    (if
      (wcmatch (cdr (assoc 0 (entget n))) "*POLYLINE")
      (ssadd n Polylines)
      );if
    );foreach
);defun

(defun LM:ss->ent ( ss / i l )
    (if ss
        (repeat (setq i (sslength ss))
            (setq l (cons (ssname ss (setq i (1- i))) l))
        )
    )
)

[Дима_]

Да уж, ну вот вам тогда "сложный" вариант:

Код:

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

 (vl-load-com)
(defun splitss (ss)
((lambda (ssa ssb lst)
   (mapcar '(lambda (ent)
              ((lambda (tp) (cond ((wcmatch tp "INSERT") (ssadd ent ssa))
                                  ((wcmatch tp "*POLYLINE") (ssadd ent ssb))
                                  (T nil)))
               (cdr (assoc 0 (entget ent))))) lst)
   (list ssa ssb))
 (ssadd) (ssadd)
 (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))))

вызов (splitss (ssget))

[Red Nova]

Дима_ Да уж, это по сложнее будет ))

[roaa]

А как такой вариант

Код:

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

 
(setq ssetA nil
	    ssetB nil
	    ssetA (ssadd) ;;; создаем пустой набор для блоков
	    ssetB (ssadd) ;;; и пустой набор для полилиний
	    sset (ssget)  ;;; запрашиваем у пользователя выбор рамкой 
)
(vl-cmdf "_zoom" "_o" sset "")
(sssetfirst nil sset)
(setq ssetA (ssget '((0 . "INSERT")))) ;;; набор из блоков
(sssetfirst nil sset)
(setq ssetB (ssget '((0 . "*POLYLINE")))) ;;; набор из полилиний
(vl-cmdf "_zoom" "_p" "")

[sdv79]

Дима_, данную структуру кода встречаю не первый раз, но каждый раз возникает вопрос
"((lambda (ssa ssb lst)..." какую функцию можно использовать между первой и второй скобкой в "((lambda...", не понимаю.

[Дима_]

(lambda ...) возвращает функцию, соответственно ((lambda ...) arg...) запускает ее с аргументами arg..., между первой и второй скобкой можно поставить любую функцию которая принимает функцию как аргумент.

[Red Nova]

roaa
Спасибо, Коротко. Но пару вопросов.
1.
В чем смысл зуммировать?:
(vl-cmdf "_zoom" "_o" sset "")
(vl-cmdf "_zoom" "_p" "")
Работает и без этого.
2.
Правильно ли я понял что (sssetfirst nil sset) отключает выбор рамкой и ssget берет предыдущий выбор за основу?

[roaa]

Выбор ssget происходит на видимой части экрана, поэтому зуммируем выбранное (после возвращаем к исходному виду). (sssetfirst nil sset) производит выделение набора sset, а ssget подхватывает... как-то так.
В виде функции:

Код:

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

 ;;; (sssplit (ssget) '((0 . "INSERT")(66 . 1)))
(defun sssplit (sset splitlist) (sssetfirst nil sset)(ssget splitlist))

[Red Nova]

Спасибо. (sssetfirst nil sset) оказалось очень полезна. Вроде как логика ясна.
Но на счет зуммирования не убежден, так как работает и без этого.

[Red Nova]

Всем ку!
Подскажите плиз со следующей задачей.
Требуется запросить ввод у пользователя.
Ввести разрешено либо число/букву (и числа и буквы могут быть и двузначными), либо список из нескольких чисел/букв разделенных запятой и/или пробелом
Затем введенное нужно перевести в список из strings.

Пример 1
Вводим:
F, 1, 2, LW
Получаем:
("F" "1" "2" "LW")

Пример 2
Вводим:
20 a
Получаем:
("20" "a")

Пример 3
Вводим:
R1
Получаем:
("R1")

Могу начать так:
(getstring T "\nyour prompt:")
и получить string типа։
"F, 1, 2, LW"

Как можно дальше раздробить "F, 1, 2, LW" на список?

----- добавлено через ~3 ч. -----
Нашел вариант у Lee Mac-а․ Не совсем то, но подстроиться можно.

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

Ну дык... Либо initget + getkword, либо создавать диалог и выбирать в нем.

[Red Nova]

Спасибо, учту

[roaa]

Сообщение от Red Nova Как можно дальше раздробить "F, 1, 2, LW" на список?

http://forum.dwg.ru/showthread.php?p=911449

[Immortal_6666]

Нашел мастер-класс 2014-ого от А. Кулика. Там есть пример с командой _purge
Вроде идея описанная в статье понятно, но почти сразу начинается головная боль. Во-первых он (приведенные код) не работает (может опечатка в PDF) _o - мне автокад называется неверным ключом...
Во-вторых, не понимаю, зачем вводить другие ключи если мы уже указали _a - т.е удалять все объекты. Вот код чтоб было понятнее.

Не вижу разницы в работе этого (за исключением ошибки с _o)

Код:

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

 (defun c:pua ()
(repeat 3
(command "_.-purge" "_a" "*" "_n")
(command "_.-purge" "_e")
(command "_.-purge" "_z")
(command "_.-purge" "_o")
(command "_.-purge" "_r" "*" "_n")
) ;_ end of repeat
(command "_.audit" "_y")
) ;_ end of defun

и этого:

Код:

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

 
(defun c:pua ()
(repeat 3
(command "_purge" "_a" "*" "_n")
) ;_ end of repeat
(command "_audit" "_y")
) ;_ end of defun

Просьба ничем не кидаться, я совсем новичок в этом и понимаю, что первый вариант "правильнее", т.к. его делал специалист, а второй - я =) И еще вопрос зачем делать "-" и "." в начале. Что делает "-" я понимаю, но не понимаю зачем закладывать это в код - смысл видеть все эти абзацы в кс во время работы лиспа? А вот что точка дает перед именем мне неизвестно.
Готов пойти по всем ссылкам куда пошлете и читать книги =), чем в принципе и занимаюсь в последние дни. Просто такие странности в чужом коде в самом начале пути ставят в тупик, начинает казаться, что вообще ничего не понимаю.

И еще маленькие вопросы, в диалоговом окне purge есть галочка "удалять вложенные объекты" - как ее командно активировать? Я правильно понимаю, что ключи к любой команде можно посмотреть только вызвав ее через - и дальше искать заглавные буквы или есть какие-то "списки"?

[skkkk]

Immortal_6666, почему-то в последнее время нигде не могу найти список английских команд с опциями, раньше точно были они в онлайн-справке к AutoCAD 2010 - теперь там лишь какие-то скудные описания. Поскольку последнее время почти отошел от командных методов, давно не приходилось искать. Если кто ткнет в ссылку, буду признателен.

Скажу точно, что опция "_r" чистит зарегистрированные приложения, которые не чистит опция "_a". Про остальные опции из кода выше сказать не могу, т. к. неясно, какая из букв кажлой опции - заглавная, но видимо, они также не чистятся при выборе "всего". Если скинешь полный список опций этой команды, будет яснее. Черточка означает вызов команды в бездиалоговом режиме (в режиме командной строки), если таковой для команды имеется. Это как раз для программной работы, без чертечки выскочит окно. Точка - это гарантированный вызов родной автокадовской команды, если вдруг она переопределена пользователем на свое усмотрение.

[Immortal_6666]

Сообщение от skkkk Immortal_6666, почему-то в последнее время нигде не могу найти список английских команд с опциями, раньше точно были они в онлайн-справке к AutoCAD 2010 - теперь там лишь какие-то скудные описания. Поскольку последнее время почти отошел от командных методов, давно не приходилось искать. Если кто ткнет в ссылку, буду признателен. Скажу точно, что опция "_r" чистит зарегистрированные приложения, которые не чистит опция "_a". Про остальные опции из кода выше сказать не могу, т. к. неясно, какая из букв кажлой опции - заглавная, но видимо, они также не чистятся при выборе "всего". Если скинешь полный список опций этой команды, будет яснее. Черточка означает вызов команды в бездиалоговом режиме (в режиме командной строки), если таковой для команды имеется. Это как раз для программной работы, без чертечки выскочит окно. Точка - это гарантированный вызов родной автокадовской команды, если вдруг она переопределена пользователем на свое усмотрение.

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

Ключи описаны в файле (он в открытом доступе лежит, думаю, автор не будет против, что я приложу его сюда), данный пример - страницы 5,6.

Главный вопрос, наверное, как догадаться, что purge с ключом "все" чистит на самом деле не все и что нужно вызывать ключи _r и другие?

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

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

[skkkk]

Сообщение от Immortal_6666 А насчет черточки - я понимаю, что она делает, но в коде без нее тоже никаких окон нет

Сообщение от Immortal_6666 не понимаю, зачем ее включили в данный код

Это справедливо не для всех версий и не для всех команд, думаю, поэтому программисты машинально ставят ее.

Сообщение от Immortal_6666 с ней в командной строке выводится целый том войны и мира

Я, например, часто как раз предпочитаю проконтролировать, что удалилось. Например, когда потёр ненужные блоки с чертежа, проверить: а удалились ли они из базы или я стёр не все?

Сообщение от Immortal_6666 как догадаться, что purge с ключом "все" чистит на самом деле не все и нужно вызывать ключи _r и другие?

Проверив, например, что после чистки "всего" зарегистрированные приложения также чистятся. Алексей, видимо, доходил до этого как-то так. Пункт "_O", кстати, - Orphaned data ("осиротевшие" данные) - видимо, уже давно упразднен, по крайней мере, в 2011-м его точно нет (или, может, он предусмотрен только в каких-то вертикалках). Поэтому и выдает ошибку. Там же в файле Алексеем указана рекомендация чистить файл три раза. Это потому, что при удалении, например, блока, в котором находился текстовый объект определенного стиля этот стиль еще использовался, а после удаления - уже нет; повторная очистка стирает его из базы чертежа.

----- добавлено через 56 сек. -----
Вот Алексей уже сам и ответил.

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

Он не упразднен, он появился только в 2015 версии, если не ошибаюсь.
P.S. Вообще говоря, уже достаточно давно предпочитаю обходиться некомандными методами Контроля больше

[skkkk]

Сообщение от Кулик Алексей aka kpblc Он не упразднен, он появился только в 2015 версии, если не ошибаюсь.

То-то я и думаю, вроде что-то новенькое...
Кулик Алексей aka kpblc, это и есть "связанные данные"?
Что за зверь такой, просвети, пожалуйста?

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

http://adn-cis.org/forum/index.php?topic=709.0
http://adn-cis.org/forum/index.php?topic=2617
"Что это такое и откуда берется" - на русском информации мало: https://www.google.ru/webhp?hl=ru&sa...%D0%B2+autocad
По моим ощущениям, это последствия перегона данных из Microstation (кажется) в dwg.

[skkkk]

Спасибо, Алексей, понял. Это DGN. У gomer'a в CleanDWG есть очистка от типов линий DGN. И она отрабатывает в 2011-м с результатом "Стили линий dgn не найдены". А вот опции "_O" в purge нет. Мне пока не приходилось с ними встречаться в чертежах.

[I_g_o_r]

Добрый день!!

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

Код:

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

 
(defun c:q () 
(setq nabor (ssget))

(setq dl (sslength nabor))
(setq i 0)

( While (< i dl)

(setq a (cdr (assoc -1 (entget (ssname nabor i)))))

;(print (entget (ssname nabor i)))
(print a)
(setq a (entnext a)); name insert
(print a)
(setq k (entget a))

			(WHILE a
			(setq k (entget a)); parametrs insert
			(setq a (entnext a))
			(print a)  
			)
(setq i (+ i 1))
)
(alert "Все ок!!")
)

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

Что ты хочешь получить? В каком месте ошибка? Какая ошибка?

[I_g_o_r]

Доброе утро!
Ошибка: неверный тип аргумента: lentityp nil. - выскакивает в 13 ой строке. Код - часть приложения, которое собирает блоки в кучку по списку с графической базы данных - просто убрал все лишнее.
Может что не то у меня с автокадом? На предприятии несколько версий, везде лицензия и везде похожая ситуация периодически возникает. Ошибка выпадает только в последнем созданном в этом чертеже блоке. И, что самое странное, когда просто копируешь этот блок рядышком - все начинает работать.

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

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

[I_g_o_r]

Давай сначала. Допустим, я ищу в блоке определенную надпись. Для того чтобы до нее добраться - я должен проковырять весь блок. Здесь все упростил, чтобы "обкатать" на простом примере. Обычно все работает, но в этом случае код не проходит весь цикл ни разу - вылетает ошибка. Судя по тому что возникают вопросы - у тебя все работает и в конце вылетает окошко "все ок". Стало быть дело либо в моем автокаде, либо в моем компе.

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

Опять путаница между описанием блока и вхождением блока. https://www.google.ru/search?q=%D1%8...fIH8WS6ASpw5Ag

----- добавлено через 13 сек. -----
Хоть статью пиши, ей-богу!

----- добавлено через ~33 мин. -----
В качестве первых набросков: http://autolisp.ru/2017/02/18/blockdef-and-blockref/

[Romazn]

Всем доброго времени суток!
Совсем недавно начал пробовать писать что то в лиспе, поэтому не совсем представляю себе его возможности.
Кто в курсе, скажите, есть ли возможность написать такого типа программу:
Есть огромная база чертежей *.DWG. Каждый чертеж имеет название в формате aaaaaa.bbbbbbb*.dwg
где : аааааа - номер машины
bbbbbbb - номер чертежа
* - любые символы(или их нет)
чертежи разложены по папкам с путем ...\аааааа*\...
где : аааааа - номер машины
* - любые символы.

Есть файл спецификации, в котором, помимо прочего, есть, в виде текста, номера чертежей. Вот так это выглядит:


То есть, например чертеж 543011.2801043(с картинки) будет иметь такой путь: ...\543011*\543011.2801043*.dwg

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

[I_g_o_r]

Доброе утро!

Алексей, спасибо за статью. Постараюсь запомнить. А теперь для "особо одаренных" (для меня). Как мне это поможет с вышеуказанным кодом? Код не работает с последним созданным/скопированным блоком в чертеже. Попробуй прогнать его на блоке который прикреплен - выдает ошибку, но если этот блок скопировать или создать еще один, то на первом блоке все будет работать, а на новом - нет!! Вот, собственно в чем вопрос. Пробовал повторять это на двух разных компах - результат тот же.

[kurstep]

Romazn, мне кажется в вашем случае могут помочь просто гиперcсылки, вроде их можно прикрепить к строке таблицы и добавить нужный файл, Поищите в гугле "гиперссылки автокад"

[George_D]

Добрый день, ищу решение проблемы: есть созданная методом Autolisp таблица в файле dwg, пытаюсь родной командой "-TABLEEXPORT" экспортировать ее в csv. формат , но у некоторых ячеек при экспорте слетает формат ячеек ( вместо текстовый-числовой). Связанно ли это с стилем таблиц Автокада, либо может быть c Excel?

Код:

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

 (setq aas (car(entsel)))
  (command  "_TABLEEXPORT" aas)

[Romazn]

kurstep, Я знаю про гиперссылки. Дело в том, что, как я говорил, архив огромный, отредактировать каждый лист спецификации, вставив гиперссылку, нет ни возможности ни желания. Именно поэтому я и хочу сделать так, что бы программа "анализировала" именно текст и искала файл.

[Сергей812]

Romazn, спецификация в чем хоть? Сделайте нормальное вложение, а не ссылку куда-то на гугл-диск)

Сообщение от Romazn Дело в том, что, как я говорил, архив огромный, отредактировать каждый лист спецификации, вставив гиперссылку, нет ни возможности ни желания. Именно поэтому я и хочу сделать так, что бы программа "анализировала" именно текст и искала файл.

Если хотите какой то реакции на ходу - вешайтесь на реакторы/обработчики событий. Либо парсить текст в спецификациях и при наличии по сгенерированному в процессе парсинга имени файла вставлять гиперссылки. И прогнать архив через эту программу.

[Enik]

Народ, подскажите, а то я уже всю голову сломал. Должна получиться программа, "реставрирующая" взорванную полилинию (ну, или хотя бы её очертания) из отдельных отрезков. Вот код:

Код:

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

 
(setq new_set(ssget))					;создание набора
(setq new_set_qua(sslength new_set))			;количество элементов в наборе

(setq n 0)						;счётчик примитивов в первоначальном наборе
(setq i 0)						;счётчик отрезков в наборе

(setq dots_set (list 0 0 0))				;создание списка точек полилинии

(while (< n new_set_qua)
  (setq name_obj(ssname new_set n))			;извлечение примитива из набора по порядковому номеру
  (setq chars_obj(entget name_obj))			;извлчечение списка характеристик примитива
  (setq type_obj(cdr(assoc 0 chars_obj)))		;извлечение типа примитива из списка
  
  	(if (= type_obj "LINE")
	  (progn
	    (setq dot_start(cdr(assoc 10 chars_obj)))		;извлечение координат первой точки отрезка
	    (setq dot_end(cdr(assoc 11 chars_obj)))		;извлечение координат второй точки отрезка
	    (setq dots_set(list dots_set dot_start dot_end))	;добавляет к списку точек полилинии точки отрезка	
  	    (setq i (+ i 1))
	  )	;конец progn
	)	;конец if
  (setq n (+ n 1))
)		;конец while

(setq dots_set (cdr dots_set))

(apply 'vl-cmdf (append (list "_.PLINE" (car dots_set) "_W" 0 0) (cdr dots_set) '("")))

Проблема в этой строчке:

Код:

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

 (setq dots_set(list dots_set dot_start dot_end))

То есть так оно не работает. И вроде бы даже понятно, почему.

Но как тогда по-другому сформировать циклом список списков с координатами точек полилинии?

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

А почему не использовать append или cons?

[Enik]

Сообщение от Кулик Алексей aka kpblc А почему не использовать append или cons?

У cons функционал в данном случае аналогичен list. Если брать append, то да, список формируется (но не список списков, а обычный линейный). И проблема в том, что _.Pline его как-то по-своему воспринимает и рисует что-то совсем не то. Если же вручную создать список по типу ((1 1 0) (2 2 0) (3 3 0)), то полилиния выстраивается корректно.

Если же, действительно, брать append, то на выходе из цикла будем иметь список вида (1 1 0 2 2 0 3 3 0), из которого нужно будет получить список списков... Тоже та ещё задачка.

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

Код:

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

 
(defun test1 (/ selset)
  (if (setq selset (ssget '((0 . "LINE"))))
    (foreach ent ((lambda (/ tab item)
                    (repeat (setq tab  nil
                                  item (sslength selset)
                                  ) ;_ end setq
                      (setq tab (cons (ssname selset (setq item (1- item))) tab))
                      ) ;_ end of repeat
                    ) ;_ end of lambda
                  )
      (setq ent (entget ent)
            res (cons (cons (cdr (assoc 10 ent)) (list (cdr (assoc 11 ent)))) res)
            ) ;_ end of setq
      ) ;_ end of foreach
    ) ;_ end of if
  res
  ) ;_ end of defun

(defun test2 (/ selset)
  (if (setq selset (ssget '((0 . "LINE"))))
    (apply (function append)
           (mapcar (function (lambda (ent) (setq ent (entget ent)) (list (cdr (assoc 10 ent)) (cdr (assoc 11 ent)))))
                   ((lambda (/ tab item)
                      (repeat (setq tab  nil
                                    item (sslength selset)
                                    ) ;_ end setq
                        (setq tab (cons (ssname selset (setq item (1- item))) tab))
                        ) ;_ end of repeat
                      ) ;_ end of lambda
                    )
                   ) ;_ end of mapcar
           ) ;_ end of apply
    ) ;_ end of if
  ) ;_ end of defun

(defun test3 (/ selset)
  (if (setq selset (ssget '((0 . "*LINE"))))
    (apply (function append)
           (mapcar (function
                     (lambda (ent)
                       (mapcar (function cdr)
                               (vl-remove-if-not (function (lambda (x) (member (car x) '(10 11)))) (entget ent))
                               ) ;_ end of mapcar
                       ) ;_ end of lambda
                     ) ;_ end of function
                   ((lambda (/ tab item)
                      (repeat (setq tab  nil
                                    item (sslength selset)
                                    ) ;_ end setq
                        (setq tab (cons (ssname selset (setq item (1- item))) tab))
                        ) ;_ end of repeat
                      ) ;_ end of lambda
                    )
                   ) ;_ end of mapcar
           ) ;_ end of apply
    ) ;_ end of if
  ) ;_ end of defun

[Enik]

Работает! Спасибо, дружище!! Теперь полилиния рисуется по точкам. Немного причудливо, ну да это ерунда. Сейчас сделаю сортировку - и оно должно залетать.


UPD. Никакая сортировка тут не понадобилась. Я просто поменял местами 10 и 11 dxf код. Со взорванной полилинией работает идеально. Хотя, конечно, из произвольных отрезков линию не соберёт.

Код:

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

 
;;;;
;;;;Реставрация очертания взорванной полилинии из её отрезков
;;;;


;;;;Рисование полилинии
(defun c:PL_RES (/ dots_set)
	(setq dots_set (kpblc_list))
	(apply 'vl-cmdf (append (list "_.PLINE" (car dots_set) "_W" 0 0) (cdr dots_set) '("")))
) ;_ end of defun  


;;;;Получение списка координат начала и конца отрезков
(defun kpblc_list (/ selset)
  (if (setq selset (ssget '((0 . "LINE"))))
    (apply (function append)
           (mapcar (function (lambda (ent) (setq ent (entget ent)) (list (cdr (assoc 11 ent)) (cdr (assoc 10 ent)))))
                   ((lambda (/ tab item)
                      (repeat (setq tab  nil
                                    item (sslength selset)
                                    ) ;_ end setq
                        (setq tab (cons (ssname selset (setq item (1- item))) tab))
                        ) ;_ end of repeat
                      ) ;_ end of lambda
                    )
                   ) ;_ end of mapcar
           ) ;_ end of apply
    ) ;_ end of if
  ) ;_ end of defun

UPD2 Чтобы уменьшить количество вершин, нужно использовать команду ПРОПОЛКА ПОЛИЛИНИИ (встроена в акад). В код её вписывать не стал, потому что допуски у всех могут быть разные. У меня 8 км водопровода нормально собралось с допуском 0,01 (то бишь 1 см). Но это у меня.

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

Есть пара моментов:
1. Насчет "прополки полилинии" не уверен, что она встроена.
2. После получения координат можно (и, скорее всего, нужно) удалять дубликаты
3. Полилинию наверняка проще и быстрее будет создавать через entmake или vla.
4. И, наконец, последнее: грабли, здрасьте!

[Enik]

Сообщение от Кулик Алексей aka kpblc Есть пара моментов: 1. Насчет "прополки полилинии" не уверен, что она встроена. 2. После получения координат можно (и, скорее всего, нужно) удалять дубликаты 3. Полилинию наверняка проще и быстрее будет создавать через entmake или vla. 4. И, наконец, последнее: грабли, здрасьте!

1. Поищу исходный код этой команды. Если найду - вставлю.
2. Тут проблема не только в этом... См. ниже.
3. Мне, чайнику, разницы не видно Может, и проще. Всё равно пока что не умею.
4. Ого, а вот за это спасибо! Добавил включение/отключение привязки в код. Разницы не заметил, правда, ну да пускай будет, раз оно так правильнее.

А теперь о главном. Штирлиц никогда не был так близок к провалу:

В общем, контур-то полилиния отображает верно. Но при попытке манипуляции с ней возникли проблемы. Команда ПОДОБИЕ выдаёт какую-то дикую ... хрень. Стал разбираться. Выяснилось, что в некоторых местах полилиния начерчена взад-назад, как ручкой по одному месту. Скорее всего, до взрыва там была не одна полилиния, а несколько, начерченные одна поверх другой. В общем, буду разбираться.
Планирую сделать следующее:
а) удалить все совпадающие вершины
б) сделать запрос на крайнюю точку будущей линии
в) отсортировать список, чтобы в нём последовательно стояли точки, находящиеся друг от друга на минимальном удалении. Мда... со школы помню: сколько элементов в списке, столько и будет итераций в цикле сортировки. В моём случае - 2500 отрезков, 5000 точек. Что ж, придётся компу повисеть минуту-другую. Друг вариантов пока не вижу.

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

Сообщение от Enik Друг вариантов пока не вижу.

Команда _.pedit и ее опции.

[Red Nova]

Доброго. Непонятка с vla-endundomark vla-startundomark. Вроде в других кодах работает а тут нет. Команда создает по точкам выбранных полилиний блоки. Но при undo удаление созданных блоков происходит по очереди а не гурьбой. Подскажите плиз что не так. Файл примера и используемые функции от ЛиМака во вложении.

Код:

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

 (defun c:BMP_PolylinePT (/ *error* adoc sset ename i j var val PointLst PointLstLength ScaleFactor obj
		pt1 pt2 blkangle blklength obj vlaobj PTtype PTComment alpha flipmarker almostclodedpolylinemarker)

  (defun *error* ( msg )
    ;(if ucschanged (command-s "_.ucs" "_prev"))
    (mapcar 'setvar var val)
    (if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
                 (princ (strcat "\nError: " msg))))

  (vl-load-com)
  (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object)))) ;_ end of vla-startundomark
  
  (setq var '(cmdecho attreq clayer cecolor celtype osmode) 
        val  (mapcar 'getvar var))
  (setvar "celtype" "ByLayer")
  (setvar "cmdecho" 0)
  (setvar "attreq" 0)
  (setvar "OSMODE" 0)
  (command "cecolor" "BYLAYER")
  (command "clayer" "BMP-Plan Profile")
  (if (= (getvar "INSUNITS") 4)
    (setq ScaleFactor 25.4)
    (setq ScaleFactor 1))
  (setq sset (ssget '((0 . "LWPOLYLINE"))))
  (setq PTtype (getstring T "Enter Petimeter Trim Type Number PT-: "))
  (setq PTtype (strcat "PT-" PTtype))
  (setq PTComment (getstring T "Enter Petimeter Trim Comment: "))

  (setq j (sslength sset))
(while
  (>= j 0)
  
  (setq ename (vlax-ename->vla-object (ssname sset (setq j (1- j)))))
  (setq PointLst (vlax-safearray->list
		    (vlax-variant-value
		      (vla-get-coordinates ename))))
  (setq PointLstLength (length PointLst))
  (setq almostclodedpolylinemarker 0)
  (if
    (and
      (= (car PointLst) (nth (- PointLstLength 2) PointLst))
      (= (cadr PointLst) (nth (- PointLstLength 1) PointLst))
      )
    (setq PointLst (reverse (cdr (cdr (reverse PointLst))))
	  almostclodedpolylinemarker 1)
    )
  (setq i 0)

  (if
    (or
      (eq (vla-get-closed ename) :vlax-true)
      (= almostclodedpolylinemarker 1)
      )
    (setq PointLstLength (length PointLst))
    (setq PointLstLength (- (length PointLst) 2))
    );if

;'(0.0 0.0 100.0 0.0 100.0 50.0 0.0 50.0)

  (while (< i PointLstLength)
    (setq pt1 (list (nth i PointLst) (nth (+ i 1) PointLst)))
    (setq pt2
	(if
	   (or
	     (eq (vla-get-closed ename) :vlax-true)
	     (= almostclodedpolylinemarker 1)
	     )
	   (if
	     (= i (- PointLstLength 2))
	     (list (car PointLst) (cadr PointLst))
	     (list (nth (+ i 2) PointLst) (nth (+ i 3) PointLst))
	     )
	  (list (nth (+ i 2) PointLst) (nth (+ i 3) PointLst))
	   )
         );setq
    (setq blklength (distance pt1 pt2))
    (setq blkangle (angle pt1 pt2))
    
    (setq alpha (angle pt1 pt2))
    (setq flipmarker 0)
    (if
      (and (>= alpha (d2r 135)) (<= alpha (d2r 271)))
      (setq flipmarker 1)
      )

    (if
      (= flipmarker 0)
      (command "_.-insert" "BMP Plan PT" pt1 1.000001 0 0)
      (command "_.-insert" "BMP Plan PT" pt2 1.000001 0 0)
      )
    
    (setq obj (entlast))
    (setq vlaobj (vlax-ename->vla-object obj))
    (LM:setdynpropvalue vlaobj "Length" blklength)

    (if
      (= flipmarker 0)
      (LM:setdynpropvalue vlaobj "Angle1" blkangle)
      (progn
	(LM:setdynpropvalue vlaobj "Angle1" (+ blkangle (d2r 180)))
	(LM:toggleflipstate vlaobj))
      )
    
    (if
      (not (wcmatch PTtype "PT-"))
      (LM:vl-setattributevalue vlaobj "TYPE" PTtype)
      )
    (if
      (not (wcmatch PTComment ""))
      (LM:vl-setattributevalue vlaobj "COMMENT" PTComment)
      )
    (cond
      ((and (> blklength (* 60 ScaleFactor)) (< blklength (* 300 ScaleFactor)))
       (LM:SetVisibilityState vlaobj "Short Tag"))
      ((< blklength (* 60 ScaleFactor))
       (LM:SetVisibilityState vlaobj "No Tag"))
      )
    (setq i (+ i 2))
    );while
  
);while
  
  (*error* nil)
  (vla-endundomark adoc) ;;; undomark bottom mark
  (princ)
 )

[skkkk]

Red Nova, это потому что ты ставишь метку отмены после того, как искусственно прерываешь ход выполнения своей программы функцией *error*. Фактически, до строк 124-125 код у тебя не доходит никогда и ни при каких условиях.
Я вижу, ты понимаешь, что искусственный вызов ошибки очень удобен: не нужно два раза повторять одни и те же куски кода для возврата системы в первозданное состояние - она в него вернется и в случае непредвиденной ошибки. Меня этому (в том числе) в свое время научил gomer, подвергнув жесткой критике один из моих кодов, за что ему пребольшое спасибо.
Понимать - понимаешь, а про метку почему-то забыл
Вставь ее в тело *error*.

[Red Nova]

skkkk - Спасибо. Ох и нубас же я

[Enik]

Доброго времени года!

Вот тут нашёл код для сортировки списка точек от LeeMac:

Код:

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

 (defun sort ( lst / _sort a b d e l p )
  (defun _sort ( a b )
    (if a (cons a (_sort (car (setq b (vl-sort b '(lambda ( c d ) (< (distance a c) (distance a d)))))) (cdr b))))
  )
  (setq l (cdr lst)
        d (distance (setq p (car lst)) (car l))
  )
  (while (setq a (car l))
    (foreach b (setq l (cdr l))
      (if (< d (setq e (distance a b))) (setq p a d e))
    )
  )
  (_sort p (vl-remove p lst))
)

При попытке сортировки он выдаёт ошибку:

неверный элемент в списке аргументов: 2.23835e+006

Сам для себя делаю вывод, что программа не переваривает вещественные числа с плавающей точкой.
Как быть? Координаты неизбежно нужно округлять? Или есть ещё варианты? Потому что округлять не хотелось бы. Это как-то... неправильно что-ли.

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

Ты как вызываешь код?

[Enik]

Сообщение от Кулик Алексей aka kpblc Ты как вызываешь код?

Формирование списка и сортировка - через вызов функций

Код:

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

 (setq dots_set (kpblc_list))
(setq dots_set (sortentlist (dots_set)))

У функции сортировки ведь есть параметр, который нужно передать. Или ... ?

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

Что за kpblc_list? Что за sortenlist?
Есть разница между вызовом sort:
(sort '((0. 0. 0.) (10. -10. 0.) (20. 20. 0)))
(sort '(0. 0. 0. 10. -10. 0. 20. 20. 0))
Первый сработает, второй (естественно) выдаст ошибку.

[Enik]

Виноват. Начнём по порядку. Чтобы без всяких яких и с понятными обозначениями функций.

Вот весь код:

Код:

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

 ;;;;
;;;;Реставрация очертания взорванной полилинии из её отрезков
;;;;

;;;;Рисование полилинии
(defun c:PL_RES (/ dots_set)

 	(setq dots_set (kpblc_list))
  	(setq dots_set (sort (dots_set)))

	(disable_enable_osmode)
	
	(apply 'vl-cmdf (append (list "_.PLINE" (car dots_set) "_W" 0 0) (cdr dots_set) '("")))

	(disable_enable_osmode)

) ;_ end of defun  


;;;;Получение списка координат начала и конца отрезков by Kpblc
(defun kpblc_list (/ selset)
  (if (setq selset (ssget '((0 . "LINE"))))
    (apply (function append)
           (mapcar (function (lambda (ent) (setq ent (entget ent)) (list (cdr (assoc 11 ent)) (cdr (assoc 10 ent)))))
                   ((lambda (/ tab item)
                      (repeat (setq tab  nil
                                    item (sslength selset)
                                    ) ;_ end setq
                        (setq tab (cons (ssname selset (setq item (1- item))) tab))
                        ) ;_ end of repeat
                      ) ;_ end of lambda
                    )
                   ) ;_ end of mapcar
           ) ;_ end of apply
    ) ;_ end of if
  ) ;_ end of defun

;;;;Отключение привязки
(defun disable_enable_osmode ()
    (if (< (getvar "osmode") 16384) 
      (setvar "osmode" (+ (getvar "osmode") 16384)) 
      (setvar "osmode" (- (getvar "osmode") 16384))
    )
)

;;;;Сортировка списка координат точек по расстоянию by Lee Mac
 (defun sort ( lst / _sort a b d e l p )
  (defun _sort ( a b )
    (if a (cons a (_sort (car (setq b (vl-sort b '(lambda ( c d ) (< (distance a c) (distance a d)))))) (cdr b))))
  )
  (setq l (cdr lst)
        d (distance (setq p (car lst)) (car l))
  )
  (while (setq a (car l))
    (foreach b (setq l (cdr l))
      (if (< d (setq e (distance a b))) (setq p a d e))
    )
  )
  (_sort p (vl-remove p lst))
)

Если кратко:
Выделяем отрезки (полученный из взорванной полилинии или нескольких, наложенных друг на друга), получаем координаты их начала и конца, загоняем координаты в список вида ((1.002 2.01 0) (4.04 2.07 0) ... ), дальше сортируем координаты точек внутри списка таким образом, чтобы по ним можно было нарисовать полилинию, не пересекающую саму себя. То есть, берётся первая точка - элемент из списка, и среди оставшихся точек-элементов выбирается ближайшая к ней. и т.д. Потом рисуем по этим точкам полилинию.

Но сейчас оно не работает. Функция для сортировки списка координат точек стопорится, когда встречает вещественное число с плавающей точкой.

Материалы взяты отсюда
Формирование списка - http://forum.dwg.ru/showpost.php?p=1...postcount=3269
Сортировка списка - http://www.cadtutor.net/forum/showth...l=1#post417660

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

(setq dots_set (sort (dots_set)))

и

(setq dots_set (sort dots_set))

Разные вещи.

----- добавлено через ~2 мин. -----
И чем тебе так не угодил _.pedit?

[Enik]

Сообщение от Кулик Алексей aka kpblc И чем тебе так не угодил _.pedit?

Просто не разобрался. С этой командой я часто работаю в самом автокаде. И даже не представляю, как на данном примере можно использовать её функционал.

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

Вариант без командных методов:

Код:

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

 (defun test (/ selset pt_lst)
  (if (= (type (setq selset (vl-catch-all-apply (function (lambda () (ssget '((0 . "LINE"))))))))
         'pickset
         ) ;_ end of =
    (progn (foreach pt (apply (function append)
                              (mapcar (function (lambda (x) (setq x (entget x)) (list (cdr (assoc 10 x)) (cdr (assoc 11 x)))))
                                      ((lambda (/ tab item)
                                         (repeat (setq tab  nil
                                                       item (sslength selset)
                                                       ) ;_ end setq
                                           (setq tab (cons (ssname selset (setq item (1- item))) tab))
                                           ) ;_ end of repeat
                                         ) ;_ end of lambda
                                       )
                                      ) ;_ end of mapcar
                              ) ;_ end of apply
             (if (not (member pt pt_lst))
               (setq pt_lst (cons pt pt_lst))
               ) ;_ end of if
             ) ;_ end of foreach
           (entmakex (append (list '(0 . "LWPOLYLINE")
                                   '(100 . "AcDbEntity")
                                   '(100 . "AcDbPolyline")
                                   (cons 90 (length pt_lst))
                                   '(70 . 0)
                                   '(43 . 0.0)
                                   '(38 . 0.0)
                                   '(39 . 0.0)
                                   ) ;_ end of list
                             (mapcar (function (lambda (x) (cons 10 x))) (sort pt_lst))
                             ) ;_ end of append
                     ) ;_ end of entmakex
           ) ;_ end of progn
    ) ;_ end of if
 ;_ end of entmakex
  ) ;_ end of defun

----- добавлено через ~3 мин. -----

Сообщение от Enik Просто не разобрался. С этой командой я часто работаю в самом автокаде. И даже не представляю, как на данном примере можно использовать её функционал.

https://dwg.ru/dnl/607 , команда pl-join. Бери код, смотри.

[Enik]

Сообщение от Кулик Алексей aka kpblc С.-Петербург Сообщений: 34,062 (setq dots_set (sort (dots_set))) и (setq dots_set (sort dots_set)) Разные вещи.

Спасибо! Глупая ошибка Да, теперь всё работает корректно (если обратно поменять местами 10 и 11 dxf коды). Не так уж и много времени занимает программа. У меня 1700 отрезков обработала меньше, чем за минуту.

Теперь попробую добавить указание крайней точки полилинии + прикручу прополку.

----- добавлено через ~1 ч. -----
Ну, в общем, рабочий код получен. Алексею большое спасибо!

Код:

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

 ;;;;
;;;;Реставрация очертания взорванной полилинии из её отрезков
;;;;

;;;;Рисование полилинии
(defun c:PL_RES (/ dots_set)

	(disable_enable_osmode)
  
	(setq dot_start (getpoint "\nУкажите базовую точку : "))
 	(setq dots_set (kpblc_list))
  	(setq dots_set (cons dot_start dots_set))
  	(setq dots_set (sort dots_set))
	(apply 'vl-cmdf (append (list "_.PLINE" (car dots_set) "_W" 0 0) (cdr dots_set) '("")))

	(disable_enable_osmode)

) ;_ end of defun  


;;;;Получение списка координат начала и конца отрезков by Kpblc
(defun kpblc_list (/ selset)
  (if (setq selset (ssget '((0 . "LINE"))))
    (apply (function append)
           (mapcar (function (lambda (ent) (setq ent (entget ent)) (list (cdr (assoc 10 ent)) (cdr (assoc 11 ent)))))
                   ((lambda (/ tab item)
                      (repeat (setq tab  nil
                                    item (sslength selset)
                                    ) ;_ end setq
                        (setq tab (cons (ssname selset (setq item (1- item))) tab))
                        ) ;_ end of repeat
                      ) ;_ end of lambda
                    )
                   ) ;_ end of mapcar
           ) ;_ end of apply
    ) ;_ end of if
  ) ;_ end of defun

;;;;Отключение привязки
(defun disable_enable_osmode ()
    (if (< (getvar "osmode") 16384) 
      (setvar "osmode" (+ (getvar "osmode") 16384)) 
      (setvar "osmode" (- (getvar "osmode") 16384))
    )
)

;;;;Сортировка списка координат точек по расстоянию by Lee Mac
 (defun sort ( lst / _sort a b d e l p )
  (defun _sort ( a b )
    (if a (cons a (_sort (car (setq b (vl-sort b '(lambda ( c d ) (< (distance a c) (distance a d)))))) (cdr b))))
  )
  (setq l (cdr lst)
        d (distance (setq p (car lst)) (car l))
  )
  (while (setq a (car l))
    (foreach b (setq l (cdr l))
      (if (< d (setq e (distance a b))) (setq p a d e))
    )
  )
  (_sort p (vl-remove p lst))
)

Для прополки полилинии проще всего использовать встроенную команду в автокаде или PL-VxRdc из https://dwg.ru/dnl/607 . Не стал эту красоту своими ручонками кромсать. Да и зачем, когда есть корпоративные стандарты двжру?

Дальше буду пробовать использовать различные варианты кода и сравнивать их по быстродействию (в некомпилированном виде).

Ещё буду разбирать по существу отдельные строчки кода. А то порой кажется, что шмель летать не должен так оно в принципе невозможно. А оно работает и плюёт на Enik'а. Наверное, это особенности AutoLisp. Интересный язык, однако.

[Sergey91@06]

Есть необходимость доработать автоматическое заполнение таблицы автокад в виде спецификации. На просторах Рунета нашел отличный код, который позволяет делать спецификацию для выбранных элементов, теперь необходимо, чтобы вместо имени блока в строку наименование, он прописывал название видимости, а в столбцы "наименование" и "гайки" прописывал соответвующие атрибуты, в столбец "длина" прописывал длину если таковая есть. Догадываюсь что сделать это весьма несложно, но в LISP-программировании я нуб. Буду благодарен за любую помощь.
Еще интересует возможность доработки данного LIPS для создания аналогичной таблицы во внешний EXEL-файл.

[Сергей812]

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

[Sergey91@06]

Добрый день, отписался в новой теме, но меня перенаправили сюда:
Есть необходимость доработать автоматическое заполнение таблицы автокад в виде спецификации. На просторах Рунета нашел отличный код, который позволяет делать спецификацию для выбранных элементов, теперь необходимо, чтобы вместо имени блока в строку наименование, он прописывал название видимости, а в столбцы "наименование" и "гайки" прописывал соответствующие атрибуты, в столбец "длина" прописывал длину если таковая есть. Догадываюсь что сделать это весьма несложно, но в LISP-программировании я нуб. Буду благодарен за любую помощь.

P.S. Еще интересует возможность доработки данного LIPS для создания аналогичной таблицы во внешний EXEL-файл. В данный момент LISP код читает только блоки первого уровня, любопытно рассмотреть вариант выгрузки в таблицу блоков вложенных в другие блоки.

Код:

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

(Defun C:specification (/ sel len i spec_list name vla sp title code ed
			id spec_row tmp_row cnt new_row p1 p2 mas rows cols
			spec_table row col x1 y1 x2 y2 spec_number)
  (vl-load-com)
  (setq acad_object (vlax-get-acad-object))
  (setq active_document (vla-get-ActiveDocument acad_object))
  (setq model_space (vla-get-ModelSpace active_document))
  (vla-startundomark active_document)
  
(defun get-all-atts (obj)
    ;;;Use (get-all-atts (car(entsel "\nSelect block:")))
    ;;;Returs list  (("TAG1" . "Value1")("TAG2" . "Value2") ...)
(vl-load-com)
    (if (= (type obj) 'ENAME)
		(setq obj (vlax-ename->vla-object obj)))
  (if (and obj
           (vlax-property-available-p obj 'Hasattributes)
	   (eq :vlax-true (vla-get-HasAttributes obj))
      )
    (vl-catch-all-apply
      (function
	(lambda	()
	  (mapcar (function (lambda (x)
			      (cons (vla-get-TagString x)
				    (vla-get-TextString x)
			      )
			    )
		  )
		  (append (vlax-invoke obj 'Getattributes)
			  (vlax-invoke obj 'Getconstantattributes)
		  )
	  )
	)
      )
    )
  )
)


 ;Âûáèðàåì áëîêè
  (setq sel (ssget '((0 . "INSERT"))))

 ;Êîëè÷åñòâî âûáðàííûõ ýëåìåíòîâ
  (setq len (SSLENGTH sel))
  (setq i 0)

  (setq spec_list nil)
 ;Öèêë îáðàáîòêè âûáðàííûõ îáúåêòîâ
  (while (< i len)
 ;Èìÿ âûáðàííîãî îáúåêòà
    (setq name (ssname sel i))

 ;Ïðåîáðàçóåì â vla-Îáúåêò
    (setq vla (vlax-ename->vla-object name))

    (setq spec_number 0)
    (while (<= spec_number 10)
    
 ;×èòàåì ñâîéñòâî è çàïèñûâàåì â ïåðåìåííûå íàçâàíèå è êîä
    (setq title "")
    (setq code "")
    (setq ed "")
    (setq cnt "1")

    ;Ïîëó÷àåì ñïåöèôèêàöèþ èç áëîêà
    (setq sp (BlockLdata name (strcat "spec" (itoa spec_number))))
(if sp (progn
	 
    (setq tmp (cdr (assoc "code" sp)))
    (setq read_tmp (read tmp))
    (if (= (type read_tmp) 'LIST)
    (foreach n read_tmp (progn (setq code (strcat code (eval n)))))
      (setq code tmp)
    )

    (setq tmp (cdr (assoc "ed" sp)))
    (setq read_tmp (read tmp))
    (if (= (type read_tmp) 'LIST) 
    (foreach n read_tmp (progn (setq ed (strcat ed (eval n)))))
       (setq ed tmp)
    )

    (setq cnt "")
    (setq tmp (cdr (assoc "cnt" sp)))
    (setq read_tmp (read tmp))
    (if (= (type read_tmp) 'LIST)
    (foreach n read_tmp (progn (setq cnt (strcat cnt (eval n)))))
       (setq cnt tmp)
    )

    (setq tmp (cdr (assoc "title" sp)))
    (setq read_tmp (read tmp))
    (if (= (type read_tmp) 'LIST)
    (foreach n read_tmp (progn (setq title (strcat title (eval n)))))
	(setq title tmp)
    )
))
      (if (or sp (= spec_number 0))
	(progn
    ;Åñëè íàçâàíèå ïóñòîå, ïðèñâàèâàåì èìÿ áëîêà
	  (if (not sp)(progn
    (if (or (not title)(= title "")) (setq title (vla-get-effectivename vla)))
    (if (not code) (setq code ""))
    (if (or (not ed)(= ed "")) (setq ed "øò"))
    (if (or (not cnt)(= cnt "")) (setq cnt "1"))
    		       );end progn
	    );end if

	  (if (/= title "")(progn
    (setq id (strcat title "_" code "_" ed))

 	;spec_row ("id áëîêà" ("title" . "Íàçâàíèå") ("code" . "Êîä")("ed" . "øò") 1)
    (setq
      spec_row (cons id
		     (list (cons "title" title) (cons "code" code)(cons "ed" ed) (atof cnt))
	       )
    )

 ;Ñîáèðàåì ñïåöèôèêàöèþ
 ;Ñ÷èòàåì ýëåìåíò óíèêàëüíûì, åñëè ó íåãî óíèêàëåí id, ïîëó÷àåì ñïåöèôèêàöèþ
    (if	(setq tmp_row (assoc id spec_list))
      (progn
	(setq cnt (+ (last tmp_row) (atof cnt)))
	(setq new_row (cons id (list (cons "title" title) (cons "code" code)(cons "ed" ed) cnt)))
	(setq spec_list (subst new_row tmp_row spec_list))
      );end progn
      (setq spec_list (cons spec_row spec_list))
    );end if

    	);end progn
	);endif
    
	);end progn
	);endif
      (setq spec_number (1+ spec_number))
      );end while

    (setq i (1+ i))
  ) ;end while

  (setq spec_list (reverse spec_list))
  (setq spec_len (length spec_list))

  ;Çàïðàøèâàåì òî÷êó äëÿ âñòàâêè òàáëèöû
  (setq p1 (getpoint "Òî÷êà âñòàâêè òàáëèöû\n"))
  (setq p2 (GETCORNER p1 "Øèðèíà òàáëèöû\n"))
  (setq mas (/ (abs (- (car p1)(car p2))) 185))
  (setq x1 (car p1))
  (setq y1 (cadr p1))
  (setq x2 (car p2))
  (setq y2 (cadr p2))

  (setq p1 (list (min x1 x2)(max y1 y2) 0))

  

  ;Ñîçäà¸ì òàáëèöó
  (setq rows 2)
  (setq cols 7)
  (setq spec_table (vla-AddTable 
                    model_space 
                    (vlax-3d-point p1)
                    rows
                    cols 
                    10
                    10))

  ;Íàñòðàèâàåì ðàçìåðû ÿ÷ååê
  (vla-SetColumnWidth spec_table 0 15)
  (vla-SetColumnWidth spec_table 1 60)
  (vla-SetColumnWidth spec_table 2 65)
  (vla-SetColumnWidth spec_table 3 10)
  (vla-SetColumnWidth spec_table 4 15)
  (vla-SetColumnWidth spec_table 5 20)
  (vla-SetColumnWidth spec_table 6 20)
  
  (vla-setText spec_table 0 0 "Ñïåöèôèêàöèÿ ýëåìåíòîâ óçëà")
  (vla-setText spec_table 1 0 "Ïîç.")
  (vla-setText spec_table 1 1 "Îáîçíà÷åíèå")
  (vla-setText spec_table 1 2 "Íàèìåíîâàíèå")
  (vla-setText spec_table 1 3 "Åä.èçì")
  (vla-setText spec_table 1 4 "Êîë-âî.")
  (vla-setText spec_table 1 5 "Äëèíà")
  (vla-setText spec_table 1 6 "ãàéêà")
 

  ;Çàïîëíÿåì òàáëèöó
  (vla-insertrows spec_table 2 10 spec_len)
  (setq row 1)
  (repeat spec_len
    (progn
      (setq tmp (cdr (nth (1- row) spec_list)))
      (setq title (cdr (assoc "title" tmp)))
      (setq code (cdr (assoc "code" tmp)))
      (setq ed (cdr (assoc "ed" tmp)))
      (setq cnt (last tmp))
      
      (vla-setText spec_table (+ row 1) 0 (itoa row))
      (vla-setText spec_table (+ row 1) 1 title)
      (vla-setText spec_table (+ row 1) 2 code)
      (vla-setText spec_table (+ row 1) 3 ed)
      (vla-setText spec_table (+ row 1) 4 (ntos cnt))
      
      (setq row (1+ row))
    )
   )

  ;Øðèôò â ÿ÷åéêàõ
  (setq text_height 3)
  (vla-SetCellTextHeight spec_table 0 0 text_height)
  
  (setq row 1)
  (repeat (1+ spec_len)
    (progn
        (setq col 0)
  	(repeat cols
	  (progn
	    	;Âûñîòà òåêñòà
		(vla-SetCellTextHeight spec_table row col text_height)
		;Âûðàâíèâàíèå òåêñòà
		(cond
		  ((or (= col 0)(= col 2)(= col 3)(= col 4)(= row 1)) (vla-setcellalignment spec_table row col acmiddlecenter))
		  ((or (= col 1)) (vla-setcellalignment spec_table row col acMiddleLeft))
		  (t nil)
		)
	 	(setq col (1+ col))
	  )
	)
      (setq row (1+ row))
     )
   )

  ;Ìàñøòàáèðóåì òàáëèöó
  (vla-ScaleEntity spec_table (vlax-3d-point (car p1) (cadr p1) 0) mas)
  
(vla-endundomark active_document)
);end Defun

(Defun C:setspecification (/ sel)

 ;Âûáèðàåì áëîê
  (setq spec_number "0")
  (setq sel (ssget "_:S" '((0 . "INSERT"))))
  (setSpecificationDialog sel)

);end Defun

(Defun setSpecificationDialog (sel / file handle item name vla tmp
			   sp title code ed cnt dcl_id ddi)

  (vl-load-com)
  (setq acad_object (vlax-get-acad-object))
  (setq active_document (vla-get-ActiveDocument acad_object))
  (setq model_space (vla-get-ModelSpace active_document))
  (vla-startundomark active_document)

  (setq	file   (strcat (vl-string-right-trim
			 "\\"
			 (vla-get-tempfilepath
			   (vla-get-files
			     (vla-get-preferences (vlax-get-acad-object))
			   )
			 )
		       )
		       "\\dlg.dcl"
	       ) ;_ end of strcat
	handle (open file "w")
  ) ;_ end of setq
  (foreach item
	   '("
set_spec : dialog {label = \"Óñòàíîâêà äàííûõ äëÿ ñïåöèôèêàöèè\";

:row{
:column {
:text {label = \"Èìÿ áëîêà: \";
	key = \"block_name\";
	width = \"40\";
	}
}
:column {
:popup_list{label=\"Íîìåð çàïèñè (0-10):\";
            key=\"spec_number\";
            edit_width=5;
            list = \"0\\n1\\n2\\n3\\n4\\n5\\n6\\n7\\n8\\n9\\n10\";
            is_default = true;
	    is_cancel = true;
           }
}
:column {
:button {
	key = \"clear\";
	label = \"Î÷èñòèòü\";
	is_default = true;
	is_cancel = true;
	}
}
}
:edit_box {label = \"Íàçâàíèå\";
           key = \"title\";
           edit_width=60;
           edit_limit = 1000;
          }
:edit_box {label = \"Êîä\";
           key = \"code\";
           edit_width=60;
           edit_limit = 1000;
          }
:edit_box {label = \"Åä.èçì\";
           key = \"ed\";
           edit_width=60;
           edit_limit = 1000;
          }
:edit_box {label = \"Êîë.\";
           key = \"cnt\";
           edit_width=60;
           edit_limit = 1000;
          }   
ok_cancel;
}"	    )
    (write-line item handle)
  ) ;_ end of foreach
  (close handle)

   (setq name (ssname sel 0))

 ;Ïðåîáðàçóåì â vla-Îáúåêò
    (setq vla (vlax-ename->vla-object name))

  ;Íîìåð çàïèñè ïî óìîë÷àíèþ 0
  (if (or (not spec_number)(= spec_number "")) (setq spec_number "0"))
  
  ;×èòàåì ñâîéñòâî è çàïèñûâàåì â ïåðåìåííûå íàçâàíèå è êîä
    (setq sp (BlockLdata name (strcat "spec" spec_number)))

    (setq title (cdr (assoc "title" sp)))
    (setq code (cdr (assoc "code" sp)))
    (setq ed (cdr (assoc "ed" sp)))
    (setq cnt (cdr (assoc "cnt" sp)))
    

  (if (not sp) (setq sp ""))
  (if (not title) (setq title ""))
  (if (not code) (setq code ""))
  (if (not ed) (setq ed ""))
  (if (not cnt) (setq cnt ""))

 

;Çàãðóæàåì äèàëîã
  (setq dcl_id (load_dialog file))
  (if (< dcl_id 0)
    (progn
      (alert "Íå óäàëîñü çàãðóçèòü ôîðìó ïðèëîæåíèÿ")
      (exit)
    )
  )

  (if (not (new_dialog "set_spec" dcl_id))
    (progn
      (alert "Äèàëîãîâîå îêíî íå ìîæåò áûòü çàãðóæåíî!")
      (exit)
    )
  )

  (set_tile "title" title)
  (set_tile "code" code)
  (set_tile "ed" ed)
  (set_tile "cnt" cnt)
  (set_tile "spec_number" spec_number)

  (setq strBlockName (vla-get-effectivename (vlax-ename->vla-object name)))
  (set_tile "block_name" (strcat "Èìÿ áëîêà: " strBlockName))
  

  (action_tile "cancel" "(done_dialog 0)")
  (action_tile "accept" "(setspec name)(done_dialog 1)")
  (action_tile "spec_number" "(setq spec_number (get_tile \"spec_number\"))(done_dialog 2)")
  (action_tile "clear" "(done_dialog 3)")

  
  (setq ddi (start_dialog))
  (unload_dialog dcl_id)
  
  (if (= ddi 0)(princ "\n Îòìåíåíî!\n"))
  (if (= ddi 1)(princ "\n Ñîõðàíåíî!\n"))
  (if (= ddi 2)(setSpecificationDialog sel))
  (if (= ddi 3)(clear name (atoi spec_number)))
(vla-endundomark active_document)
) ;end Defun


(Defun setspec(name / title code ed cnt spec_str)
    (setq title (get_tile "title"))
    (setq code (get_tile "code"))
    (setq ed (get_tile "ed"))
    (setq cnt (get_tile "cnt"))

    (setq spec
   (list
	(cons "title" title)
	(cons "code" code)
	(cons "ed"  ed)
	(cons "cnt" cnt)
    )
   )
  
  (BlockLdataPut name (strcat "spec" spec_number) spec)
  
);end Defun

(Defun ntos (n / typ sl ns is_point i isloop)
(setq typ (type n))
  (cond
	((= typ 'INT) (itoa n))
	((= typ 'STR) (ntos (atof n)))
	((= typ 'REAL) (progn
			(setq ns (rtos n 2 3))
			(setq sl (strlen ns))

			(setq i 1)
			(while (<= i sl)
			  (if (= (substr ns i 1) ".")(setq is_point T));end if
			  (setq i (1+ i))
			  );end while

			
			;Ïîêà ïîñëåäíèé ñèìâîë 0 èëè ".", îáðåçàåì åãî
			(setq isloop T)
			(if is_point
				(while (and isloop (or (= "0" (substr ns sl))(= "." (substr ns sl))))
				    (if (= "." (substr ns sl))(setq isloop nil))
				    (setq ns (substr ns 1 (1- sl))) 
				    (setq sl (strlen ns))
				);end while
			);end if
			
			ns
		        );end progn
	 )
  );end cond
);end Defun

(Defun C:clearSpecification()
  (vl-load-com)
  (setq acad_object (vlax-get-acad-object))
  (setq active_document (vla-get-ActiveDocument acad_object))
  (setq model_space (vla-get-ModelSpace active_document))
  (vla-startundomark active_document)

	;Âûáèðàåì áëîê
  (setq sel (ssget "_:S" '((0 . "INSERT"))))
  (setq name (ssname sel 0))

  (BlockLdataPut name "spec" nil)
  (setq i 0)
  (while (<= i 10)
    (clear name i)
    (setq i (1+ i))
    )
   (princ "\nÑïåöèôèêàöèÿ áëîêà î÷èùåíà!\n")
  (princ)
(vla-endundomark active_document)
);end Defun

(Defun clear(name spec_number)
(BlockLdataPut name (strcat "spec" (itoa spec_number)) nil)
   (princ (strcat "\nÑïåöèôèêàöèÿ ¹" (itoa spec_number) " áëîêà î÷èùåíà!\n"))
  
  (princ)
);end Defun


; Syntax (BlockLdataPut "MyBlockName" "key" "value")
(defun BlockLdataPut (blk_ent key lstLdata / entBlockDefinition objBlockDefinition)
 (and
  (setq strBlockName (vla-get-effectivename (vlax-ename->vla-object blk_ent)))
  (setq entBlockDefinition (tblobjname "block" strBlockName))
  (setq objBlockDefinition (vlax-ename->vla-object entBlockDefinition))
  (vlax-ldata-put objBlockDefinition key lstLdata)
 )
)

; Syntax (BlockLdata "MyBlockName" "key")
(defun BlockLdata (blk_ent key / entBlockDefinition objBlockDefinition)
 (if
  (and
   (setq strBlockName (vla-get-effectivename (vlax-ename->vla-object blk_ent)))
   (setq entBlockDefinition (tblobjname "block" strBlockName))
   (setq objBlockDefinition (vlax-ename->vla-object entBlockDefinition))
  )
  (vlax-ldata-get objBlockDefinition key)
 )
)

 ;; Get Dynamic Block Property Value  -  Lee Mac
;; Returns the value of a Dynamic Block property (if present)
;; blk - [vla] VLA Dynamic Block Reference object
;; prp - [str] Dynamic Block property name (case-insensitive)

(defun LM:getdynpropvalue ( blk prp )
    (setq prp (strcase prp))
    (vl-some '(lambda ( x ) (if (= prp (strcase (vla-get-propertyname x))) (vlax-get x 'value)))
        (vlax-invoke blk 'getdynamicblockproperties)
    )
)

;; Get Dynamic Block Properties  -  Lee Mac
;; Returns an association list of Dynamic Block properties & values.
;; blk - [vla] VLA Dynamic Block Reference object
;; Returns: [lst] Association list of ((<prop> . <value>) ... )

(defun LM:getdynprops ( blk )
    (mapcar '(lambda ( x ) (cons (vla-get-propertyname x) (vlax-get x 'value)))
        (vlax-invoke blk 'getdynamicblockproperties)
    )
)

;; Get Dynamic Block Property Allowed Values  -  Lee Mac
;; Returns the allowed values for a specific Dynamic Block property.
;; blk - [vla] VLA Dynamic Block Reference object
;; prp - [str] Dynamic Block property name (case-insensitive)
;; Returns: [lst] List of allowed values for property, else nil if no restrictions

(defun LM:getdynpropallowedvalues ( blk prp )
    (setq prp (strcase prp))
    (vl-some '(lambda ( x ) (if (= prp (strcase (vla-get-propertyname x))) (vlax-get x 'allowedvalues)))
        (vlax-invoke blk 'getdynamicblockproperties)
    )
)

;; Toggle Dynamic Block Flip State  -  Lee Mac
;; Toggles the Flip parameter if present in a supplied Dynamic Block.
;; blk - [vla] VLA Dynamic Block Reference object
;; Return: [int] New Flip Parameter value

(defun LM:toggleflipstate ( blk )
    (vl-some
       '(lambda ( prp / rtn )
            (if (equal '(0 1) (vlax-get prp 'allowedvalues))
                (progn
                    (vla-put-value prp (vlax-make-variant (setq rtn (- 1 (vlax-get prp 'value))) vlax-vbinteger))
                    rtn
                )
            )
        )
        (vlax-invoke blk 'getdynamicblockproperties)
    )
)


;; Get Visibility Parameter Name  -  Lee Mac
;; Returns the name of the Visibility Parameter of a Dynamic Block (if present)
;; blk - [vla] VLA Dynamic Block Reference object
;; Returns: [str] Name of Visibility Parameter, else nil

(defun LM:getvisibilityparametername ( blk / vis )  
    (if
        (and
            (vlax-property-available-p blk 'effectivename)
            (setq blk
                (vla-item
                    (vla-get-blocks (vla-get-document blk))
                    (vla-get-effectivename blk)
                )
            )
            (= :vlax-true (vla-get-isdynamicblock blk))
            (= :vlax-true (vla-get-hasextensiondictionary blk))
            (setq vis
                (vl-some
                   '(lambda ( pair )
                        (if
                            (and
                                (= 360 (car pair))
                                (= "BLOCKVISIBILITYPARAMETER" (cdr (assoc 0 (entget (cdr pair)))))
                            )
                            (cdr pair)
                        )
                    )
                    (dictsearch
                        (vlax-vla-object->ename (vla-getextensiondictionary blk))
                        "ACAD_ENHANCEDBLOCK"
                    )
                )
            )
        )
        (cdr (assoc 301 (entget vis)))
    )
)





;; Get Dynamic Block Visibility State  -  Lee Mac
;; Returns the value of the Visibility Parameter of a Dynamic Block (if present)
;; blk - [vla] VLA Dynamic Block Reference object
;; Returns: [str] Value of Visibility Parameter, else nil

(defun LM:getvisibilitystate ( blk )
    (LM:getdynpropvalue blk (LM:getvisibilityparametername blk))
)

----- добавлено через ~1 ч. -----

Код:

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

(Defun C:specification (/ sel len i spec_list name vla sp title code ed
			id spec_row tmp_row cnt new_row p1 p2 mas rows cols
			spec_table row col x1 y1 x2 y2 spec_number)
  (vl-load-com)
  (setq acad_object (vlax-get-acad-object))
  (setq active_document (vla-get-ActiveDocument acad_object))
  (setq model_space (vla-get-ModelSpace active_document))
  (vla-startundomark active_document)
  
(defun get-all-atts (obj)
    ;;;Use (get-all-atts (car(entsel "\nSelect block:")))
    ;;;Returs list  (("TAG1" . "Value1")("TAG2" . "Value2") ...)
(vl-load-com)
    (if (= (type obj) 'ENAME)
		(setq obj (vlax-ename->vla-object obj)))
  (if (and obj
           (vlax-property-available-p obj 'Hasattributes)
	   (eq :vlax-true (vla-get-HasAttributes obj))
      )
    (vl-catch-all-apply
      (function
	(lambda	()
	  (mapcar (function (lambda (x)
			      (cons (vla-get-TagString x)
				    (vla-get-TextString x)
			      )
			    )
		  )
		  (append (vlax-invoke obj 'Getattributes)
			  (vlax-invoke obj 'Getconstantattributes)
		  )
	  )
	)
      )
    )
  )
)


 ;Выбираем блоки
  (setq sel (ssget '((0 . "INSERT"))))

 ;Количество выбранных элементов
  (setq len (SSLENGTH sel))
  (setq i 0)

  (setq spec_list nil)
 ;Цикл обработки выбранных объектов
  (while (< i len)
 ;Имя выбранного объекта
    (setq name (ssname sel i))

 ;Преобразуем в vla-Объект
    (setq vla (vlax-ename->vla-object name))

    (setq spec_number 0)
    (while (<= spec_number 10)
    
 ;Читаем свойство и записываем в переменные название и код
    (setq title "")
    (setq code "")
    (setq ed "")
    (setq cnt "1")

    ;Получаем спецификацию из блока
    (setq sp (BlockLdata name (strcat "spec" (itoa spec_number))))
(if sp (progn
	 
    (setq tmp (cdr (assoc "code" sp)))
    (setq read_tmp (read tmp))
    (if (= (type read_tmp) 'LIST)
    (foreach n read_tmp (progn (setq code (strcat code (eval n)))))
      (setq code tmp)
    )

    (setq tmp (cdr (assoc "ed" sp)))
    (setq read_tmp (read tmp))
    (if (= (type read_tmp) 'LIST) 
    (foreach n read_tmp (progn (setq ed (strcat ed (eval n)))))
       (setq ed tmp)
    )

    (setq cnt "")
    (setq tmp (cdr (assoc "cnt" sp)))
    (setq read_tmp (read tmp))
    (if (= (type read_tmp) 'LIST)
    (foreach n read_tmp (progn (setq cnt (strcat cnt (eval n)))))
       (setq cnt tmp)
    )

    (setq tmp (cdr (assoc "title" sp)))
    (setq read_tmp (read tmp))
    (if (= (type read_tmp) 'LIST)
    (foreach n read_tmp (progn (setq title (strcat title (eval n)))))
	(setq title tmp)
    )
))
      (if (or sp (= spec_number 0))
	(progn
    ;Если название пустое, присваиваем имя блока
	  (if (not sp)(progn
    (if (or (not title)(= title "")) (setq title (vla-get-effectivename vla)))
    (if (not code) (setq code ""))
    (if (or (not ed)(= ed "")) (setq ed "шт"))
    (if (or (not cnt)(= cnt "")) (setq cnt "1"))
    		       );end progn
	    );end if

	  (if (/= title "")(progn
    (setq id (strcat title "_" code "_" ed))

 	;spec_row ("id блока" ("title" . "Название") ("code" . "Код")("ed" . "шт") 1)
    (setq
      spec_row (cons id
		     (list (cons "title" title) (cons "code" code)(cons "ed" ed) (atof cnt))
	       )
    )

 ;Собираем спецификацию
 ;Считаем элемент уникальным, если у него уникален id, получаем спецификацию
    (if	(setq tmp_row (assoc id spec_list))
      (progn
	(setq cnt (+ (last tmp_row) (atof cnt)))
	(setq new_row (cons id (list (cons "title" title) (cons "code" code)(cons "ed" ed) cnt)))
	(setq spec_list (subst new_row tmp_row spec_list))
      );end progn
      (setq spec_list (cons spec_row spec_list))
    );end if

    	);end progn
	);endif
    
	);end progn
	);endif
      (setq spec_number (1+ spec_number))
      );end while

    (setq i (1+ i))
  ) ;end while

  (setq spec_list (reverse spec_list))
  (setq spec_len (length spec_list))

  ;Запрашиваем точку для вставки таблицы
  (setq p1 (getpoint "Точка вставки таблицы\n"))
  (setq p2 (GETCORNER p1 "Ширина таблицы\n"))
  (setq mas (/ (abs (- (car p1)(car p2))) 185))
  (setq x1 (car p1))
  (setq y1 (cadr p1))
  (setq x2 (car p2))
  (setq y2 (cadr p2))

  (setq p1 (list (min x1 x2)(max y1 y2) 0))

  

  ;Создаём таблицу
  (setq rows 2)
  (setq cols 7)
  (setq spec_table (vla-AddTable 
                    model_space 
                    (vlax-3d-point p1)
                    rows
                    cols 
                    10
                    10))

  ;Настраиваем размеры ячеек
  (vla-SetColumnWidth spec_table 0 15)
  (vla-SetColumnWidth spec_table 1 60)
  (vla-SetColumnWidth spec_table 2 65)
  (vla-SetColumnWidth spec_table 3 10)
  (vla-SetColumnWidth spec_table 4 15)
  (vla-SetColumnWidth spec_table 5 20)
  (vla-SetColumnWidth spec_table 6 20)
  
  (vla-setText spec_table 0 0 "Спецификация элементов узла")
  (vla-setText spec_table 1 0 "Поз.")
  (vla-setText spec_table 1 1 "Обозначение")
  (vla-setText spec_table 1 2 "Наименование")
  (vla-setText spec_table 1 3 "Ед.изм")
  (vla-setText spec_table 1 4 "Кол-во.")
  (vla-setText spec_table 1 5 "Длина")
  (vla-setText spec_table 1 6 "гайка")
 

  ;Заполняем таблицу
  (vla-insertrows spec_table 2 10 spec_len)
  (setq row 1)
  (repeat spec_len
    (progn
      (setq tmp (cdr (nth (1- row) spec_list)))
      (setq title (cdr (assoc "title" tmp)))
      (setq code (cdr (assoc "code" tmp)))
      (setq ed (cdr (assoc "ed" tmp)))
      (setq cnt (last tmp))
      
      (vla-setText spec_table (+ row 1) 0 (itoa row))
      (vla-setText spec_table (+ row 1) 1 title)
      (vla-setText spec_table (+ row 1) 2 code)
      (vla-setText spec_table (+ row 1) 3 ed)
      (vla-setText spec_table (+ row 1) 4 (ntos cnt))
      
      (setq row (1+ row))
    )
   )

  ;Шрифт в ячейках
  (setq text_height 3)
  (vla-SetCellTextHeight spec_table 0 0 text_height)
  
  (setq row 1)
  (repeat (1+ spec_len)
    (progn
        (setq col 0)
  	(repeat cols
	  (progn
	    	;Высота текста
		(vla-SetCellTextHeight spec_table row col text_height)
		;Выравнивание текста
		(cond
		  ((or (= col 0)(= col 2)(= col 3)(= col 4)(= row 1)) (vla-setcellalignment spec_table row col acmiddlecenter))
		  ((or (= col 1)) (vla-setcellalignment spec_table row col acMiddleLeft))
		  (t nil)
		)
	 	(setq col (1+ col))
	  )
	)
      (setq row (1+ row))
     )
   )

  ;Масштабируем таблицу
  (vla-ScaleEntity spec_table (vlax-3d-point (car p1) (cadr p1) 0) mas)
  
(vla-endundomark active_document)
);end Defun

(Defun C:setspecification (/ sel)

 ;Выбираем блок
  (setq spec_number "0")
  (setq sel (ssget "_:S" '((0 . "INSERT"))))
  (setSpecificationDialog sel)

);end Defun

(Defun setSpecificationDialog (sel / file handle item name vla tmp
			   sp title code ed cnt dcl_id ddi)

  (vl-load-com)
  (setq acad_object (vlax-get-acad-object))
  (setq active_document (vla-get-ActiveDocument acad_object))
  (setq model_space (vla-get-ModelSpace active_document))
  (vla-startundomark active_document)

  (setq	file   (strcat (vl-string-right-trim
			 "\\"
			 (vla-get-tempfilepath
			   (vla-get-files
			     (vla-get-preferences (vlax-get-acad-object))
			   )
			 )
		       )
		       "\\dlg.dcl"
	       ) ;_ end of strcat
	handle (open file "w")
  ) ;_ end of setq
  (foreach item
	   '("
set_spec : dialog {label = \"Установка данных для спецификации\";

:row{
:column {
:text {label = \"Имя блока: \";
	key = \"block_name\";
	width = \"40\";
	}
}
:column {
:popup_list{label=\"Номер записи (0-10):\";
            key=\"spec_number\";
            edit_width=5;
            list = \"0\\n1\\n2\\n3\\n4\\n5\\n6\\n7\\n8\\n9\\n10\";
            is_default = true;
	    is_cancel = true;
           }
}
:column {
:button {
	key = \"clear\";
	label = \"Очистить\";
	is_default = true;
	is_cancel = true;
	}
}
}
:edit_box {label = \"Название\";
           key = \"title\";
           edit_width=60;
           edit_limit = 1000;
          }
:edit_box {label = \"Код\";
           key = \"code\";
           edit_width=60;
           edit_limit = 1000;
          }
:edit_box {label = \"Ед.изм\";
           key = \"ed\";
           edit_width=60;
           edit_limit = 1000;
          }
:edit_box {label = \"Кол.\";
           key = \"cnt\";
           edit_width=60;
           edit_limit = 1000;
          }   
ok_cancel;
}"	    )
    (write-line item handle)
  ) ;_ end of foreach
  (close handle)

   (setq name (ssname sel 0))

 ;Преобразуем в vla-Объект
    (setq vla (vlax-ename->vla-object name))

  ;Номер записи по умолчанию 0
  (if (or (not spec_number)(= spec_number "")) (setq spec_number "0"))
  
  ;Читаем свойство и записываем в переменные название и код
    (setq sp (BlockLdata name (strcat "spec" spec_number)))

    (setq title (cdr (assoc "title" sp)))
    (setq code (cdr (assoc "code" sp)))
    (setq ed (cdr (assoc "ed" sp)))
    (setq cnt (cdr (assoc "cnt" sp)))
    

  (if (not sp) (setq sp ""))
  (if (not title) (setq title ""))
  (if (not code) (setq code ""))
  (if (not ed) (setq ed ""))
  (if (not cnt) (setq cnt ""))

 

;Загружаем диалог
  (setq dcl_id (load_dialog file))
  (if (< dcl_id 0)
    (progn
      (alert "Не удалось загрузить форму приложения")
      (exit)
    )
  )

  (if (not (new_dialog "set_spec" dcl_id))
    (progn
      (alert "Диалоговое окно не может быть загружено!")
      (exit)
    )
  )

  (set_tile "title" title)
  (set_tile "code" code)
  (set_tile "ed" ed)
  (set_tile "cnt" cnt)
  (set_tile "spec_number" spec_number)

  (setq strBlockName (vla-get-effectivename (vlax-ename->vla-object name)))
  (set_tile "block_name" (strcat "Имя блока: " strBlockName))
  

  (action_tile "cancel" "(done_dialog 0)")
  (action_tile "accept" "(setspec name)(done_dialog 1)")
  (action_tile "spec_number" "(setq spec_number (get_tile \"spec_number\"))(done_dialog 2)")
  (action_tile "clear" "(done_dialog 3)")

  
  (setq ddi (start_dialog))
  (unload_dialog dcl_id)
  
  (if (= ddi 0)(princ "\n Отменено!\n"))
  (if (= ddi 1)(princ "\n Сохранено!\n"))
  (if (= ddi 2)(setSpecificationDialog sel))
  (if (= ddi 3)(clear name (atoi spec_number)))
(vla-endundomark active_document)
) ;end Defun


(Defun setspec(name / title code ed cnt spec_str)
    (setq title (get_tile "title"))
    (setq code (get_tile "code"))
    (setq ed (get_tile "ed"))
    (setq cnt (get_tile "cnt"))

    (setq spec
   (list
	(cons "title" title)
	(cons "code" code)
	(cons "ed"  ed)
	(cons "cnt" cnt)
    )
   )
  
  (BlockLdataPut name (strcat "spec" spec_number) spec)
  
);end Defun

(Defun ntos (n / typ sl ns is_point i isloop)
(setq typ (type n))
  (cond
	((= typ 'INT) (itoa n))
	((= typ 'STR) (ntos (atof n)))
	((= typ 'REAL) (progn
			(setq ns (rtos n 2 3))
			(setq sl (strlen ns))

			(setq i 1)
			(while (<= i sl)
			  (if (= (substr ns i 1) ".")(setq is_point T));end if
			  (setq i (1+ i))
			  );end while

			
			;Пока последний символ 0 или ".", обрезаем его
			(setq isloop T)
			(if is_point
				(while (and isloop (or (= "0" (substr ns sl))(= "." (substr ns sl))))
				    (if (= "." (substr ns sl))(setq isloop nil))
				    (setq ns (substr ns 1 (1- sl))) 
				    (setq sl (strlen ns))
				);end while
			);end if
			
			ns
		        );end progn
	 )
  );end cond
);end Defun

(Defun C:clearSpecification()
  (vl-load-com)
  (setq acad_object (vlax-get-acad-object))
  (setq active_document (vla-get-ActiveDocument acad_object))
  (setq model_space (vla-get-ModelSpace active_document))
  (vla-startundomark active_document)

	;Выбираем блок
  (setq sel (ssget "_:S" '((0 . "INSERT"))))
  (setq name (ssname sel 0))

  (BlockLdataPut name "spec" nil)
  (setq i 0)
  (while (<= i 10)
    (clear name i)
    (setq i (1+ i))
    )
   (princ "\nСпецификация блока очищена!\n")
  (princ)
(vla-endundomark active_document)
);end Defun

(Defun clear(name spec_number)
(BlockLdataPut name (strcat "spec" (itoa spec_number)) nil)
   (princ (strcat "\nСпецификация №" (itoa spec_number) " блока очищена!\n"))
  
  (princ)
);end Defun


; Syntax (BlockLdataPut "MyBlockName" "key" "value")
(defun BlockLdataPut (blk_ent key lstLdata / entBlockDefinition objBlockDefinition)
 (and
  (setq strBlockName (vla-get-effectivename (vlax-ename->vla-object blk_ent)))
  (setq entBlockDefinition (tblobjname "block" strBlockName))
  (setq objBlockDefinition (vlax-ename->vla-object entBlockDefinition))
  (vlax-ldata-put objBlockDefinition key lstLdata)
 )
)

; Syntax (BlockLdata "MyBlockName" "key")
(defun BlockLdata (blk_ent key / entBlockDefinition objBlockDefinition)
 (if
  (and
   (setq strBlockName (vla-get-effectivename (vlax-ename->vla-object blk_ent)))
   (setq entBlockDefinition (tblobjname "block" strBlockName))
   (setq objBlockDefinition (vlax-ename->vla-object entBlockDefinition))
  )
  (vlax-ldata-get objBlockDefinition key)
 )
)

 ;; Get Dynamic Block Property Value  -  Lee Mac
;; Returns the value of a Dynamic Block property (if present)
;; blk - [vla] VLA Dynamic Block Reference object
;; prp - [str] Dynamic Block property name (case-insensitive)

(defun LM:getdynpropvalue ( blk prp )
    (setq prp (strcase prp))
    (vl-some '(lambda ( x ) (if (= prp (strcase (vla-get-propertyname x))) (vlax-get x 'value)))
        (vlax-invoke blk 'getdynamicblockproperties)
    )
)

;; Get Dynamic Block Properties  -  Lee Mac
;; Returns an association list of Dynamic Block properties & values.
;; blk - [vla] VLA Dynamic Block Reference object
;; Returns: [lst] Association list of ((<prop> . <value>) ... )

(defun LM:getdynprops ( blk )
    (mapcar '(lambda ( x ) (cons (vla-get-propertyname x) (vlax-get x 'value)))
        (vlax-invoke blk 'getdynamicblockproperties)
    )
)

;; Get Dynamic Block Property Allowed Values  -  Lee Mac
;; Returns the allowed values for a specific Dynamic Block property.
;; blk - [vla] VLA Dynamic Block Reference object
;; prp - [str] Dynamic Block property name (case-insensitive)
;; Returns: [lst] List of allowed values for property, else nil if no restrictions

(defun LM:getdynpropallowedvalues ( blk prp )
    (setq prp (strcase prp))
    (vl-some '(lambda ( x ) (if (= prp (strcase (vla-get-propertyname x))) (vlax-get x 'allowedvalues)))
        (vlax-invoke blk 'getdynamicblockproperties)
    )
)

;; Toggle Dynamic Block Flip State  -  Lee Mac
;; Toggles the Flip parameter if present in a supplied Dynamic Block.
;; blk - [vla] VLA Dynamic Block Reference object
;; Return: [int] New Flip Parameter value

(defun LM:toggleflipstate ( blk )
    (vl-some
       '(lambda ( prp / rtn )
            (if (equal '(0 1) (vlax-get prp 'allowedvalues))
                (progn
                    (vla-put-value prp (vlax-make-variant (setq rtn (- 1 (vlax-get prp 'value))) vlax-vbinteger))
                    rtn
                )
            )
        )
        (vlax-invoke blk 'getdynamicblockproperties)
    )
)


;; Get Visibility Parameter Name  -  Lee Mac
;; Returns the name of the Visibility Parameter of a Dynamic Block (if present)
;; blk - [vla] VLA Dynamic Block Reference object
;; Returns: [str] Name of Visibility Parameter, else nil

(defun LM:getvisibilityparametername ( blk / vis )  
    (if
        (and
            (vlax-property-available-p blk 'effectivename)
            (setq blk
                (vla-item
                    (vla-get-blocks (vla-get-document blk))
                    (vla-get-effectivename blk)
                )
            )
            (= :vlax-true (vla-get-isdynamicblock blk))
            (= :vlax-true (vla-get-hasextensiondictionary blk))
            (setq vis
                (vl-some
                   '(lambda ( pair )
                        (if
                            (and
                                (= 360 (car pair))
                                (= "BLOCKVISIBILITYPARAMETER" (cdr (assoc 0 (entget (cdr pair)))))
                            )
                            (cdr pair)
                        )
                    )
                    (dictsearch
                        (vlax-vla-object->ename (vla-getextensiondictionary blk))
                        "ACAD_ENHANCEDBLOCK"
                    )
                )
            )
        )
        (cdr (assoc 301 (entget vis)))
    )
)





;; Get Dynamic Block Visibility State  -  Lee Mac
;; Returns the value of the Visibility Parameter of a Dynamic Block (if present)
;; blk - [vla] VLA Dynamic Block Reference object
;; Returns: [str] Value of Visibility Parameter, else nil

(defun LM:getvisibilitystate ( blk )
    (LM:getdynpropvalue blk (LM:getvisibilityparametername blk))

[valerik88]

Это же моя программа отсюда, только кем то переделаная
http://forum.dwg.ru/showthread.php?t=132979
Имя блока вставляется только для тех блоков, к которым не была ранее применена функция setspecification
С помощью команды setspecification можно настроить любой блок, что бы он в спецификацию что угодно выдавал.

Можно в строки "Название", "Код", "кол-во" вставлять autolisp код, который будет возвращать нужную информацию. В момент исполнения функции specification этот код из блоков исполнится и вставит в таблицу то что нужно.
Например у меня в блоках вставлены такие строки:

Код:

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

 ("Полка-" (rtos (getpropertyvalue name "AcDbDynBlockPropertylength") 2 0) "-10")

- возвращает значение динамического параметра "length"

Код:

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

 ((LM:getvisibilitystate vla))

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

[Sergey91@06]

valerik88, а можешь расписать что куда именно прописать нужно(хочется самому научится ловить рыбу, т.е. попробовать понять ка как это работает, чтобы если необходимо будет внести какие-то корректировки самому можно было сделать), передо мной стоит задача - сделать чтобы несколько кнопок, которые немного ускорят мою работу:, т.е. хочу добавить потом ещё 2 аналогичные команды, отличатся будут они только определенным атрибутом - в столбце артикул. Но это все лирика, сейчас подробнее по примеру:
Нужно чтобы в столбец "обозначение" прописывалась "видимость" блока, в столбец "артикул" атрибут "_Article_galv", В столбец "длина" соответственно длина блока(если есть), ещё наверное условие какое-то нужно сделать, чтобы отдельно считались и нумеровались одинаковые блоки с разной длиной, также вопросы по lisp-таблице, как шрифт на программном уровне поменять и сделать чтобы длину таблицы не нужно было показывать а только точку вставки, длина автоматически по ГОСТ 1850мм.

[valerik88]

Sergey91@06, Вот сделал для примера 1 блок
Что бы всё понять, примени команду setspecification для блока, увидишь, что каждое поле вычисляется отдельным кодом:
Для наименования - ((LM:getvisibilitystate vla)) вставляет в спецификацию значение видимости блока
для кода - ((getpropertyvalue name "AcDbDynBlockProperty_Article_galv")) - вставляет атрибут _Article_galv
для единиц измерения - ((rtos (getpropertyvalue name "AcDbDynBlockPropertyРасстояние5") 2 0)) - вставляет длину консоли

В твоей программе добавлены столбцы Длина и Гайка, но в программе в них ни чего не заносится, поэтому для примера я вставил в поле Ед.изм. значение длины. Что бы вставлялось в нужное поле, придётся программу дорабатывать, но это время, поэтому я только советом помочь смогу.

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

также вопросы по lisp-таблице, как шрифт на программном уровне поменять

В программе есть строка

Код:

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

;Шрифт в ячейках
(setq text_height 3)

А стиль вроде ставится тот который установлен в данный момент (могу ошибаться)

сделать чтобы длину таблицы не нужно было показывать а только точку вставки, длина автоматически по ГОСТ 1850мм.

Для этого надо убрать строку

Код:

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

;Масштабируем таблицу
(vla-ScaleEntity spec_table (vlax-3d-point (car p1) (cadr p1) 0) mas)

Ну и запрос второй точки не нужен становится

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

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

[aTBepTKa]

*удалить

[Sergey91@06]

valerik88, спасибо огромное за разъяснения. в общем и целом понял как работает данный LISP(т.е. есть несколько переменных которым мы даем соответствующие значения атрибута, после чего выводим в таблицу), программа очень хорошая, но меня как я теперь понял интересуют более простые и приземленные вещи. Например есть у меня база блоков, штук 300, я переименовываю в них атрибуты, чтобы одинаково назывались: _visibility, _lenght, _article_galv и другое. А потом выполняю команду: и как итог имею таблицу, где элементы автоматически нумеруются(притом если у элементов с одинаковыми атрибутами _visibility, _article_galv отличается параметр _lenght, то это должна быть уже другая позиция) и в столбец "наименование" попадает значение атрибута _visibility, "длина"(если есть) - _lenght, _article_galv - "артикул". Насколько я понимаю в таком случае LISP не будет запускать никакие LISP или макросы прописанные в блоки, что является более безопасным. Если встречалось что-то подобное или есть понимание как это реализовать, то буду крайне благодарен

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

Sergey91@06, ты не пробовал attin / attout или его аналог?

[Сергей812]

Сообщение от Sergey91@06 А потом выполняю команду: и как итог имею таблицу, где элементы автоматически нумеруются(притом если у элементов с одинаковыми атрибутами _visibility, _article_galv отличается параметр _lenght, то это должна быть уже другая позиция) и в столбец "наименование" попадает значение атрибута _visibility, "длина"(если есть) - _lenght, _article_galv - "артикул".

Непонятна только автоматическая нумерация (что именно имеет в виду автор), видимости, атрибуты и прочее выводятся стандартным извлечением данных.

[Sergey91@06]

Кулик Алексей aka kpblc, идея близка, но все же не то, т.к. у моих блоков могут быть и 10 атрибутов например, но выгружать на команду он должен только определенные, названия которых я прописываю в коде. И я хочу сделать 2 альтернативные кнопки: а)создает таблицу внутри файла б)создает внешний exel(svc) файл с аналогичной таблицей, таблица должна быть ГОСТовской, т.е. иметь определенные размеры. Сейчас начал курсы LISP изучать, возможно я скоро сам пойму как это сделать, если все получится то поделюсь наработками

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

Ну, в принципе код открыт - отфильтровать атрибуты можно хоть внутри кода, хоть при обработке готового файла, хоть где.
Один маленький, но серьезный момент: потребуются хендлы блоков, чтобы их можно было идентифицировать. А это гарантирует "негостовскость" таблицы.
Можно на сайте Lee Mac посмотреть - кажется, у него там были очень интересные нумераторы.

[Red Nova]

Доброго!
Есть ли у кого опыт по созданию полей со ссылкой на дин блок? (в лиспе естественно)
Научился манипулировать всеми параметрами дин. блока и содержимым атрибутов, но с полями пока не работал.

Собственно задача:
Есть исходный динамический блок с атрибутами. Кроме него есть блок маркер в котором только один атрибут.
Требуется создать в атрибуте блока маркера поля в перемешку с текстом, поля ссылаются на дин. параметры и атрибуты исходного блока.

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

Подскажите в каком направлении копать?
Заранее спасибо.

[Boxa]

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

[Red Nova]

Спасибо. Таким методом работают ссылки на дин. свойства но не на атрибуты.
На основе одного из кодов от VVA настряпал такой вот тестовый код для атрибутов.
Вот только при записи поля в другой атрибут сперва содержание отображается как ####, а корректное поле появляется только после регенерации.
При этом, если записывать поле не в атрибут блока а в текст, то все отображается сразу ОК.
Мне бы очень хотелось не использовать регенерацию, так как файлы тяжелые а операция довольно частая.
Может кто подскажет возможно ли это и как?

Код:

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

 (defun c:testwithblock (/ CSblk vlaCSblk attlst fld TAGblk vlaTAGblk)
  (vl-load-com)
  (setq CSblk (ssget "_:S" '((0 . "INSERT")(66 . 1))))
  (setq vlaCSblk (car (LM:ss->vla CSblk)))
  (setq attlst (get-all-atts vlaCSblk))
  (setq fld (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                                (vl-princ-to-string(Get-ObjectID-x86-x64 (caddr (assoc "BAY" attlst))))
                                ">%).TextString>%"
                                ))
  (setq TAGblk (ssget "_:S" '((0 . "INSERT")(66 . 1))))
  (setq vlaTAGblk (car (LM:ss->vla TAGblk)))
  (LM:vl-setattributevalue vlaTAGblk "LONGTAG" fld)
  )

(defun c:testwithtext (/ CSblk vlaCSblk attlst fld pt)
  (vl-load-com)
  (setq CSblk (ssget "_:S" '((0 . "INSERT")(66 . 1))))
  (setq vlaCSblk (car (LM:ss->vla CSblk)))
  (setq attlst (get-all-atts vlaCSblk))
  (setq fld (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                                (vl-princ-to-string(Get-ObjectID-x86-x64 (caddr (assoc "BAY" attlst))))
                                ">%).TextString>%"
                                ))
  (setq pt (getpoint "\nSpecify First Corner of MText Object: "))
  (command "._MTEXT" pt pause fld "")
  )


(defun Get-ObjectID-x86-x64 (obj / util)
  (setq util (vla-get-Utility (vla-get-activedocument (vlax-get-acad-object))))
  (if (= (type obj) 'ENAME)(setq obj (vlax-ename->vla-object obj)))
  (if (= (type obj) 'VLA-OBJECT)
     (if (> (vl-string-search "x64" (getvar "platform")) 0)
       (vlax-invoke-method util "GetObjectIdString" obj :vlax-False)
       (rtos (vla-get-objectid obj) 2 0)
     )
  )
)

(defun get-all-atts (obj)
  (if (and obj
    (eq :vlax-true (vla-get-HasAttributes obj))
    (vlax-property-available-p obj 'Hasattributes)
    
      )
    (vl-catch-all-apply
      (function
 (lambda ()
   (mapcar (function (lambda (x)
         (list (vla-get-TagString x)
	       (bg:get-TextString (vlax-vla-object->ename x))
                                    x
         )
       )
    )
    (append (vlax-invoke obj 'Getattributes)
     (vlax-invoke obj 'Getconstantattributes)
    )
   )
 )
      )
    )
  )
)

(defun LM:vl-setattributevalue ( blk tag val )
    (setq tag (strcase tag))
    (vl-some
       '(lambda ( att )
            (if (= tag (strcase (vla-get-tagstring att)))
                (progn (vla-put-textstring att val) val)
            )
        )
        (vlax-invoke blk 'getattributes)
    )
)

[Boxa]

Сообщение от Red Nova Таким методом работают ссылки на дин. свойства но не на атрибуты.

И атрибуты тоже. Другое дело, что в строку нужно вставлять не ID блока, а ID самого атрибута, т.к. атрибут самостоятельный объект.
ЗЫ.
И если не сложно, дополните пожалуйста код, до рабочего состояния, не у всех есть набор используемых Вами функций.

[Red Nova]

Сообщение от Boxa И атрибуты тоже. Другое дело, что в строку нужно вставлять не ID блока, а ID самого атрибута, т.к. атрибут самостоятельный объект.

Все верно.
Но проблема с регенерацией у меня осталась...

[Boxa]

Сообщение от Red Nova Но проблема с регенерацией у меня осталась...

_UPDATEFIELD вместо Regen пробовали?

Код:

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

 
;create a selection set of items eg: all items on your prefered layer
(setq #temp (ssget "X" (list (cons 8 "Your_Layer_Name"))))

;then update all items on the layer in selectionset
(command ".updatefield" #temp "")

[Red Nova]

За ".updatefield" спасибо, не знал. Очень полезно. Искал как-то нечто подобное но не нашел...
Про мой блок - дальнейшие тесты показали, что если не редактировать атрибут существующего блока а вводить содержание его при вставке блока , то поле сразу отображается как нужно.

[Red Nova]

Други, у меня баг при использовании vlr-object-reactor для атрибута дин. блока.
Дин. блок имеет линейный параметр ширины рамки, который по задумке реактора изменяется в зависимости от содержания атрибута. То есть каждый раз получаем ширину атрибута через vla-getBoundingBox и соответственно изменяем ширину рамки. Все работает пока не добавить в дин блок flip state. Без реактора флипает нормально, а с реактором атрибут, после флипа, получает при изменении текста непонятное смещение.
Может кто с таким встречался? Вот код и файл примера.

Код:

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

 (defun c:test (/ *error* var val CSblk vlaCSblk tagtext pt TagTextWidth vlaattobj OutsideTagFieldReactor)
  (defun *error* ( msg )
    (mapcar 'setvar var val)
    (if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
                 (princ (strcat "\nError: " msg)))
    (vla-endundomark adoc))
  (vl-load-com)
  (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
  (setq var '(cmdecho attreq attdia) 
        val  (mapcar 'getvar var))
  (setvar "CMDECHO" 0)
  (setvar "ATTREQ" 1)
  (setvar "ATTDIA" 0)
  (setq CSblk (ssget "_:S" '((0 . "INSERT")(66 . 1))))
  (setq vlaCSblk (car (setq vlaCSblk (LM:ss->vla CSblk))))
  (setq tagtext
	 (strcat
	   "ga, L="
	   (strcat "%<\\AcObjProp Object(%<\\_ObjId " (vl-princ-to-string(Get-ObjectID-x86-x64 vlaCSblk)) ">%).Parameter(16).UpdatedDistance \\f \"%lu4%pr2\">%")
	   )
	)
  (setq pt (getpoint "Specify Tag Insertion Point"))
  (command "_.Insert" "BMP Tag CS Outside" pt 1 1 "" tagtext)
  (setq obj (entlast))
  (setq vlaobj (vlax-ename->vla-object obj))
  (setq vlaattobj (car (vlax-safeArray->list (vlax-variant-value (vla-getAttributes vlaobj)))))
  (setq OutsideTagFieldReactor (vlr-object-reactor (list vlaattobj vlaobj)
		      "Outside Tag Field Reactor" '((:vlr-modified . UpdateTagField))))
  (vlr-pers OutsideTagFieldReactor)
  (setq TagTextWidth (RN:GetAttWidth vlaobj))
  (setq TagBoxSize (+ TagTextWidth (/ 0.1 (getvar 'CANNOSCALEVALUE))))
  (LM:setdynpropvalue vlaobj "Tag Box Size" TagBoxSize)
  (vla-endundomark adoc)
  (princ)
  (*error* nil)
  )

(defun UpdateTagField (notifier-object reactor-object parameter-list /
		       objlist a b TagTextWidth TagBoxSize )
  (setq objlist (vlr-owners reactor-object))
  (if
    (= notifier-object (nth 1 objlist))
    (progn
      (vla-getBoundingBox (nth 1 objlist) 'a 'b)
      (setq a (vlax-safeArray->list a))
      (setq b (vlax-safeArray->list b))
      (setq TagTextWidth (- (car b) (car a)))
      (setq TagBoxSize (+ TagTextWidth (/ 0.1 (getvar 'CANNOSCALEVALUE))))
      (if
	(wcmatch (LM:effectivename (nth 0 objlist)) "BMP Tag*")
	(LM:setdynpropvalue (nth 0 objlist) "Tag Box Size" TagBoxSize)
	)
      )
    )
  )

(defun UpdateTagFieldX (notifier-object reactor-object parameter-list /
		       objlist a b TagTextWidth TagBoxSize )
  (setq objlist (vlr-owners reactor-object))
  (if
    (= notifier-object (nth 0 objlist))
    (progn
      (vla-getBoundingBox (nth 0 objlist) 'a 'b)
      (setq a (vlax-safeArray->list a))
      (setq b (vlax-safeArray->list b))
      (setq TagTextWidth (- (car b) (car a)))
      (setq TagBoxSize (+ TagTextWidth (/ 0.1 (getvar 'CANNOSCALEVALUE))))
      (LM:setdynpropvalue (nth 1 objlist) "Tag Box Size" TagBoxSize)
      )
    )
  )

(defun Get-ObjectID-x86-x64 (obj / util)
  (setq util (vla-get-Utility (vla-get-activedocument (vlax-get-acad-object))))
  (if (= (type obj) 'ENAME)(setq obj (vlax-ename->vla-object obj)))
  (if (= (type obj) 'VLA-OBJECT)
     (if (> (vl-string-search "x64" (getvar "platform")) 0)
       (vlax-invoke-method util "GetObjectIdString" obj :vlax-False)
       (rtos (vla-get-objectid obj) 2 0)
     )
  )
)

(defun RN:GetAttWidth (obj / atts att a b w rot)
  (vl-load-com)
  (setq rot (vlax-get-property obj 'Rotation))
  (vlax-put obj 'Rotation 0)
  (if
    (= (vla-get-hasAttributes obj) :vlax-true)
    (progn
      (setq atts (vlax-safeArray->list
		   (vlax-variant-value (vla-getAttributes obj))))
      (foreach att atts
	(vla-getBoundingBox att 'a 'b)
	(setq a (vlax-safeArray->list a))
	(setq b (vlax-safeArray->list b))
	(setq w (- (car b) (car a)))
	);foreach
      );progn
    );if
  (vlax-put obj 'Rotation rot)
  (princ w)
  )

(defun LM:setdynpropvalue ( blk prp val )
    (setq prp (strcase prp))
    (vl-some
       '(lambda ( x )
            (if (= prp (strcase (vla-get-propertyname x)))
                (progn
                    (vla-put-value x (vlax-make-variant val (vlax-variant-type (vla-get-value x))))
                    (cond (val) (t))
                )
            )
        )
        (vlax-invoke blk 'getdynamicblockproperties)
    )
)

(defun LM:effectivename ( obj )
    (vlax-get-property obj
        (if (vlax-property-available-p obj 'effectivename)
            'effectivename
            'name
        )
    )
)

Добавлено. Вру. Реактор тут не причем. Нужно динамический блок потыкать...

[Red Nova]

По предыдущему посту - я просто не учел что флип не меняет направления текста. Убрал флип чтобы пока не мешал... Пошли дальше.

Первый вариант объектного реактора у меня работает.
Но когда попытался усложнить код возникли проблемы.
В реакторе многие команды не работают. По крайней мере у меня...
Итак я имею блок маркера текст в котором может иметь разную ширину. Чтобы рамка блока маркера совпадала по ширине с текстом и пишется реактор.
При вставке блока я получаю ширину текста при помощи vla-getBoundingBox, при этом если блок повернут то я перед применением vla-getBoundingBox поворачивал блок как нужно, получал ширину и возвращал прежний поворот. Такой трюк в реакторе не работает. Не знаю в чем дело. На строчке vlax-put код слетает.

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

;(setq rot (vlax-get-property (nth 0 objlist) 'Rotation))
;(vlax-put (nth 1 objlist) 'Rotation 0)
(vla-getBoundingBox (nth 1 objlist) 'a 'b)
;(vlax-put (nth 1 objlist) 'Rotation rot)

В теперешнем виде все работает, но для повернутых блоков vla-getBoundingBox получает не те координаты что нужно.

Почему vlax-put не работает в реакторе?

[Red Nova]

Решение нашлось благодоря замене vla-getBoundingBox на функзию от Lee Mac.

Код:

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

 ;; Text Box  -  Lee Mac
;; A wrapper for the textbox function to return the bounding box of a Text or Attrib (in OCS)
(defun LM:textbox ( ent / ins mat rot )
        (setq ent (entget ent)
              ins (cdr (assoc 10 ent))
              rot (cdr (assoc 50 ent))
              mat (list
                      (list (cos rot) (sin (- rot)) 0.0)
                      (list (sin rot) (cos rot)     0.0)
                     '(0.0 0.0 1.0)
                  )
        )
        (mapcar '(lambda ( x ) (mapcar '+ (mxv mat x) ins)) (LM:points->boundingbox (textbox ent)))
    )

;; Points to Bounding Box  -  Lee Mac
;; Returns the rectangular extents of a supplied point list
(defun LM:points->boundingbox ( lst )
    (   (lambda ( l )
            (mapcar '(lambda ( a ) (mapcar '(lambda ( b ) ((eval b) l)) a))
               '(
                    (caar   cadar)
                    (caadr  cadar)
                    (caadr cadadr)
                    (caar  cadadr)
                )
            )
        )
        (mapcar '(lambda ( f ) (apply 'mapcar (cons f lst))) '(min max))
    )
)

;; Matrix x Vector  -  Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n
(defun mxv ( m v )
    (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)
 
(princ)

[Red Nova]

Никак не выходит отключить Object Reactor для определенных блоков.
Как правильно обозначить Object Reactor в рамках vlr-owner-remove?
Вот так не работает:

(vlr-owner-remove '#<VLR-Object-Reactor> owner) Error: bad argument type: Object reactor: #<VLR-OBJECT-REACTOR>

В хелпе такой пример:

(vlr-owner-remove circleReactor archie) #<VLA-OBJECT IAcadArc 03ad0bcc>

Но как до того назначить кто такой circleReactor?
Если при создании реактора я именую его TagFieldReactor

(setq TagFieldReactor (vlr-object-reactor (reverse (cons vlaobj vlaattobj)) "TagFieldReactor" '((:vlr-modified . UpdateTagField))))

И при этом TagFieldReactor - глобальная переменная, получаю

(vlr-owner-remove TagFieldReactor owner) Error: bad argument type: Object reactor: nil

[skkkk]

Возможно ли как-то в лиспе добиться "псевдо-вложенности" меток отмены? Если схематично, то имею в виду нечто следующее:

Код:

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

[НАЧАЛО] <начало_1><конец_1>   <начало_2><конец_2> ............<начало_N><конец_N>   [КОНЕЦ]

Я понимаю: явно (в лоб) этого не сделать, поскольку известно, что вторая подряд начальная метка отката "стирает" первую. Но может, можно как-то логически или аналитически схитрить?

Пример.
Программа в цикле поочередно (с помощью nentsel) просит указать подобъекты блока. Указанный подобъект незамедлительно стирается. До момента завершения команды (прерывания цикла по Enter) я хочу отменять по Ctrl+Z удаление каждого подобъекта по одному, а после завершения - отменить удаление сразу всех подобъектов.

Подобный принцип реализован в штатной _.PLINE: в процессе отрисовки можем убирать по одному сегменту, а по ее завершении - можно отменить сразу всю полилинию.

[Saur]

Сообщение от Red Nova Никак не выходит

Red Nova, до сих пор лисп не освоил?

[Сергей812]

Сообщение от skkkk Программа в цикле поочередно (с помощью nentsel) просит указать подобъекты блока. Указанный подобъект незамедлительно стирается. До момента завершения команды (прерывания цикла по Enter) я хочу отменять по Ctrl+Z удаление каждого подобъекта по одному, а после завершения - отменить удаление сразу всех подобъектов.

если с помощью grread можно перехватить нажатие Ctrl-Z и эта функция срабатывает раньше, чем nentsel (в .Net и ObjectARX перехват событий системы соответствующей функцией осуществляется на самом входе в акад, не знаю как в лиспе) - то не удалять, а скрывать объекты. И вести стек "удаленных" объектов. А саму команду обкрутить стандартными маркерами отмены. Т.е. внутри команды происходит перехват хоткея отмены и просто показывается объект с удалением из стека. После завершения команды все объекты чохом удаляются - но за их восстановление уже будет отвечать стандартный механизм отмены.

[skkkk]

Сергей812, идея для данного примера здравая, спасибо - суть хитрости уловил. Не додумался даже до такой. Было у меня еще пару-тройку программ, где я хотел бы реализовать подобный механизм, но сейчас что-то не припомню, где именно.
Причем тут с перехватом нажатия Ctrl+Z проблем нет, даже без grread. Это сочетание просто передает в командную строку символы _U, которые можно назначить в качестве ключевого слова переменной на запрос nentsel (предварив initget'ом) - и далее обработать. Тут я столкнулся с другим: как скрыть объект внутри блока? С удалением проблем нет: применяем vla-Delete ко вложенному объекту, затем entupd ко всему блоку - даже не подвисает ни на секунду. А вот как скрыть, пока не пойму. Redraw с аргументом 2 (скрыть примитив, перерисовать цветом фона) работает только в активном пространстве. Метод HighLight может только подсветить примитив пунктиром.

Пока писал, навела на мысль эта ремарка Полещука: "перерисовать цветом фона". Вроде, подходит. Ладно, свой цвет я знаю и не меняю его - стандартный черный (AC 2011) - 0, 0, 0. Назначаю его подпримитиву - и дело в шляпе, казалось бы... Но цвет не у всех такой. А выяснить программно на лиспе цвет фона нельзя (цитата из Полещука):

Этот тип данных не поддерживается AutoLISP, тем не менее управлять цветом можно, зная цифровые коды цветов, но нельзя получить значение установленного цвета фактически.

Не выходит вычислить значение полученного варианта (#<variant 19 16777215>):

;;; error: LISPFromPtr failed. The type is not supported: 19

Выходит, придется каждому юзеру прописывать в коде цвет индивидуально. Может, у кого еще какие мысли найдутся?
Сергей812, еще раз большое спасибо за хорошую идею.
И всех с праздником Великой Победы!

[Сергей812]

Варианты:
1. Переносить на вспомогательный выключенный слой
2. Полещук. п. 8.2.636. Свойство Visible

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

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

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

[skkkk]

Сергей812, и снова спасибо. С п.2 - в точку. Забыл я что-то про него. Не приходилось вроде, еще использовать, хватало до этого redraw.
Кулик Алексей aka kpblc, вроде как уже и не надо для этой задачи, но все равно стало любопытно, однако найти такой код так и не удалось. Только для изменения цвета нашел.

[frostmourn]

skkkk, вот, например: http://forum.dwg.ru/showthread.php?t=49422

[Red Nova]

Сообщение от Saur Red Nova, до сих пор лисп не освоил?

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

[Titli-pytli]

Здравствуйте! Извините, может вопрос уже был, найти не смог. В динамическом блоке есть параметр "отражение", соответственно возможны два варианта настройки: "Без отражения", "отраженное". В каком виде данных скармливать параметр функции vla-put-value для изменения этого динамического свойства?

[Red Nova]

Titli-pytli
Вот вариант от Lee Mac-а

Код:

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

 ;; Toggle Dynamic Block Flip State  -  Lee Mac
;; Toggles the Flip parameter if present in a supplied Dynamic Block.
;; blk - [vla] VLA Dynamic Block Reference object
;; Return: [int] New Flip Parameter value

(defun LM:toggleflipstate ( blk )
    (vl-some
       '(lambda ( prp / rtn )
            (if (equal '(0 1) (vlax-get prp 'allowedvalues))
                (progn
                    (vla-put-value prp (vlax-make-variant (setq rtn (- 1 (vlax-get prp 'value))) vlax-vbinteger))
                    rtn
                )
            )
        )
        (vlax-invoke blk 'getdynamicblockproperties)
    )
)

[Fedorino]

Здравствуйте! Подскажите пожалуйста, как заставить подобную конструкцию работать

Код:

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

 (setq pt (getpoint "\nУкажите точку: [привет]"))
(alert (vl-princ-to-string pt))

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

[AlexSheep]

Fedorino,
Посмотри функцию initget

[Fedorino]

Сообщение от AlexSheep Fedorino, Посмотри функцию initget

AlexSheep спасибо!
Смотрел ее, вводил с маленькой буквы и не работало (initget "привет")
Надо с заглавной, всем спасибо!
Пример

Код:

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

 (defun c:rrr ( / )
	(initget "Привет")
	(setq pt (getpoint "\nУкажите точку: [Привет]"))
	(alert (vl-princ-to-string pt))
)

[Enik]

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

Например, есть густо разрисованный чертёж. Нужно в конкретное место поставить точку/мультивыноску/блок и тп., чтобы программа автоматически прошерстила "окрестность" и поставила текст в ту часть чертежа, где он не будет перекрывать другие объекты. Причём, на максимально близком от конкретного места расстоянии.

[Сергей812]

Уже было подобное обсуждение в какой то ветке относительно выносок для кабельного журнала. Здесь задача гораздо сложнее. Например, ту же мультивыноску бывает порою проще вынести подальше от объекта, на который она указывает - чтобы при этом наклон и пересечки выносной линии с другими элементами чертежа обеспечивали однозначную визуальную связь выноски и объекта. Так что нахождение свободного "пятна" на чертежа - это лишь часть задачи.

[Enik]

Сообщение от Сергей812 Уже было подобное обсуждение в какой то ветке относительно выносок для кабельного журнала.

Не видел такой темы. Интересно, в результате обсуждения там что-нибудь интересное родилось?

Сообщение от Сергей812 Здесь задача гораздо сложнее. Например, ту же мультивыноску бывает порою проще вынести подальше от объекта, на который она указывает - чтобы при этом наклон и пересечки выносной линии с другими элементами чертежа обеспечивали однозначную визуальную связь выноски и объекта.

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

Сообщение от Сергей812 Так что нахождение свободного "пятна" на чертежа - это лишь часть задачи.

А методология решения данных задач в принципе существует?

Мне в голову только одна мысль приходит.
1. Задаём размер "окрестности", в пределах которой нужно разместить выноску.
2. Из dxf кодов элементов в этой окрестности выделяем нужные данные.
3. Создаём виртуальное координатное поле в пределах окрестности:
- задаём размер ячейки координатного поля. Допустим, 0.1х0.1 единицы чертежа.
- циклически проходим все ячейки координатного поля. Если в пределах ячейки оказывается объект, ячейке присваивается свойство " 1". Если нет, то свойство "0".
4. Определяем размеры выноски, которую хотим разместить, в количестве ячеек координатного поля.
5. Ну а дальше методом концентрических окружностей программа, оперируя данными координатного поля и размерами выноски, ищет пустое место. Как это происходит. Циклично. Сначала задаётся небольшой радиус, просматриваются все точки на окружности от 0 до 2π с некоторым шагом углов. Если места нет, то выбираются всё большие и большие радиусы, и так же проходятся окружности от 0 до 2π. И так до тех пор, пока радиус поиска не станет равен изначально заданному радиусу окрестности. И если пустого места нет, то вылетает ошибка: "извини, братан, местов нема".

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

Но это всё догадки. Честно говоря, я даже такой науки не знаю, где бы такие алгоритмы и задачи рассматривались.

----- добавлено через ~6 мин. -----
Ну или просто секрамкой по размерам выноски проходить окрестность методом концентрических окружностей... Это проще, но тогда будут возникать ошибки и слипания выноски с объектами.

[Сергей812]

Enik, думаю, что если хотите раскрыть эту тематику - надо попросить админа/модераторов вынести в отдельную ветку)

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

[Enik]

Сообщение от Сергей812 Enik, думаю, что если хотите раскрыть эту тематику - надо попросить админа/модераторов вынести в отдельную ветку)

Сергей812, хорошая мысль, спасибо!

Алексей, прошу рассмотреть эту возможность...

Offtop: Попробую ещё LeeMac'у написать.

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

Такими темпами можно и до умного проектирования дойти. Например, связать воедино кадастровый план, топосъёмку с домами, дорогами и коммуникациями. Наложить сюда ЗОУИТ. И вуаля: трассировка объекта готова. Вкалывают роботы - счастлив человек.

[Сергей812]

Offtop:

Сообщение от Enik до умного проектирования дойти

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

[Enik]

Offtop: Накидал схемку, отправил ЛееМаку

И ещё раз клац

[Saur]

Сообщение от Red Nova Вот к примеру умею так:

Молодца. Опалубку перекрытия вычерчиваешь? А вот подрезать все равно вручную надо

[Enik]

Offtop: Пришёл ответ от ЛееМака

Hi Vladimir,



Thank you for your message.



I'm afraid I haven't previously encountered programs such as you have described which would allow the automatic placement of annotation in a crowded drawing such that the annotation remains visible & readable. As you've identified from the algorithm described by your image set, such a task is relatively complex and would be quite a challenge to automate.



Kind Regards,



Lee

Offtop: В общем, придётся поднимать целину. Не похоже, чтобы этим кто-то занимался раньше.

[hamlet's shadow]

Добрый день! Координаты примитива функциями lisp извлекаются в экспоненциальной форме (вроде: (2.08014e+008 4.11118e+008)), что в десятичной записи дает точность до 1000. Вопрос номер один - как повысить точность извлечения координат (хотя бы до значения точности в настройках чертежа autocad). И вопрос два - как в visual lisp переводить числа из одного формата в другой. Тыкаю редактор буквально третий день, ни разу не программист, а дудл предлагает функцию format, которая не читается интерпретатором и в справочнике инфы не углядел. Оби Ван, ты последняя надежда.

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

Я не оби Ван, поэтому не надейся
Данные извлекаются с максимальной точностью. Просто отображаются не совсем корректно. Можешь ради приколу проверить через (rtos value 2 16)

[hamlet's shadow]

Сообщение от Кулик Алексей aka kpblc Я не оби Ван, поэтому не надейся Данные извлекаются с максимальной точностью. Просто отображаются не совсем корректно. Можешь ради приколу проверить через (rtos value 2 16)

Спасибо не Оби Ван Да, в строке смотрится куда "точнее", но проблема в том, что когда скармливаю список с координатами (вещественные числа в в экспоненциальной форме) функции "XLS" (которую выдернул отсюда http://forum.dwg.ru/showpost.php?p=244237&postcount=7), то в Excel она делает экспорт в той же форме (экспоненциальной) и с точностью, которая отображается в редакторе visual lisp. Перевод числа уже в экселе в десятичную форму дает результат с точность до 1000. Бяда. Если экспорт идет с максимальной точностью, то может в excel чего подкрутить нужно? Или без перевода чисел в строку до экспорта удачи не видать?

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

Нннуууу... Если неохота сильно разбираться, попробуй поиграться с luprec, lunits - кажется, именно они отвечают за отображение значений.
P.S. Код не смотрел, не разбирался. Увы, некогда

[Titli-pytli]

Подскажите пожалуйста, как определять общие глобальные переменные для нескольких открытых чертежей? А то в одном чертеже она (переменная) есть, а в другом она nil.

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

Если так уж надо, то используй функции vl-bb-set и vl-bb-ref
Хотя я бы подумывал об использовании реестра или внешних настроечных файлов. Нечасто надо делать внедокументные переменные.

[Fedorino]

Здравствуйте!
Не могу придумать как организовать выбор двух событий, подскажите пожалуйста

Код:

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

 (setq es (entsel "Выберите объект для смещения или [Расстояние]: "))

Как сделать либо выбор объекта, либо ввод расстояния?

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

Код:

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

   (initget 128 "Расстояние Distance")
  (entsel "Выберите объект для смещения или [Расстояние] : ")

[Fedorino]

Алексей, спасибо, не знал что initget можно применять к другим методам кроме get.

[Fedorino]

Снова здравствуйте!
В продолжение предыдущего вопроса.
Необходимо либо выбрать объект, либо сразу ввести значение, возможно ли такое?
Т.е. в переменную записывается либо сам объект, либо любое введенное значение.
Например, вводим число 5, в переменную записалось число 5.
Если щелкнули мышью по объекту, записалось имя объекта.

Код:

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

 (setq es (entsel "\nВыберите объект: "))
(princ es) ; 5 или имя объекта

----- добавлено через ~6 ч. -----
Никто не подсказывает, пришлось думать самому.
Воткнул в initget возможные варианты значений от 0 до 10 с шагом 0.1.
Возможно и глупо, но теперь можно выбрать либо объект, либо ввести необходимое значение, сразу.

Код:

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

 	; формируем initget
		(setq i 0.0)
		(setq str "")
	(repeat 100
		(setq i (+ i 0.1))
		(if (eq (rem (* i 10) i) 0) (setq a 0) (setq a 1))
		(setq str (strcat str (rtos i 2 a) " "))
	)

       (initget str)
       (while
          (setq es (entsel "\nВыберите объект или введите расстояние: "))
          (alert (vl-princ-to-string es))
       )

[Sergey91@06]

Здравствуйте, друзья! Необходима ваша помощь
Нашел в интернете полезный LISP - создающий выноску с именем блока, немного адаптировал под себя, т.к. необходимо было чтобы на выноске отображалось не имя блока а название видимости. Проблемы начинаются когда у блока много атрибутов - вместо названия видимости на выноске отображается ###. Так понимаю вся проблема в строке: ">%).Parameter(1).VisibilityState>%", как только видимость перестает быть параметром номер 1 - отображается ###. Пытался с помощью субфункций от LeeMac реализовать вставку значения не путем ссылки, а просто вставки текста = название видимости, пусть даже они не будут связаны ссылкой на параметр объекта.
В общем мне необходимо понять, что нужно исправить в нижнем коде, в который я добавил функции от LeeMac, а именно что нужно написать вместо: "AcDbBlockVisibilityParameterEntity"(в исходной версии:"%<\\AcObjProp Object(%<\\_ObjId " (itoa (vla-get-objectid pline)) ">%).Parameter(1).VisibilityState>%")
Рабочий код:

Код:

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

(defun C:BLNM (/ acsp adoc ent mtx p1 p2 pline txt)
  (vl-load-com)
  (or adoc
      (setq adoc
	     (vla-get-activedocument
	       (vlax-get-acad-object)
	     )
      )
  )
  (if (and
	(= (getvar "tilemode") 0)
	(= (getvar "cvport") 1)
      )
    (setq acsp (vla-get-paperspace adoc))
    (setq acsp (vla-get-modelspace adoc))
  )
  (setq
    pline (vlax-ename->vla-object
	    (car (setq ent (entsel "\n >> Выбрать блок >> \n")))
	  )
  )
  (setq	txt
	 (strcat
	   "%<\\AcObjProp Object(%<\\_ObjId "
	   (itoa (vla-get-objectid pline))
	  ">%).Parameter(1).VisibilityState>%"
	 )
  )
  (setq	p1 (cadr ent)
	p2 (getpoint p1 "\nВторая точка >> \n")
  )
  (setq	mtx (vlax-invoke
	      acsp 'AddMText p2	0.0 txt)
  )
  (vlax-put mtx
	    'AttachmentPoint
	    (cond ((> (car p1) (car p2))
		   acAttachmentPointMiddleRight
		  )
		  ((< (car p1) (car p2))
		   acAttachmentPointMiddleLeft
		  )
		  (T acAttachmentPointMiddleLeft)
	    )
  )

  (vlax-invoke
    acsp
    'Addleader
    (apply 'append (list p1 p2))
    mtx
    acLineWithArrow
  )
  (vl-catch-all-apply
    (function (lambda ()
		(progn
		  (vlax-release-object mtx)
		  (vlax-release-object pline)
		)
	      )
    )
  )
  (vla-regen adoc acactiveviewport)
  (princ)
)
(prompt "\n")
(prompt "\t\t<<< Ввести BLNM для старта программы :  >>>  \n")
(princ)
; TesT : (C:BLNM)LISP]

Моя криворукая попытка вставить значение видимости в обход ссылки на параметр:

Код:

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

(defun C:BLNM (/ acsp adoc ent mtx p1 p2 pline txt)
(defun LM:SetVisibilityState ( blk val / vis )
    (if
        (and
            (setq vis (LM:getvisibilityparametername blk))
            (member (strcase val) (mapcar 'strcase (LM:getdynpropallowedvalues blk vis)))
        )
        (LM:setdynpropvalue blk vis val)
    )
)
(defun LM:getvisibilitystate ( blk )
    (LM:getdynpropvalue blk (LM:getvisibilityparametername blk))
)
(defun LM:getvisibilityparametername ( blk / vis )  
    (if
        (and
            (vlax-property-available-p blk 'effectivename)
            (setq blk
                (vla-item
                    (vla-get-blocks (vla-get-document blk))
                    (vla-get-effectivename blk)
                )
            )
            (= :vlax-true (vla-get-isdynamicblock blk))
            (= :vlax-true (vla-get-hasextensiondictionary blk))
            (setq vis
                (vl-some
                   '(lambda ( pair )
                        (if
                            (and
                                (= 360 (car pair))
                                (= "BLOCKVISIBILITYPARAMETER" (cdr (assoc 0 (entget (cdr pair)))))
                            )
                            (cdr pair)
                        )
                    )
                    (dictsearch
                        (vlax-vla-object->ename (vla-getextensiondictionary blk))
                        "ACAD_ENHANCEDBLOCK"
                    )
                )
            )
        )
        (cdr (assoc 301 (entget vis)))
    )
)
  (vl-load-com)
  (or adoc
      (setq adoc
	     (vla-get-activedocument
	       (vlax-get-acad-object)
	     )
      )
  )
  (if (and
	(= (getvar "tilemode") 0)
	(= (getvar "cvport") 1)
      )
    (setq acsp (vla-get-paperspace adoc))
    (setq acsp (vla-get-modelspace adoc))
  )
  (setq
    pline (vlax-ename->vla-object
	    (car (setq ent (entsel "\n >> Выбрать блок >> \n")))
	  )
  )
  (setq	txt
	 (strcat
	   "AcDbBlockVisibilityParameterEntity"
	 )
  )
  (setq	p1 (cadr ent)
	p2 (getpoint p1 "\nВторая точка >> \n")
  )
  (setq	mtx (vlax-invoke
	      acsp 'AddMText p2	0.0 txt)
  )
  (vlax-put mtx
	    'AttachmentPoint
	    (cond ((> (car p1) (car p2))
		   acAttachmentPointMiddleRight
		  )
		  ((< (car p1) (car p2))
		   acAttachmentPointMiddleLeft
		  )
		  (T acAttachmentPointMiddleLeft)
	    )
  )

  (vlax-invoke
    acsp
    'Addleader
    (apply 'append (list p1 p2))
    mtx
    acLineWithArrow
  )
  (vl-catch-all-apply
    (function (lambda ()
		(progn
		  (vlax-release-object mtx)
		  (vlax-release-object pline)
		)
	      )
    )
  )
  (vla-regen adoc acactiveviewport)
  (princ)
)
(prompt "\n")
(prompt "\t\t<<< Ввести BLNM для старта программы :  >>>  \n")
(princ)
; TesT : (C:BLNM)LISP]

[100k]

Господа, подскажите мне пожалуйста:
1. Lisp это функциональный язык?
2. Похож он на F#?
4. Если похож, то значит там используются лямбда выражения?

[trir]

1. Lisp это функциональный язык?

это отец всех функциональных языков

4. Если похож, то значит там используются лямбда выражения?

lisp это сплошная лямбда

[gomer]

Сообщение от 100k Господа, подскажите мне пожалуйста: 1. Lisp это функциональный язык? 2. Похож он на F#? 4. Если похож, то значит там используются лямбда выражения?

1. нет
2. нет
4. нет, да
3.?

[Sergey91@06]

Добрый день!
LISP-код выдает ошибку: ; ошибка: неверно сформированный список на входе
Помогите пожалуйста исправить ошибку

Код:

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

(defun C:BLNM3 (/ acsp adoc ent mtx p1 p2 pline txt)
  (vl-load-com)
  (or adoc
      (setq adoc
	     (vla-get-activedocument
	       (vlax-get-acad-object)
	     )
      )
  )
  (if (and
	(= (getvar "tilemode") 0)
	(= (getvar "cvport") 1)
      )
    (setq acsp (vla-get-paperspace adoc))
    (setq acsp (vla-get-modelspace adoc))
  )
  (setq
    pline (vlax-ename->vla-object
	    (car (setq ent (entsel "\n >> Выберите блок >> \n")))
	  )
  )
(setq text (if (GetParamIDbyName name "Состояние видимости")
                                    (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                                          (itoa (vla-get-ObjectID vla))
                                          ">%).Parameter("
                                          (itoa (GetParamIDbyName name "Состояние видимости"))
                                          ").VisibilityState>%"
                                          )
                                    (if (GetParamIDbyName name "Stav viditelnosti")
                                      (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                                            (itoa (vla-get-ObjectID vla))
                                            ">%).Parameter("
                                            (itoa (GetParamIDbyName name "Stav viditelnosti"))
                                            ").VisibilityState>%"                                      
                                            )
                                    (if (GetParamIDbyName name "Visibility State")
                                      (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                                            (itoa (vla-get-ObjectID vla))
                                            ">%).Parameter("
                                            (itoa (GetParamIDbyName name "Visibility State"))
                                            ").VisibilityState>%"                                      
                                            )
                                      "Ошибка атрибута!"
                                      ))
  (setq	p1 (cadr ent)
	p2 (getpoint p1 "\nВторая точка >> \n")
  )
  (setq	mtx (vlax-invoke
	      acsp 'AddMText p2	0.0 txt)
  )
  (vlax-put mtx
	    'AttachmentPoint
	    (cond ((> (car p1) (car p2))
		   acAttachmentPointMiddleRight
		  )
		  ((< (car p1) (car p2))
		   acAttachmentPointMiddleLeft
		  )
		  (T acAttachmentPointMiddleLeft)
	    )
  )

  (vlax-invoke
    acsp
    'Addleader
    (apply 'append (list p1 p2))
    mtx
    acLineWithArrow
  )
  (vl-catch-all-apply
    (function (lambda ()
		(progn
		  (vlax-release-object mtx)
		  (vlax-release-object pline)
		)
	      )
    )
  )
  (vla-regen adoc acactiveviewport)
  (princ)
)
(prompt "\n")
(prompt "\t\t<<< Ввести BLNM3 для старта программы :  >>>  \n")
(princ)
; TesT : (C:BLNM3)LISP]

[Сергей812]

Код:

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

(princ) ) ; Закрывающая скобка функции
; TesT : (C:BLNM3)LISP]

[Sergey91@06]

Сергей812, спасибо, к сожалению результат не изменился, видимо ещё есть подобные ошибки

[Сергей812]

Видимо, просто это в глаза бросилось сразу)
Загружаете в редакторе VisualLisp и горячими клавишами "Ctrl + [" и "Ctrl +]" проверяете комплектность скобок (открывающей и закрывающей соответственно) в строках, где их много.

[Sergey91@06]

Сергей812, нашел недостающую скобку, теперь lisp загружается, но при исполнении и выборе динамического блока выдает ошибку: неверный тип аргумента: lentityp 1 (хотя прежняя версия мое сообщение выше, выносила выноску, я просто изменил ссылку, добавив возможные варианты текста и через if и получение ID параметра видимости)
P.S. скобку в конце все-таки убрал с ней не запускалось, видимо программа закрывается чуть раньше.

Код:

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

(defun C:BLNM3 (/ acsp adoc ent mtx p1 p2 pline txt)
  (vl-load-com)
  (or adoc
      (setq adoc
	     (vla-get-activedocument
	       (vlax-get-acad-object)
	     )
      )
  )
  (if (and
	(= (getvar "tilemode") 0)
	(= (getvar "cvport") 1)
      )
    (setq acsp (vla-get-paperspace adoc))
    (setq acsp (vla-get-modelspace adoc))
  )
  (setq
    pline (vlax-ename->vla-object
	    (car (setq ent (entsel "\n >> Выберите блок >> \n")))
	  )
  )
(setq text (if (GetParamIDbyName name "Состояние видимости")
                                    (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                                          (itoa (vla-get-ObjectID vla))
                                          ">%).Parameter("
                                          (itoa (GetParamIDbyName name "Состояние видимости"))
                                          ").VisibilityState>%"
                                          )
                                    (if (GetParamIDbyName name "Stav viditelnosti")
                                      (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                                            (itoa (vla-get-ObjectID vla))
                                            ">%).Parameter("
                                            (itoa (GetParamIDbyName name "Stav viditelnosti"))
                                            ").VisibilityState>%"                                      
                                            )
                                    (if (GetParamIDbyName name "Visibility State")
                                      (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                                            (itoa (vla-get-ObjectID vla))
                                            ">%).Parameter("
                                            (itoa (GetParamIDbyName name "Visibility State"))
                                            ").VisibilityState>%"                                      
                                            )
                                      "Ошибка атрибута!"
                                      ))))
  (setq	p1 (cadr ent)
	p2 (getpoint p1 "\nВторая точка >> \n")
  )
  (setq	mtx (vlax-invoke
	      acsp 'AddMText p2	0.0 txt)
  )
  (vlax-put mtx
	    'AttachmentPoint
	    (cond ((> (car p1) (car p2))
		   acAttachmentPointMiddleRight
		  )
		  ((< (car p1) (car p2))
		   acAttachmentPointMiddleLeft
		  )
		  (T acAttachmentPointMiddleLeft)
	    )
  )

  (vlax-invoke
    acsp
    'Addleader
    (apply 'append (list p1 p2))
    mtx
    acLineWithArrow
  )
  (vl-catch-all-apply
    (function (lambda ()
		(progn
		  (vlax-release-object mtx)
		  (vlax-release-object pline)
		)
	      )
    )
  )
  (vla-regen adoc acactiveviewport)
  (princ)
	     )
(prompt "\n")
(prompt "\t\t<<< Ввести BLNM для старта программы :  >>>  \n")
(princ) 
; TesT : (C:BLNM)LISP]

[Сергей812]

да, посмотрел внимательнее - последние 4 строки: это подсказка по использованию команды при загрузке лиспа в акад, сорри за введение в заблуждение. Но вы не полный код выложили - например, GetParamIDbyName?

[Sergey91@06]

Сергей812, да потерял кусок кода, вот обновленный код, собираю его из разных кусков как вслепую конструктор, поскольку в lispе практически не понимаю,
результатом такого метода тыка ошибка теперь приобрела следующий вид: неверный тип аргумента: VLA-OBJECT nil

Код:

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

(defun C:BLNM3 (/ acsp adoc ent mtx p1 p2 pline txt)
    (setq CONSTparamtypes (list
      (list
                "Состояние видимости"   ;visibility
                "Stav viditelnosti"     ;visibility
		"Visibility State"      ;visibility

      )))
  (setq description (LM:getdynpropvalue vla "_Visibility" ) )
  (vl-load-com)
  (or adoc
      (setq adoc
	     (vla-get-activedocument
	       (vlax-get-acad-object)
	     )
      )
  )
  (if (and
	(= (getvar "tilemode") 0)
	(= (getvar "cvport") 1)
      )
    (setq acsp (vla-get-paperspace adoc))
    (setq acsp (vla-get-modelspace adoc))
  )
  (setq
    pline (vlax-ename->vla-object
	    (car (setq ent (entsel "\n >> Выберите блок >> \n")))
	  )
  )
  (setq paramtypes (if (GetParamIDbyName name "_Visibility")
              (nth 1 CONSTparamtypes)
              (nth 0 CONSTparamtypes)
              ))
  (setq vla (vlax-ename->vla-object name))
  (setq description (LM:getdynpropvalue vla "_Visibility" ) )
(setq description_ref (if (GetParamIDbyName name (nth 0 paramtypes))
                                    (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                                          (itoa (vla-get-ObjectID vla))
                                          ">%).Parameter("
                                          (itoa (GetParamIDbyName name (nth 0 paramtypes)))
                                          ").VisibilityState>%"
                                          )
                                    (if (GetParamIDbyName name "Stav viditelnosti")
                                      (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                                            (itoa (vla-get-ObjectID vla))
                                            ">%).Parameter("
                                            (itoa (GetParamIDbyName name "Stav viditelnosti"))
                                            ").VisibilityState>%"                                      
                                            )
                                    (if (GetParamIDbyName name "Visibility State")
                                      (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                                            (itoa (vla-get-ObjectID vla))
                                            ">%).Parameter("
                                            (itoa (GetParamIDbyName name "Visibility State"))
                                            ").VisibilityState>%"                                      
                                            )
                                      "Ошибка атрибута!"
                                      ))))
  (setq	p1 (cadr ent)
	p2 (getpoint p1 "\nВторая точка >> \n")
  )
  (setq	mtx (vlax-invoke
	      acsp 'AddMText p2	0.0 txt)
  )
  (vlax-put mtx
	    'AttachmentPoint
	    (cond ((> (car p1) (car p2))
		   acAttachmentPointMiddleRight
		  )
		  ((< (car p1) (car p2))
		   acAttachmentPointMiddleLeft
		  )
		  (T acAttachmentPointMiddleLeft)
	    )
  )

  (vlax-invoke
    acsp
    'Addleader
    (apply 'append (list p1 p2))
    mtx
    acLineWithArrow
  )
  (vl-catch-all-apply
    (function (lambda ()
		(progn
		  (vlax-release-object mtx)
		  (vlax-release-object pline)
		)
	      )
    )
  )
  (vla-regen adoc acactiveviewport)
  (princ)
  ;;; finds (param) parameter of object (ent) and returns its number
(defun GetParamIDbyName (ent param)
  (cdr (assoc param (GetParameterNumber ent))))
	     )
(prompt "\n")
(prompt "\t\t<<< Ввести BLNM3 для старта программы :  >>>  \n")
(princ) 
; TesT : (C:BLNM3)LISP]

[Red Nova]

Доброго.
Подскажите плиз можно ли повесить блок на курсор и при этом заранее иметь возможность задать его размер.
Если делать командным методом то блок повесится на курсор в размере 1:1, а размер будет задан после этого.
(command "_.Insert" "BMP Dot" pause 100 100 "")
То есть веся на курсоре блок будет иметь неправильный размер.
Если же сперва вставить блок в точку с нулевыми координатами в нужном размере, а затем использовать "._move"
(command "._move" dot "" '(0 0) pause)
То от курсора к точке (0 0) будет видна направляющая, что не есть гут.

[Сергей812]

а если activex использовать - vla-move ?
Во всяком случае, в том же NETAPI это задача решается установкой нужного масштаба при первичной вставке в текущее пространство через BlockReference.ScaleFactors с последующей передаче в JIG, который уже и таскает вставку. А командные методы лиспа - это такой черный ящик по сути)

[Red Nova]

А в vla-move можно делать паузу на user input?

[Сергей812]

вообще то имел в виду grread в цикле... Не знаю правда, насколько это мерцать будет - в NET мерцания не заметно особо во время JIG. Т.е. вставляете блок в нужном масштабе тоже через ActiveX, и потом запрашиваете через ggread текущие координаты указателя и подтаскивайте туда вставку блока. И какой то выход из цикла предусмотреть, естественно.

[ShaggyDoc]

Сообщение от Red Nova Доброго. Подскажите плиз можно ли повесить блок на курсор и при этом заранее иметь возможность задать его размер. Если делать командным методом то блок повесится на курсор в размере 1:1, а размер будет задан после этого. (command "_.Insert" "BMP Dot" pause 100 100 "") То есть веся на курсоре блок будет иметь неправильный размер. Если же сперва вставить блок в точку с нулевыми координатами в нужном размере, а затем использовать "._move" (command "._move" dot "" '(0 0) pause) То от курсора к точке (0 0) будет видна направляющая, что не есть гут.

Несколько раз публиковал на форуме такую функцию, даже конкурс был на написание. Подскажу основной момент - предварительно надо масштабировать и, если надо, повернуть блок. Поворот можно и задавать на месте после вставки. Фрагмент кода функции:

Код:

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

 (vl-cmdf "_.INSERT"   block_name  "_PROTATE"  (if block_angle   block_angle    0 )
                             "_PXScale"   x_scale "_PYScale"  y_scale    pause )

Надо это обернуть в цикл, т.к. часто приходится вставлять блок многократно. Прерывание цикла по ESC, но с обязательной защитой через error-catch, чтобы прерывалась не программа, а только цикл вставки.

Позаботиться о возможных атрибутах.

[Red Nova]

ShaggyDoc vl-cmdf "_.INSERT" работает, спасибо. Многократно вставлять мне необходимости не было, сделал по простому.

Код:

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

 (vl-cmdf "_.INSERT" "BMP Dot" "_scale" dotscale "_rotate" 0 pause)

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

Ага, но в последних версиях (начиная с 2015, кажется) vl-cmdf независимо ни от чего возвращает t, а command (равно как и command-s) - nil. Так что учтите

[skkkk]

Сообщение от Кулик Алексей aka kpblc vl-cmdf независимо ни от чего возвращает t

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

[roaa]

Сообщение от Red Nova Если же сперва вставить блок в точку с нулевыми координатами в нужном размере, а затем использовать "._move"

а почему не "_change"?
ну и ActiveX:

Код:

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

 
(defun _vis_ins_blk ( asp blkName blkScal blkAngl / actdoc actspace bl)
;;; Вставка блока (динамическая)
;;; asp - vla-указатель на пространство документа
;;; blkName - имя блока - строковая (вхождение блока должно быть)
;;; blkScal - масштаб вставки - действительное
;;; blkAngl - угол поворота блока - действительное
        
  (princ "\nТочка вставки:")
  (vl-catch-all-error-p 
    (vl-catch-all-apply 
     '(lambda ()
        (while
          (= 5 (car (setq gr (grread 13 0))))
          (if bl (vla-erase bl))
          (setq bl 
                   (vla-InsertBlock asp
                     (vlax-3d-point (cadr gr))
                     blkName blkScal blkScal blkScal blkAngl
                   ) ;_ end vla-InsertBlock
          ) ;_ end setq
        ) ;_ end while
      ) ;_ end lambda
    ) ;_ end vl-catch-all-apply
  ) ;_ end vl-catch-all-error-p 
  (cond ((/= 3 (car gr))(vla-erase bl)(setq bl nil))(bl))
) ;_ end defun


(defun _vis_mins_blk ( adc blkName blkScal blkAngl / actdoc actspace bl)
;;; Множественная вставка блока (динамическая)
;;; asp - vla-указатель на пространство документа
;;; blkName - имя блока - строковая (вхождение блока должно быть)
;;; blkScal - масштаб вставки - действительное
;;; blkAngl - угол поворота блока - действительное
;;; Запуск: (_vis_mins_blk (vla-get-activedocument (vlax-get-acad-object)) "fire_smoke" 100 0)
        
  (setq asp    (if (= (vla-get-activespace adc) 1)
                 (vla-get-modelspace adc)
                 (vla-get-paperspace adc)
               ) ;_ end if
        bl_lst nil
  ) ;_ end setq
  (while
    (setq blk (_vis_ins_blk asp blkName blkScal blkAngl))
    (setq bl_lst (cons blk bl_lst))
  ) ;_ end while
  bl_lst
) ;_ end defun

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

Придется извращаться - запоминать последний примитив, выполнять команду, проверять соответствие и т.п. Ну или переходить на .net...
Сам был в шоке!

[Сергей812]

А пробовали написать в Аутодеск - чем вызвано такое изменение поведения функции vl-cmdf ?
А для command у Полещука написано - что возвращаемое значение nil всегда.

[skkkk]

Сообщение от Сергей812 command у Полещука написано - что возвращаемое значение nil всегда

Это-то давно известно, Алексей просто напомнил. Я с самого начала освоения лиспа не понимал, зачем же она возвращает nil? Ну не возвращай ты ничего, верни какой-либо список параметров выполненной команды, имя команды в конце концов. А тут просто - выполнил команду, хоть всё и верно прошло, а в ответ - ЛОЖЬ! Где логика? Ладно, я с этим смирился, и даже использовал ее порой, бывали случаи, когда vl-cmdf не отрабатывал (конкретики сейчас не припомню - всегда старался уходить от командных методов). Но вот уж вообще чего не пойму: зачем трогать то, что работало и так? Заставляя при этом разрабов переписывать коды в языке, который прямо-таки и вопил на всех углах: "Я не завишу от версии!!!" Возможно были конфликты с какими-то из новшеств. Или же это было начало политики, провоцирующей всех постепенно

Сообщение от Кулик Алексей aka kpblc переходить на .net

Знать бы куда и кому писать. Никогда этого не делал, поскольку особо не верил в то, что меня услышат. Вместо этого усердно ваял костыли и искал обходные пути. Наверное, я "социальный овощ" по Бушману.

[Сергей812]

Ну они и про VBA пугали уже сколько лет - что откажутся от его поддержки. И тоже в пользу того же NET, ObjectARX - в конечном итоге еще джаву прилепили с какой то версии, оставив остальное)

[ShaggyDoc]

Сообщение от roaa а почему не "_change"? ну и ActiveX:

Ну, один раз можно. Но гораздо полезнее множественная вставка блока. При этом блок должен постоянно висеть на курсоре, уже в нужном масштабе, возможно повернутым. Блок может иметь атрибуты, причем всех видов, а может и не иметь. И прерывать цикл как в штатных командах - пустым вводом. И чтобы при этом не вывалиться из основной программы.

Такая функция может применяться очень часто. Вообще идеально, чтобы была штатной, но....

Мы с Петром Лоскутовым (Alaspher) - соавтором Н.Н. Полещука по книге AutoLISP и Visual LISP в среде AutoCAD и подружились при совместной отработке этой функции лет 20 назад. Тогда был только Автолисп, не было замечательных vl-catch-xxx, никаких ActiveX.

Было много сложных вариантов. чтобы выполнить все условия. Более простой появился вместе с vl-cmdf, которая стала возвращать T или NIL. Но вот "никогда такого не было и опять".

Хорошо хоть могу послать уродов из AutoDesk в "индейскую избу"...

[LcH]

Может кто-нибудь откликнется на мой вопрос.
Можно из программы на Автолиспе получить информацию, есть ли в dwg объекты, к которым можно применить purge?
Т.е., хотелось бы не входить в диалог утилиты AutoCAD 'Проверить', не делать _purge, не делать (repeat 3 (vla-PurgeAll (vla-get-ActiveDocument (vlax-get-acad-object)))),
т.е. не чистить, а только получить информацию, требуется очистка dwg, или нет.
Для другой проверки - требуется _audit dwg, или нет, я сделала (написала - это будет громко сказано) небольшую функцию-команду, где использовала (vla-AuditInfo active_doc :vlax-False), и мне было достаточно нескольких последних результирующих строк протокола работы этой функции, чтобы сформировать сообщение разработчику dwg, о необходимости провести проверку внутренней структуры чертежа, исправить ошибки.
Сейчас мне требуется не чистить чертеж, а проверить, был ли чертеж очищен, желательно написать функцию - проверку.
Не подскажете, это возможно?

[frostmourn]

А результат в каком виде нужно получить? Насколько я понял (судя по vla-AuditInfo), достаточно вывода в комстроке?

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

Я бы поставил LOGFILEMODE, установил LOGFILEPATH, потом в ком.строке выполнил _.-purge, explodeallproxy, removeallproxy, _.audit и прочие вещи, следом - отмена действий. И после этого уже обрабатывать полученный log-файл.
Есть, конечно, другой вариант - проходить по всем соответствующим таблицам и на каждый элемент пытаться выполнить нечто типа:

Код:

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

 (entdel ent)
(if (not (entget ent))
    ;; Примитив удаляется. Делаем что надо в таком случае
 ) ;_ end of if
(entdel ent) ;; восстанавливаем примитив

Но работать будет ооочень долго, я думаю.

[LcH]

Добрый день!
Спасибо, что разместили мой вопрос и откликнулись.

"А результат в каком виде нужно получить? Насколько я понял (судя по vla-AuditInfo), достаточно вывода в комстроке?"

"Я бы поставил LOGFILEMODE, установил LOGFILEPATH, потом в ком.строке выполнил _.-purge, explodeallproxy, removeallproxy, _.audit и прочие вещи, следом - отмена действий. И после этого уже обрабатывать полученный log-файл."


В общем-то, по такой схеме у нас организованы три функции проверки.
Создаю каталог, используя вашу функцию создания каталога в
(strcat (vl-string-right-trim "\\" (getenv "APPDATA")) "\\LispRu\\Datas"), которую когда-то откуда-то у вас скопировала.
Переназначаю LOGFILEPATH, устанавливаю LOGFILEMODE, затем анализирую закрытый уже log файл, часть информации (коротко)
вывожу на экран и в текстовое окно Автокада. Потом, эти функции проверки удаляют проанализированные log
файлы из каталога (...\\LispRu\\Datas). Конечно, результаты всех проверок в сокращенном варианте можно записать в один
текстовый файл и отправить разработчику dwg. Это не вопрос, просто, пока не обязательно.
Проверка на наличие прокси-объектов пока не требуется, проверяем и настоятельно рекомендуем удалять только, так называемые,
AcDgnLS прокси-объекты, эта проверка есть и программы удаления тоже.

Моя проблема в том, что НЕ хочется мне делать _.purge, а следом - отмена действий, даже, если закрывать потом файлы без сохранения.
Пока не знаю как поступить.

[frostmourn]

Можно и не завершать _.purge. Попробуйте так:

Код:

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

 
(foreach x
		'("_b" "_d" "_la" "_lt" "_ma" "_mu" "_p" "_sh" "_st" "_m" "_t" "_v" "_r"
		; "_de" "_g" "_se" ; на всякий случай убрал опции, недоступные в 10-м акаде
		; "_z" "_e" "_o" ; и которые не спрашивают подтверждения
		)
	(setvar 'cmdecho 0)
	(vl-cmdf "_.-purge" x "*" "_y")
	(setvar 'cmdecho 1)
	(while (= (getvar 'cmdactive) 1) (vl-cmdf "_n"))
)

По некотором размышлении даже и так должно подойти. Наверное.

Код:

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

 
(vl-cmdf "_.-purge" "_a" "*" "_y")
(while (= (getvar 'cmdactive) 1) (vl-cmdf "_n"))

[gomer]

Сообщение от frostmourn Попробуйте так:

не нужно насиловать SyntaxHighlighter version 2.1.382 (June 24 2010)
и у ж тем более не рекомендуется насиловать автокад повторяющимися тедодвижениями

[skkkk]

LcH, во-первых, я бы не советовал учиться лиспу на таком примере. Сложноватым будет для новичка, полагаю. Может, попросить модераторов перенести этот вопрос в отдельную тему, тем более, что он вполне на это тянет.
Во-вторых, хотелось бы узнать, почему не подойдет вариант Алексея (_.-purge с последующим откатом)? Я почти уверен, что любая функция по такой проверке будет работать намного дольше. Не говоря уже о трудности в написании подобной функции. В самом деле, представьте, это же надо пробежаться по таблице блоков (в "базе чертежа"), проверить каждый на наличие в чертеже. Для полной уверенности надо убедиться, что этот блок не входит в какой-либо другой блок. То же самое придется провернуть и с таблицей слоев, типов линий, не забыв залезть в каждый блок и проверить их наличие там. Не говоря уже о проверке текстовых и прочих стилей. В общем, непростая это будет функция, весьма хлопотная в реализации, да еще и тормознутей некуда. Оно надо?
Встань передо мной такая задача, я бы пошел по пути, указанному Алексеем. В библиотеке DOSLIB есть функция, возвращающая содержимое командной строки. Я бы делал пурж (похоже, что для надежности надо все же три раза его сделать), а затем получал содержимое комстроки, "выцеплял" бы из него строки, начинающиеся на "Удаление..." и делал в них замену "Удаление" на "Неиспользуемый", что бы получился список строк вроде:

Код:

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

(list
	"Неиспользуемый блок \"_None\""
	"Неиспользуемый слой \"Слой1\""
	"Неиспользуемый размерный стиль \"Standard\""
)

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

[Lavrentiy]

Добрый день. Подскажите, пожалуйста, как можно выделить набор, который получился в результате копирования другого набора? Если по шагам: я выделил набор объектов командой "ssget", затем откопировал их с помощью команды "command "_copy"". Вот, можно-ли выделить программно этот новый набор?

[Сергей812]

Сообщение от Lavrentiy Добрый день. Подскажите, пожалуйста, как можно выделить набор, который получился в результате копирования другого набора? Если по шагам: я выделил набор объектов командой "ssget", затем откопировал их с помощью команды "command "_copy"". Вот, можно-ли выделить программно этот новый набор?

думаю, что надо отлавливать события добавления объекта в БД чертежа и собирать в набор/коллекцию/список. А перед копированием сбрасывать этот набор или какой-то флаг работы/блокировки. Тогда это будет отслеживать и копирование с других чертежей тоже.

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

Сообщение от Lavrentiy Вот, можно-ли выделить программно этот новый набор?

Теоретически можно. КОмандный реактор, перед выполнением запоминаем последний примитив, после выполнения - через entnext получаем все, что было скопировано. Кстати, на форуме решения подобных задач были (если не ошибаюсь, львиную долю разрабатывал VVA).

[Сергей812]

Пример, как решается схожая задача - получить идентификаторы всех объектов (ObjectId), вставленных через буфер обмена - от Александра Ривилиса на Net.

[macros55]

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

[gnuvse]

Здравствуйте.

Я новичок.

Специалисты, подскажите пожалуйста.

Как из однострочного текста получить содержимое при помощи программы на autolisp?

Т.е. есть текст "100", как мне в переменную получить этот текст.

Спасибо за помощь и ваше время.

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

[skkkk]

Код:

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

(vl-load-com)
(setq txt (vla-get-TextString (vlax-ename->vla-object (car (entsel "\nУкажите текст: ")))))

[gnuvse]

Спасибо большое за помощь.

Пожалуйста, если вас не затруднит, где я могу прочитать об этих vla функциях подробно?

Скажите, правильно ли я понимаю, если я буду использовать vla-get-любое_название_из_свойств, то я получу эти данные?

Сообщение от skkkk skkkk

[AMDen]

Здравствуйте!
В лиспе практически не разбираюсь.
По примерам и наитию смог сделать простенький код (не судите строго).

Код:

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

(defun c:RBV_IE ( / )
(command "._draworder" (ssget "_x" '((0 . "DIMENSION"))) "" "_f")
(command "._draworder" (ssget "_x" '((0 . "INSERT")(8 . "Блоки"))) "" "_f")
(command "._draworder" (ssget "_x" '((0 . "*LEADER"))) "" "_f")
(princ))

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

[gomer]

Код:

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

 ((lambda (ss) (if ss (command "._draworder" ss "" "_f"))) (ssget "_x" '((0 . "DIMENSION"))))

[AMDen]

gomer, Большое Спасибо! Так действительно лучше.

[Maksim7enov]

Здравствуйте! Сначала самое главное, я еще полный чайник в ЛИСПе))
Не так давно начал заниматься ЛИСПом и прошу Вашей помощи. Решил начать с малого, а именно построения трубы по уклону с заданным масштабом для помощи мне строить продольный профиль сетей водоснабжения и водоотведения.
В принципе работает, но накосячил с отключением привязки (для повторения использовал while, после того как завершаю выполнение программы привязка не возвращается. Понимаю почему но не могу понять как можно вернуть старую привязку old_value).
Так же решил, чтобы не вводить в ручную выбор 1-ой отметки применить выбор текста в котором эта отметка пишется на профиле. Тут проблема в том, что есть вариант того что можно просто промахнуться при выборе текста. Пытался воспользоваться if, но не получается. Думаю надо написать условие: если промахнулся то вводи в ручную. Пробовал но выдает ошибку.
Проблема с текстом тоже бывает всплывает. В другом файле текст вставляет не отметку которую я рассчитал а 90 т.е угол на который я хочу поворачивать.

Код:

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

(Defun C:Profil ()
    (prompt "\nРасcчитаем и построим трубу по уклону ")
(setq old_value (getvar 'osmode))
  		(setvar 'osmode 32)
(setq otm_V (getdist "\nВводи отметку вычита: <32> " ))
    		(if (= otm_V nil) (setq otm_V 32))				;при применении надо менять на ту которая по факту
  (while
(setq otm_Z (atof (cdr (assoc 1 (entget (car (entsel "\nВыбирай отметку : "))))))) ;выбираем текст с отметкой, чтобы не вводить в ручную
(setq p1 (getpoint " \nВводи расстояния между участками: ")) 		           ;выбираем расстояние участка трубопровода проложенного по 1 уклону
(setq p3 (getpoint ""))
 		(setq rasst (DISTANCE p1 p3 ))					   ;Узнаем расстояние участка
(setq uklon (getdist "\nВведи уклон трубы: " ))					   ;вводим уклон
(setq rasch1 (* (/ (- otm_Z otm_V) 2) 10))
  	(setvar 'osmode 0)
(setq p2 (mapcar '+ p1 (list 0 rasch1)))
(setq rasch2 (- otm_Z (* uklon rasst)))
(setq rasch3 (* (/ (- rasch2 otm_V) 2) 10))
(setq p4 (mapcar '+ p3 (list 0 rasch3)))
	(command "_line" p2 p4 "")
		(setvar 'osmode old_value)
(setq p4 (mapcar '- p1 (list 0 3.75)))
(setq p5 (mapcar '- p3 (list 0 3.75)))

 	(command "_text" "В" "НЦ"  p5 '1.25 '90 (rtos (+ (/ (* rasch3 2) 10) otm_V) 2 2) "")
 )
)

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

Сообщение от Maksim7enov В другом файле текст вставляет не отметку которую я рассчитал а 90 т.е угол на который я хочу поворачивать.

Значит в это файле другие настройки текущего текстового стиля.

[Maksim7enov]

Сообщение от Кулик Алексей aka kpblc Значит в это файле другие настройки текущего текстового стиля.

У меня есть динамический блок для профилей, в нем текст сделаю со стилем который будет работать нормально с лиспом. Зашел в файл вставил свой блок и выбрал стиль свой.
Все бьюсь с условием если промахнулся мимо выбора текста в данными о первой отметке. пробовал сделать так :
(if (= otm_Z nil) (getdist "\nВводи отметку вручную " ))
В итоге ошибка: неверный тип аргумента: lentityp nil

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

Если промахнулся, то entsel возвращает nil. (car nil) -> nil. А entget nil - ошибка.
Пройдись пошагово (http://autolisp.ru/2009/09/10/vlide-misc-01/ + http://autolisp.ru/2009/09/12/vlide-misc-02/)
И твой код с минимальными исправлениями - только отлов "промаха выбора".

Код:

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

 (defun c:profil (/ old_value otm_v otm_z p1 p2 p3 p4 p5 rasch1 rasch2 rasch3 rasst uklon)
  (prompt "\nРасcчитаем и построим трубу по уклону ")
  (setq old_value (getvar 'osmode))
  (setvar 'osmode 32)
  (setq otm_v (getdist "\nВводи отметку вычита: <32> "))
  (if (= otm_v nil)
    (setq otm_v 32)
    ) ;_ end of if
  ;; при применении надо менять на ту которая по факту
  (while (and (setq otm_z (car (entsel "\nВыбирай отметку : ")))
              (setq otm_z (atof (cdr (assoc 1 (entget otm_z)))))
              ) ;_ end of and
    ;; выбираем текст с отметкой, чтобы не вводить в ручную
    (setq p1 (getpoint " \nВводи расстояния между участками: "))
    ;; выбираем расстояние участка трубопровода проложенного по 1 уклону
    (setq p3 (getpoint ""))
    (setq rasst (distance p1 p3))
    ;; Узнаем расстояние участка
    (setq uklon (getdist "\nВведи уклон трубы: "))
    ;; вводим уклон
    (setq rasch1 (* (/ (- otm_z otm_v) 2) 10))
    (setvar 'osmode 0)
    (setq p2 (mapcar '+ p1 (list 0 rasch1)))
    (setq rasch2 (- otm_z (* uklon rasst)))
    (setq rasch3 (* (/ (- rasch2 otm_v) 2) 10))
    (setq p4 (mapcar '+ p3 (list 0 rasch3)))
    (command "_line" p2 p4 "")
    (setvar 'osmode old_value)
    (setq p4 (mapcar '- p1 (list 0 3.75)))
    (setq p5 (mapcar '- p3 (list 0 3.75)))
    (command "_text" "В" "НЦ" p5 '1.25 '90 (rtos (+ (/ (* rasch3 2) 10) otm_v) 2 2) "")
    ) ;_ end of while
  ) ;_ end of Defun

[Maksim7enov]

Сообщение от Кулик Алексей aka kpblc Пройдись пошагово (http://autolisp.ru/2009/09/10/vlide-misc-01/ + http://autolisp.ru/2009/09/12/vlide-misc-02/)

Спасибо! Сейчас начну изучать. Я так понял у меня и по оформлению 2)))

----- добавлено через ~2 ч. -----
Очень полезные ссылки. По оформлению понял [Ctrl]+[Shift]+[f] помогает.
Про промах при выборе делаю вывод, что на данном этапе изучения промах=расстрелу)
Так же хотелось бы узнать, может кто-то готов потратить свои силы и время на еще одного чайника?)))

[Inferi]

День добрый, помогите решить проблему:
1) применяю mapcar для извлечения из списка мультивыносок свойство "TextString" >
2) для некоторых из них вылетает ошибка: Ошибка Automation. Отсутствует описание. в связи с этим все крешится
3) дамп выноски выдающей ошибку:
; IAcadMLeader: Интерфейс мультивыносок AutoCAD
; Значения свойств:
; Application (RO) = #<VLA-OBJECT IAcadApplication 000000013f803318>
; ArrowheadBlock = "_Open"
; ArrowheadSize = 300.0
; ArrowheadType = 6
; BlockConnectionType = 0
; BlockScale = 1.0
; ContentBlockName = ""
; ContentBlockType = 6
; ContentType = 0
; Document (RO) = #<VLA-OBJECT IAcadDocument 00000000291e89d8>
; DogLegged = -1
; DoglegLength = 0.0
; EntityTransparency = "ПоСлою"
; Handle (RO) = "9205A"
; HasExtensionDictionary (RO) = 0
; Hyperlinks (RO) = #<VLA-OBJECT IAcadHyperlinks 00000000433cba98>
; LandingGap = 2.0
; Layer = "АР лестница"
; LeaderCount (RO) = 1
; LeaderLineColor = #<VLA-OBJECT IAcadAcCmColor 00000000433cbd90>
; LeaderLinetype = "ByBlock"
; LeaderLineWeight = -2
; LeaderType = 1
; Linetype = "ByLayer"
; LinetypeScale = 50.0
; Lineweight = -1
; Material = "ByLayer"
; ObjectID (RO) = 95928
; ObjectID32 (RO) = 95928
; ObjectName (RO) = "AcDbMLeader"
; OwnerID (RO) = 116635
; OwnerID32 (RO) = 116635
; PlotStyleName = "ByLayer"
; ScaleFactor = 1.0
; StyleName = "Копия(4) Standard"
; TextAttachmentDirection = 0
; TextBackgroundFill = Ошибка
; TextBottomAttachmentType = 0
; TextDirection = Ошибка
; TextFrameDisplay = 0
; TextHeight = 4.0
; TextJustify = Ошибка
; TextLeftAttachmentType = 1
; TextLineSpacingDistance = Ошибка
; TextLineSpacingFactor = Ошибка
; TextLineSpacingStyle = Ошибка
; TextRightAttachmentType = 3
; TextRotation = Ошибка
; TextString = Ошибка
; TextStyleName = Ошибка
; TextTopAttachmentType = 0
; TextWidth = Ошибка
; TrueColor = #<VLA-OBJECT IAcadAcCmColor 00000000433cbbb0>
; Visible = -1
4) какого типа функции стоит применить для решения проблемы?

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

У тебя на выноске - блок. См.свойство ContentType

[100k]

https://openedu.ru/course/ITMOUniversity/FPBC/
Функциональное программирование: базовый курс
В курсе изучаются основы функционального подхода к программированию и практические вопросы программирования на языке Lisp. Функциональные языки обладают множеством интересных особенностей, знакомство с которыми расширяет кругозор программиста. Курс содержит видеолекции, опросы и практические задания по программированию. Материал курса рассчитан на 10 недель обучения.

[Сергей812]

только это Common Lisp, а не AutoLisp - насколько понимаю.

[Maksim7enov]

Сообщение от 100k https://openedu.ru/course/ITMOUniversity/FPBC/ Функциональное программирование: базовый курс В курсе изучаются основы функционального подхода к программированию и практические вопросы программирования на языке Lisp. Функциональные языки обладают множеством интересных особенностей, знакомство с которыми расширяет кругозор программиста. Курс содержит видеолекции, опросы и практические задания по программированию. Материал курса рассчитан на 10 недель обучения.

Цена вопроса не указана

[Сергей812]

Maksim7enov,

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

[Maksim7enov]

Сообщение от Сергей812 Maksim7enov,

Ну тогда я говорю спасибо!

[AlexV]

Offtop: "Не учите меня жить, помогите материально! ©"

Товарищи знатоки, есть такая хорошая программка, "меняющая" выбранные примитивы на выбранный пользователем (код ниже), работает беспроблемно автокада что ль с 2000 у меня.. А нельзя ли ея модернизировать так, что бы у вставляемых примитивов назначалась координата Z, взятая из заменяемого примитива? Хотя бы только для блоков?

Код:

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

 ;Программа меняет набор примитивов на выбранный примитив.
;Примеры применения:

;Замена одних блоков другими.
;Замена точек блоками или окружностями.
;Замена одних надписей другими.


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



(defun c:frto(/ ACTDOC COPOBJ ERRCOUNT EXTLST
       EXTSET FROMCEN LAYCOL MAXPT CURLAY
       MINPT OBJLAY OKCOUNT OLAYST
       SCLAY TOCEN TOOBJ VLAOBJ *ERROR*)

  (vl-load-com)

  (defun *ERROR*(msg)
    (if olaySt
      (vla-put-Lock objLay olaySt)
      ); end if
    (vla-EndUndoMark actDoc)
    (princ)
    ); end of *ERROR*


  (defun GetBoundingCenter(vlaObj / blPt trPt cnPt)
  (vla-GetBoundingBox vlaObj 'minPt 'maxPt)
      (setq blPt(vlax-safearray->list minPt)
      trPt(vlax-safearray->list maxPt)
      cnPt(vlax-3D-point
      (list
            (+(car blPt)(/(-(car trPt)(car blPt))2))
            (+(cadr blPt)(/(-(cadr trPt)(cadr blPt))2))
         0.0
            ); end list
     ); end vlax-3D-point
    ); end setq
  ); end of GetBoundingCenter

  (if(not(setq extSet(ssget "_I")))
    (progn
      (princ "\n+++ Выберите заменяемые объекты <- ")
      (setq extSet(ssget))
      ); end progn
    ); end if
  (if(not extSet)
    (princ "\nDistination objects isn't selected!")
    ); end if
  (if
    (and
    extSet
    (setq toObj(entsel "\n+++ Выберите заменяющий объект -> "))
    ); and and
    (progn
      (setq actDoc
       (vla-get-ActiveDocument
         (vlax-get-Acad-object))
      layCol
       (vla-get-Layers actDoc)
      extLst
       (mapcar 'vlax-ename->vla-object
                    (vl-remove-if 'listp
                     (mapcar 'cadr(ssnamex extSet))))
      vlaObj(vlax-ename->vla-object(car toObj))
      objLay(vla-Item layCol
          (vla-get-Layer vlaObj))
      olaySt(vla-get-Lock objLay)
      fromCen(GetBoundingCenter vlaObj)
      errCount 0
      okCount 0
      ); end setq
      (vla-StartUndoMark actDoc)
      (foreach obj extLst
  (setq toCen(GetBoundingCenter obj)
        scLay(vla-Item layCol
           (vla-get-Layer obj))
           );end setq
  (if(/= :vlax-true(vla-get-Lock scLay))
    (progn
    (setq curLay(vla-get-Layer obj))
    (vla-put-Lock objLay :vlax-false)
    (setq copObj(vla-copy vlaObj))
    (vla-Move copObj fromCen toCen)
    (vla-put-Layer copObj curLay)
    (vla-put-Lock objLay olaySt)
    (vla-Delete obj)
    (setq okCount(1+ okCount))
    ); end progn
    (setq errCount(1+ errCount))
    ); end if
  ); end foreach
      (princ
  (strcat "\n" (itoa okCount) " were changed. "
    (if(/= 0 errCount)
      (strcat (itoa errCount) " were on locked layer! ")
      ""
      ); end if
    ); end strcat
  ); end princ
      (vla-EndUndoMark actDoc)
      ); end progn
    (princ "\nSource object isn't selected! ")
    ); end if
  (princ)
  ); end of c:frto

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

Код:

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

 ;|
*    Программа меняет набор примитивов на выбранный примитив.
*    Примеры применения:
   - Замена одних блоков другими.
   - Замена точек блоками или окружностями.
   - Замена одних надписей другими.
   
*    Сначала надо выбрать заменяемые объекты и нажать Enter, затем указать заменяющий объект.
* Вставка производится в центр ограничевающего (габаритного) прямоугольника старых объектов.
* Новые объекты вставляются в слои которые к которым пренадлежали старые объекты.
* Поддерживается предварительный выбор.
|;

(defun c:frto (/ actdoc copobj errcount extlst extset fromcen laycol maxpt curlay minpt objlay okcount olayst sclay tocen toobj vlaobj *error*)
  (vl-load-com)
  (defun *error* (msg)
    (if olayst
      (vla-put-lock objlay olayst)
      )   ; end if
    (vla-endundomark actdoc)
    (princ)
    )     ; end of *ERROR*
  (defun getboundingcenter (obj / minpt maxpt)
    (vla-getboundingbox obj 'minpt 'maxpt)
    (setq minpt (vlax-safearray->list minpt)
          maxpt (vlax-safearray->list maxpt)
          ) ;_ end of setq
    (mapcar '(lambda (a b) (* 0.5 (+ a b))) minpt maxpt)
    ) ;_ end of defun
  (if (not (setq extset (ssget "_I")))
    (progn (princ "\n+++ Выберите заменяемые объекты <- ") (setq extset (ssget)))
    )     ; end if
  (if (not extset)
    (princ "\nDistination objects isn't selected!")
    )     ; end if
  (if (and extset (setq toobj (entsel "\n+++ Выберите заменяющий объект -> ")))
    (progn (setq actdoc   (vla-get-activedocument (vlax-get-acad-object))
                 laycol   (vla-get-layers actdoc)
                 extlst   (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex extset))))
                 vlaobj   (vlax-ename->vla-object (car toobj))
                 objlay   (vla-item laycol (vla-get-layer vlaobj))
                 olayst   (vla-get-lock objlay)
                 fromcen  (getboundingcenter vlaobj)
                 errcount 0
                 okcount  0
                 ) ; end setq
           (vla-startundomark actdoc)
           (foreach obj extlst
             (setq tocen (getboundingcenter obj)
                   sclay (vla-item laycol (vla-get-layer obj))
                   ) ;end setq
             (if (/= :vlax-true (vla-get-lock sclay))
               (progn (setq curlay (vla-get-layer obj))
                      (vla-put-lock objlay :vlax-false)
                      (setq copobj (vla-copy vlaobj))
                      (vla-move copobj fromcen tocen)
                      (vla-put-layer copobj curlay)
                      (vla-put-lock objlay olayst)
                      (vla-delete obj)
                      (setq okcount (1+ okcount))
                      ) ; end progn
               (setq errcount (1+ errcount))
               ) ; end if
             ) ; end foreach
           (princ (strcat "\n"
                          (itoa okcount)
                          " were changed. "
                          (if (/= 0 errcount)
                            (strcat (itoa errcount) " were on locked layer! ")
                            ""
                            ) ; end if
                          ) ; end strcat
                  ) ; end princ
           (vla-endundomark actdoc)
           ) ; end progn
    (princ "\nSource object isn't selected! ")
    )     ; end if
  (princ)
  )       ; end of c:frto

Код не чистил и не проверял.

[Titli-pytli]

Помогите пожалуйста. Есть ли возможность получать (выбирать точку в пространстве модели автокада) с привязкой (угловой и размерной) от предыдущей выбранной точки (getpoint) ? Желательно так же, как при построении полилинии.


з.ы. Как выудить координату конца обычного цилиндра (_cylinder)?

[VVA]

Сообщение от Titli-pytli Есть ли возможность получать (выбирать точку в пространстве модели автокада) с привязкой (угловой и размерной) от предыдущей выбранной точки (getpoint)

Titli-pytli, polar?
Для пользователя читать про Относительные координаты в Автокаде

[kurstep]

Подскажите пожалуйста как выбрать на чертеже (с подсветкой на экране ) объект по vla- указателю ?

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

Подсветка с ручками или без? Если без, то vla-highlight в помощь. Если с ручками - то преобразовать vla в ename, добавить ename в набор и потом sssetfirst.

[Titli-pytli]

Сообщение от VVA Titli-pytli, polar? Для пользователя читать про Относительные координаты в Автокаде

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

И еще:
Почему функция (vlax-get-property obg "PrincipalDirections") возвращает одни и те же единичные вектора главных направлений для разных цилиндров (повернутых в разные направления вдоль главных координатных осей)?
Для цилиндра с осью вдоль оси X координаты векторов (1.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 1.0)
Для цилиндра с осью вдоль оси Y координаты векторов (1.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 1.0)
Не поверите, но вдоль оси Z тоже самое.
Как вообще узнать в каком направлении он повернут? Ну или может быть есть какой нибудь другой способ узнать координату конца цилиндра? Протыкал все примитивы в его составе, но так и не нашел.

[Inferi]

Доброго времени суток, может кто подскажет как преобразовать список вида:
'((1 3 2) (1 2) (6 4 5) (6 5)) -> '((1 3 2) (6 4 5))
По смыслу, если элемент списка содержится в другом списке, то удаляем элемент в сравниваемом списке

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

В другом или в следующем?

[Inferi]

Во всех последующих, список может быть длинней 4х:
'((25 50 100 300 200) (25 50 100 200) (25 50 100) (25 50) (700 600 400 500) (700 600 500) (700 600))

На выходе нужно получить максимально объединенные подсписки:
'((25 50 100 300 200)(700 600 400 500))

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

Сильно хочется задать провокационный вопрос: а каков должен быть результат для списка

'((25 50 100 300 200) (25 50 100 200) (25 50 100 700 600) (25 50) (700 600 400 500) (700 600 200 25 500) (700 600))

[Inferi]

Список тот что я обрабатываю можно разделить на два: значения элементов подсписков первого списка уникальны, и не встречаются во втором подсписке. Возможно я все усложняю. Вообще исходные данные такие:
1. есть список уникальных координат, лежащих на полилиниях (отмечены красным на рисунке)
2. есть список наложенных полилиний
Половина уникальных координат встречается в каждой полилинии в своей половине списка. Мне нужно получить две группы полилиний, по признаку принадлежности к своей половине уникальных координат.

Я пробегался foreach по координатам полилиний, и с помощью member и vl-remove-if-not получил список с именами полилиний, но проблема в том что нужно список '((имя_полилинии1 имя_полилинии2 имя_полилинии3) (имя_полилинии2 имя_полилинии3) (имя_полилинии4 имя_полилинии5 имя_полилинии6) (имя_полилинии5 имя_полилинии6)) преобразовать в '((имя_полилинии1 имя_полилинии2 имя_полилинии3)(имя_полилинии4 имя_полилинии5 имя_полилинии6))

[Fedorino]

Здравствуйте!
Будьте добры, подскажите, как с помощью лиспа, при простановке размера, задавать длину выносных линий?
Т.е. иными словами как задавать отступ размерной линии от виртуальной прямой проходящей между двумя точками размера.

[Setvar]

Я пользуюсь примерно такими кодами (выдрано из рабочей программы):

Код:

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

;;; Для горизонтального параллельного размера
;;; Нарисован, например, прямоугольник.
;;; Указываем левый нижний угол и правый нижний угол.
(defun C:FAR ( / osm dp1 dp2 dp3)
(setq osm (getvar "OSMODE"))
(setvar "OSMODE" 32) ;;; Пересечение
(setq dp1 (getpoint "\nПервая точка на объекте: "))
(setq dp2 (getpoint "\nВторая точка на объекте: "))
(setq dp12 (list (/ (+ (nth 0 dp1) (nth 0 dp2)) 2) (- (nth 1 dp1) 1000)))
(vl-cmdf "_DIMALIGNED" ""  "_m2P" dp1  dp2 dp12)
(setvar "OSMODE" osm)
(princ)
)

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

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

Сообщение от Fedorino как задавать отступ размерной линии от виртуальной прямой проходящей между двумя точками размера.

Самый простой вариант - использовать преднастроенный размерный стиль. Ну или уже сам объект размера редактировать.

----- добавлено через 10 сек. -----
Насчет второго не уверен.

[Fedorino]

Сообщение от Кулик Алексей aka kpblc. Самый простой вариант - использовать преднастроенный размерный стиль. Ну или уже сам объект размера редактировать.

В настройках размерного стиля, есть возможность задавать длину отображения выносной линии, но никак не отступ.
В самом объекте данный параметр заблокирован для редактирования(при просмотре через vlax-dump-object, рядом со значением стоит (RO)).
Есть мысль расчитывать третью(последнюю) точку, указываемую при построении размера, но это слишком сложные геометрические вычисления.

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

Сообщение от Fedorino В настройках размерного стиля, есть возможность задавать длину отображения выносной линии, но никак не отступ.

А это что?

[Setvar]

А это вот что:
Из Справки.
Отступ от объекта
Указывает расстояние, на которое выносные линии отступают от точек объекта. (Системная переменная DIMEXO)
Автор темы напрасно применил термин "отступ".

Сообщение от Fedorino Есть мысль расчитывать третью(последнюю) точку, указываемую при построении размера, но это слишком сложные геометрические вычисления.

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

[Fedorino]

Сообщение от Setvar А это вот что: Из Справки. Отступ от объекта Указывает расстояние, на которое выносные линии отступают от точек объекта. (Системная переменная DIMEXO)

Да, я не это имел ввиду.

Сообщение от Setvar Автор темы напрасно применил термин "отступ".

Не в совершенстве владею терминологией, возможно ввел кого-то в заблуждение.

Сообщение от Setvar В моем примере как раз вычисляется точка положения размерной линии. Так что твоя мысль опоздала.

Извини, я почему-то не сразу твой код заметил. Сейчас проанализировал, есть интересные моменты, но если объект поворачивать на определенный угол, то размеры пляшут.

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

У меня задача - создать лисп, позволяющий проставлять размеры с выносными линиями фиксированной длины, которую можно задавать. В том числе указывать направление построения размера, кликом мыши.

----- добавлено через ~4 ч. -----
Кстати получилось, проставлять размеры с фиксированной длиной выносных линий, способом вычисления третьей точки.
Выкладываю тестовый код, может кому пригодится, без проверок на пустой ввод и функции ошибки.
Тестил мало, возможно есть ошибки.

Код:

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

 (defun c:test (/ pnt1 pnt2 x5 y5 pnt3 pnt4 rs pnt5)
	(repeat 15
			(setvar "osmode" 1)
			(if (not rs) (setq rs (getreal "\nУкажите длину выносных линий: ")))
			(setq pnt1 (getpoint "\nУкажите первую точку размера: "))
			(setq pnt2 (getpoint pnt1 "\nУкажите вторую точку размера: "))
			(setvar "osmode" 0)
			(setq pnt3 (list (/ (+ (car pnt1) (car pnt2)) 2) (/ (+ (car (cdr pnt1)) (car (cdr pnt2))) 2) 0.0))
			(setvar "ORTHOMODE" 0)
			(setq pnt4 (getpoint pnt3 "\nУкажите направление построения: "))
			(cond 
				((= (rtos 0 2 4) (rtos (angle pnt1 pnt2) 2 4))
					(setq x5 (car pnt3))
					(if (< (car (cdr pnt3)) (car (cdr pnt4))) (setq y5 (+ (car (cdr pnt1)) rs)) (setq y5 (- (car (cdr pnt1)) rs)))
				)
				((or (eq (rtos 1.5708 2 4) (rtos (angle pnt1 pnt2) 2 4)) (eq (rtos 4.71239 2 4) (rtos (angle pnt1 pnt2) 2 4)))
					(if (< (car pnt3) (car pnt4)) (setq x5 (+ (car pnt1) rs)) (setq x5 (- (car pnt1) rs)))
					(setq y5 (car (cdr pnt3)))
				)
				((and (/= (rtos 1.5708 2 4) (rtos (angle pnt1 pnt2) 2 4)) (/= (rtos 0 2 4) (rtos (angle pnt1 pnt2) 2 4)))
					(if (< (car pnt3) (car pnt4)) (setq x5 (+ (car pnt3) (* rs (abs (sin (angle pnt1 pnt2)))))) (setq x5 (- (car pnt3) (* rs (abs (sin (angle pnt1 pnt2)))))))		
					(if (< (car (cdr pnt3)) (car (cdr pnt4))) (setq y5 (+ (car (cdr pnt3)) (* rs (abs (cos (angle pnt1 pnt2)))))) (setq y5 (- (car (cdr pnt3)) (* rs (abs (cos (angle pnt1 pnt2)))))))
				)
			)			
			(setq pnt5 (list x5 y5 0.0))
			(vl-cmdf "_dimaligned" pnt1 pnt2 pnt5)
	)
)

[Wolkodaw]

Добрый вечер! Возможно ли в LISPе реализовать двойную сортировку и как это сделать (только средствами Active X)? Например, имеется набор блоков с разными именами. Программа выделяет все блоки, сортирует их сначала по наименованию, а затем, внутри каждого списка блоков с одинаковым именем, еще и по длине. То есть список получается типа (А длиной 200, А длиной 100, Б длиной 500, Б длиной 50).

[skkkk]

Я бы делал наоборот: сначала выбрал уникальные этой функцией, а затем отсортировал по наименованию.

[Setvar]

Для Wolkodaw.
Что такое "длина" блока?
Как это могут быть блоки с одним и тем же именем, но разной "длиной"?

[Сергей812]

Сообщение от Setvar Как это могут быть блоки с одним и тем же именем, но разной "длиной"?

Линейный параметр в динблоке, например

[Setvar]

Сергей812, а ты разве Wolkodaw?

[Сергей812]

Сообщение от Setvar Сергей812, а ты разве Wolkodaw?

здесь общий форум)

[gnuvse]

Здравствуйте, есть вот такая программа.

Код:

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

 
; Cуммирование текста вер. 0.0.1
; 
;

(defun c:sum()
  (setq flag 1)
  (setq sum 0)

  (while (/= flag 0)
    (setq txt (vla-get-TextString (vlax-ename->vla-object (car (entsel "\nУкажите текст: ")))))
    (princ "\n")
    (setq sum (+ sum (atof txt)))
    (princ sum)
  )
)

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

В Си бы я сделал вот так

Код:

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

 
// -*C*-
#include <stdio.h>
#include <string.h>
#include <stdlib.h>



int main()
{

    char *str = "15,9";
    char new_str[strlen(str)];
    unsigned int i;

    for (i = 0; i < strlen(str); i++)
        if (str[i] == ',')
            new_str[i] = '.';
        else
            new_str[i] = str[i];
    new_str[i] = '\0';

    double num = atof(new_str);
    printf("%f\n", num);

    return 0;
}

Как так же провернуть в AutoLisp?

Спасибо за ваше время

[Сергей812]

vl-string-translate ?

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

Скорее уж vl-string-subst

[gnuvse]

Сообщение от Сергей812 vl-string-translate ?

Сообщение от Кулик Алексей aka kpblc Скорее уж vl-string-subst

Спасибо, что ответили, именно vl-string-subst, в тот же день нашел ответ на свой вопрос в справочнике Полещука.
Впредь буду туда заглядывать.

[Red Nova]

Доброго. Вопрос про обработку ошибок.
При нажатии esc в каком случае может выход из команды произойти не через *error* ?
Для моего кода если Vlide закрыт то при esc обработка ошибок не происходит, если Vlide открыт то при esc либо Vlide зависает либо после многократного нажатия esc вычисления останавливаются и приходится выходить через Debug - reset to top level.
Код обрабатывает очень длинные списки.

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

Поскольку код не показан, могу порекомендовать:
а) исключить рекурсию
б) найти в "Библиотеке функций" обработчик ошибок (нечто типа _dwgru-catch-error) и использовать именно его.

[Red Nova]

Попытаюсь вечером почистить код и привести пример.
_dwgru-catch-error кстати не нашел, но до error дело просто не доходит.

[Red Nova]

Вот более менее короткий пример и файл в котором следует тестировать.
После вызова test нужно задать 3 точки, очередность указана в файле.
Если по середине процесса нажать esc, то *error* не сработает.

[VVA]

Сообщение от Red Nova _dwgru-catch-error кстати не нашел, но до error дело просто не доходит

dwgru-error-catch - Как организовать досрочный выход из цикла?

[Red Nova]

Спасибо за ссылку.
Подскажите плиз как именно мне следует использовать dwgru-error-catch?
Скажем у меня проблема в цикле while.
Вот участок кода

Код:

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

 (while (not (= QDeckNormal 0))
	  (command "_.COPY" CSNormalblk "" "0,0" (strcat "0," (rtos (* -24 ScaleFactor))))
	  (setq QDeckNormal (- QDeckNormal 1))
	  (setq CSNormalblk (entlast))
	  )

Пока тут идут вычисления пользователь нажал esc. Требуется выйти через *error*.
Пробую подставить весь while под dwgru-error-catch

Код:

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

 (dwgru-error-catch
	(while 
.............
    )
	nil
	)

Моей задаче это не помогло.

Вообще я наивно полагал что при esc выход всегда через *error*, а тут нет. Почему так?

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

Red Nova, ты не поверишь, но считай весь твой код надо переделывать (это если по-хорошему )
Основной вопрос - тебе обязательно применение прямоугольника или можно обойтись без привязок?

----- добавлено через ~29 мин. -----
О, кстати! Обрати внимание на строку

Код:

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

 (progn (alert "Too narrow for a Bay") (*error*))

ничего странного не замечаешь? ))

----- добавлено через ~50 мин. -----
Еще момент - сделай блок безразмерным и тогда не надо будет мучаться с масштабами.

[Red Nova]

Сообщение от Кулик Алексей aka kpblc Red Nova, ты не поверишь, но считай весь твой код надо переделывать (это если по-хорошему )

Поверю. Ломай меня полностью. Только давай если можно разделим на 2 части.
1. Вариант по хорошему, с переделкой по полной программе.
2. Вариант полегче. Хоть какой костыль чтоб error заработала.
Основная проблема не именно в этом коде. Я просто выбрал тот что покороче и поменьше вложенных функций.
У меня десятки схожих кодов более сложной конструкции.

Сообщение от Кулик Алексей aka kpblc Основной вопрос - тебе обязательно применение прямоугольника или можно обойтись без привязок?

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

Сообщение от Кулик Алексей aka kpblc О, кстати! Обрати внимание на строку Код: (progn (alert "Too narrow for a Bay") (*error*))

Верно. Приписал nil

Код:

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

 (progn (alert "Too narrow for a Bay") (*error* nil))

Сообщение от Кулик Алексей aka kpblc Еще момент - сделай блок безразмерным и тогда не надо будет мучаться с масштабами.

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

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

М-да... Тогда все мои переделки можно смело выбрасывать
В качестве пожеланий (и прошу не рассматривать ссылки как рекламу):

1. Не контролируется наличие слоя, на который надо помещать блоки
2. Не контролируется - а есть ли в файле вообще такой блок
3. Только INSUNITS учитывать недостаточно. Во-первых, у нее чуть больше чем два значения. Во-вторых, INSUNITS совсем необязательно коррелирует с INSUNITSDEFSOURCE, INSUNITSDEFTARGET, MEASUREMENT, LUNITS и параметрами, регулируемым командой _.dwgunits. И до фига чем еще.
4. Вычисления (особенно длительные) лучше делать с прогресс-баром.
5. Постарайся вообще не использовать командные методы - они самые медленные. Намного быстрее будет создать определение анонимного блока, в него выполнять вставку объектов с заранее вычисленными параметрами, а потом уже выполнять его вставку, разбитие и (возможно) уничтожение.
6. Если таких кодов "десятки", постарайся использовать все же не *error*, а другие способы. Частенько они становятся более внятными и предсказуемыми.
7. Настоятельно рекомендую решить - то ли ты пишешь код для работы только в мировой системе координат, то ли в любой. Второй подход может значительно усложнить решение.

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

[Red Nova]

Спасибо за ответ.

Не контролируется наличие слоя, на который надо помещать блоки Не контролируется - а есть ли в файле вообще такой блок Только INSUNITS учитывать недостаточно. Во-первых, у нее чуть больше чем два значения. Во-вторых, INSUNITS совсем необязательно коррелирует с INSUNITSDEFSOURCE, INSUNITSDEFTARGET, MEASUREMENT, LUNITS и параметрами, регулируемым командой _.dwgunits. И до фига чем еще.

В идеале согласен. Поскольку по факту учил лисп в процессе то пошел более легким путем. Делаю соответствующий шаблон и работаю в нем.

Вычисления (особенно длительные) лучше делать с прогресс-баром.

Нужно почитать.

Постарайся вообще не использовать командные методы - они самые медленные.

Что командные методы - самые медленные знаю. Но поскольку само построение сравнительно недолгое то на это забил.

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

Хорошая идея. Нужно потыкать. Может использую в будущем.

Сообщение от Кулик Алексей aka kpblc Настоятельно рекомендую решить - то ли ты пишешь код для работы только в мировой системе координат, то ли в любой. Второй подход может значительно усложнить решение.

Сперва намеревался делать для любой. Потом встретил пару сучков и теперь все делаю под мировую систему координат.

Сообщение от Кулик Алексей aka kpblc Если таких кодов "десятки", постарайся использовать все же не *error*, а другие способы. Частенько они становятся более внятными и предсказуемыми.

Вот об этом прошу поподробнее.
Пока не понял что мне делать с основной задачей? Через *error* никак не выйти?

Сообщение от Red Nova Скажем у меня проблема в цикле while. Вот участок кода Код: (while (not (= QDeckNormal 0)) (command "_.COPY" CSNormalblk "" "0,0" (strcat "0," (rtos (* -24 ScaleFactor)))) (setq QDeckNormal (- QDeckNormal 1)) (setq CSNormalblk (entlast)) ) Пока тут идут вычисления пользователь нажал esc. Требуется выйти через *error*.

Почитаю вечером твою статью "Код без ошибок – возможно ли?" . Может что и переварю...

----- добавлено через ~2 ч. -----
Ну вот, добрался до дома, читаю твою статью и не пойму. Разве это мой случай?

Если попытаться вызвать (lispru-func-1), мы получим в консоли: call (fun_func-2) fun_func-2 error : divide by zero _$ То есть такой обработчик заканчивает выполнение функции - обратите внимание, текст "(fun_func-2) finished" даже не пытается напечататься: срабатывает обработчик, прописанный в fun_func-2, и на этом выполнение кода заканчивается. А если продолжать все равно надо? В таком случае приходит на помощь вариант 2: Использование функции vl-catch-*:

Мне и не нужно продолжать. Переход к моей локальной *error* у меня как раз и не происходит.
Давай забудем про мой предыдущий пример.
Вот специально под вопрос написал задачку, своеобразный светофор.
Создаю простой но требующий несколько секунд для исполнения цикл while. (5 миллионов простых вычислений у меня машина считает примерно за 5 секунд).

Код:

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

 (defun c:test ( / i var val *error*)
  (defun *error* ( msg )
    (mapcar 'setvar var val)
    (if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
                 (princ (strcat "\nError: " msg)))
    (vla-endundomark adoc)
    )

  (vl-load-com)
  (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
  
  (setq var '(clayer cecolor) 
        val  (mapcar 'getvar var))

  (setvar "cecolor" "1")
  (setq i 1)
  (while
    (< i 5000000)
    (setq i (1+ i))
    )
  (setvar "cecolor" "2")
  (*error* nil)
  )

Выставляем текущий цвет - Зеленый.
Вызываем test.
А. Если while и *error* отработали то на исходе цвет Зеленый (3).
Б. Если промеж цикла while что-то не так (к примеру если нажать escape) то на выходе цвет Красный (1) (ни while ни *error* не отработали).
В. Ну а если while отработала а до escape дело не дошло то выходе цвет Желтый (2).
С вариантами А и В все ясно. (В в такой постановке по сути и не достегаем)
Как быть с вариантом Б? Прошу привести решение.

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

Ну, как вариант (без проверок):

Код:

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

 (vl-load-com)
(defun c:test1 (/ adoc sysvars i)
  (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
  (princ (strcat "\nCeColor = " (getvar "cecolor")))
  (setq sysvars (vl-remove nil
                           (mapcar (function (lambda (x / tmp)
                                               (if (setq tmp (getvar (car x)))
                                                 (progn (if (cdr x)
                                                          (setvar (car x) (cdr x))
                                                          ) ;_ end of if
                                                        (cons (car x) tmp)
                                                        ) ;_ end of progn
                                                 ) ;_ end of if
                                               ) ;_ end of lambda
                                             ) ;_ end of function
                                   '(("cecolor" . "1"))
                                   ) ;_ end of mapcar
                           ) ;_ end of vl-remove
        i       0
        ) ;_ end of setq
  (princ (strcat "\nCeColor = " (getvar "cecolor")))
  (vl-catch-all-apply (function (lambda () (while (< 1 5e9) (setq i (1+ i))))))
  (setvar "cecolor" "2")
  (princ (strcat "\nCeColor = " (getvar "cecolor")))
  (foreach item sysvars (setvar (car item) (cdr item)))
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun

И ты так радостно готовишься к ошибке отмены, что аж оторопь берет

[Red Nova]

kpblc,
Спасибо. Постараюсь сделать костыль на основе vl-catch-all-apply.

На англоязычном форуме проверили мой код, дык у коллеги с Итальянским интерфейсом при escape по середине while *error* отрабатывает. А у меня нет. Баг акада?

Код:

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

 (defun c:test ( / i var val *error*)
  (defun *error* ( msg )
    (print (getvar "cecolor")) (princ " < color on start *error*")
    (mapcar 'setvar var val)
    (print (getvar "cecolor")) (princ " < color after mapcar *error*")
    (if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
                 (princ (strcat "\nError: " msg)))
    (vla-endundomark adoc)
    (print (getvar "cecolor")) (princ " < color after endundomar *error*")
  )
  (vl-load-com)
  (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
  (print (getvar "cecolor")) (princ " < color on start test")
  (setq var '(clayer cecolor)
        val  (mapcar 'getvar var))
  (setvar "cecolor" "1")
  (print (getvar "cecolor")) (princ " < color after cecolor 1")
  (setq i 1)
  (while
    (< i 5000000)
    (setq i (1+ i))
  )
  (setvar "cecolor" "2")
  (print (getvar "cecolor")) (princ " < color after cecolor 2")
  (*error* nil)
  (print (getvar "cecolor")) (princ " < color on end test")
)

Comando: TEST "3" < color on start test "1" < color after cecolor 1 "1" < color on start *error* "3" < color after mapcar *error* Error: Funzione annullata <<< ESC "3" < color after endundomar *error* Comando: test "3" < color on start test "1" < color after cecolor 1 "2" < color after cecolor 2 "2" < color on start *error* "3" < color after mapcar *error* "3" < color after endundomar *error* "3" < color on end test" < color on end test"

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

Может быть, дело в настройках среды

[Red Nova]

Неа, у меня галочка не стоит.
На theswamp мне подсказали заменить mapcar в *error* на foreach.
В начале это помогло (хотя почему mapcar приводило к ошибке так и не ясно). Переделанный код с #3437 заработал при нажатии escape.
Но я рано радовался. Попытался добавить в *error* изменение системы координат и *error* опать сломалась.

Command: TEST1 "3" < color on start test "1" < color after cecolor 1 "1" < color on start *error* "3" < color after variavle reset using foreach *error* "3" < color after endundomar *error* Command: Command: *Cancel*

Command: TEST2 "3" < color on start test "1" < color after cecolor 1ucs Current ucs name: *WORLD* Specify origin of UCS or [Face/NAmed/OBject/Previous/View/World/X/Y/Z/ZAxis] <World>: z Specify rotation angle about Z axis <90d0'0">: 45 Command: "UCS rotated" "1" < color on start *error* "3" < color after variavle reset using foreach *error*Function cancelled Command: *Cancel*

При этом оба кода работают нормально если не нажимать escape и дать коду отработать до конца.

Код:

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

 (defun c:test2 (/ i val *error*)
  (defun *error* (msg)
    (print (getvar "cecolor"))
    (princ " < color on start *error*")
    (foreach v val (setvar (car v) (cdr v)))
    (print (getvar "cecolor"))
    (princ " < color after variavle reset using foreach *error*")
    (command-s "_.ucs" "_w")
    (print "UCS reset *error*")
    (if	(and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
      (princ (strcat "\nError: " msg))
    )
    (vla-endundomark adoc)
    (print (getvar "cecolor"))
    (princ " < color after endundomar *error*")
  )
  (vl-load-com)
  (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
  (print (getvar "cecolor"))
  (princ " < color on start test")
  (setq val (mapcar (function (lambda (v) (cons v (getvar v)))) '("clayer" "cecolor")))
  (setvar "cecolor" "1")
  (print (getvar "cecolor"))
  (princ " < color after cecolor 1")
  (command "ucs" "z" "45")
  (print "UCS rotated")
  (setq i 1)
  (while (< i 5000000) (setq i (1+ i)))
  (setvar "cecolor" "2")
  (print (getvar "cecolor"))
  (princ " < color after cecolor 2 (while completed)")
  (*error* nil)
  (print (getvar "cecolor"))
  (princ " < color on end test")
)

(defun c:test1 (/ i val *error*)
  (defun *error* (msg)
    (print (getvar "cecolor"))
    (princ " < color on start *error*")
    (foreach v val (setvar (car v) (cdr v)))
    (print (getvar "cecolor"))
    (princ " < color after variavle reset using foreach *error*")
    (if	(and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
      (princ (strcat "\nError: " msg))
    )
    (vla-endundomark adoc)
    (print (getvar "cecolor"))
    (princ " < color after endundomar *error*")
  )
  (vl-load-com)
  (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
  (print (getvar "cecolor"))
  (princ " < color on start test")
  (setq val (mapcar (function (lambda (v) (cons v (getvar v)))) '("clayer" "cecolor")))
  (setvar "cecolor" "1")
  (print (getvar "cecolor"))
  (princ " < color after cecolor 1")
  (setq i 1)
  (while (< i 5000000) (setq i (1+ i)))
  (setvar "cecolor" "2")
  (print (getvar "cecolor"))
  (princ " < color after cecolor 2 (while completed)")
  (*error* nil)
  (print (getvar "cecolor"))
  (princ " < color on end test")
)

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

Offtop: Я бы постарался вообще обойтись без применения командных методов в *error*. Как-то не доверяю я подобному подходу...

[Red Nova]

Сообщение от Кулик Алексей aka kpblc Offtop: Я бы постарался вообще обойтись без применения командных методов в *error*. Как-то не доверяю я подобному подходу...

Совсем не оф топ. Поменял в error возврат к мировой ucs c command на activeX и вроде как пока что все работает

Код:

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

 (defun c:test (/ i val *error*)
  (defun *error* (msg)
    (print (getvar "cecolor"))
    (princ " < color on start *error*")
    (foreach v val (setvar (car v) (cdr v)))
    (print (getvar "cecolor"))
    (princ " < color after variavle reset using foreach *error*")
    (kb:UCS:NameWorld t)
    (print "UCS reset *error*")
    (if	(and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
      (princ (strcat "\nError: " msg))
    )
    (vla-endundomark adoc)
    (print (getvar "cecolor"))
    (princ " < color after endundomar *error*")
  )
  (vl-load-com)
  (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
  (print (getvar "cecolor"))
  (princ " < color on start test")
  (setq val (mapcar (function (lambda (v) (cons v (getvar v)))) '("clayer" "cecolor")))
  (setvar "cecolor" "1")
  (print (getvar "cecolor"))
  (princ " < color after cecolor 1")
  (command "ucs" "z" "45")
  (print "UCS rotated")
  (setq i 1)
  (while (< i 5000000) (setq i (1+ i)))
  (setvar "cecolor" "2")
  (print (getvar "cecolor"))
  (princ " < color after cecolor 2 (while completed)")
  (*error* nil)
  (print (getvar "cecolor"))
  (princ " < color on end test")
)

(defun kb:UCS:NameWorld (MakeActive / localUCS)
  (or g:activedoc (setq g:activedoc (vla-get-activedocument (vlax-get-acad-object))))
  (or g:ucss
      (setq g:ucss
             (vla-get-usercoordinatesystems (vla-get-activedocument (vlax-get-acad-object))
             )
      )
  )
  (setq localUCS (vla-add g:ucss
                          (vlax-3d-point '(0.0 0.0 0.0)) ;origin
                          (vlax-3d-point '(1.0 0.0 0.0)) ;x-axis
                          (vlax-3d-point '(0.0 1.0 0.0)) ;y-axis
                          "_WorldUCS"
                 )
  )
  (if MakeActive
    (vla-put-activeucs g:activedoc localUCS)
  )
  localUCS
)

Для себя сделал выводы.
в *error*
1. Не использовать mapcar
2. Не использовать командные методы.

Спасибо за помощь

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

Есть еще вариант - вообще отказаться от переопределения *error*

[mindchamber]

Подскажите пожалуйста как создать кнопку на загрузку лиспа в формате .fas?

Пробывал ^C^C load "NumeratorVertexPline01.fas" , почему-то не работает, хотя доверительную папку указал.

Спасибо.

[engngr]

^C^C(load "NumeratorVertexPline01.fas")

[Setvar]

Есть команда "_LOAD" ("ЗАГРУЗИТЬ") для для выбора и загрузки в чертеж файла форм и есть функция AutoLisp (load) для загрузки файла приложения.

[Titli-pytli]

Подскажите пожалуйста, как заставить редактор лиспа читать вот это "%<\AcVar SaveDate \f "MM.yy">%" как одну строку, а не как две и переменную MM.yy между ними?

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

Откуда считываешь? С текста/атрибута? Если да, кто мешает получать TextString, а не FieldCode?

[engngr]

Сообщение от Titli-pytli читать вот это "%<\AcVar SaveDate \f "MM.yy">%" как одну строку

Перед " поставить \ или \\?

[skkkk]

Надо перед всеми кавычками и обратными слэшами ставить обратный слэш.

[kurstep]

Здравствуйте, подскажите пожалуйста красивую и лаконичную функцию или еще лучше лямбда-функцию которая бы принимала два значения - количество элементов, и элемент - и выдавала список из одинаковых элементов:
то есть чтобы это работало так (func 5 "элемент") -> ("элемент" "элемент" "элемент" "элемент" "элемент")


Пробую так, почему-то не получается :

Код:

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

 ((lambda (count i / el) repeat count ( setq el (cons i el))) 5 "el")

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

Фигню-с написал.

----- добавлено через ~2 мин. -----
((LAMBDA(count i / res) (repeat count (setq res (cons i res))) res) 2 "i")

[Fedorino]

Здравствуйте! Такая проблема. Исходные данные:
имеется блок, прямоугольной формы, размерами допустим 100х100 мм, левая нижняя точка его лежит в начале координат 0,0,
имеется точка (setq pt '(50 50)).
Вопрос, как выяснить попадает ли точка в область блока или нет?
Решал с помощью ssget, ничего не помогает, везде nil.

Код:

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

 
(ssget pt) - nil
(ssget pt '((0 . "INSERT"))) - nil
(ssget "_F" (list pt (mapcar '+ '(1 1) pt))) - nil
(ssget "_F" (list pt (mapcar '+ pt  '(1 1)))) - nil
(ssget "_WP" (list pt (mapcar '+ '(1 1) pt))) - nil
(ssget "_WP" (list pt (mapcar '+ pt  '(1 1)))) - nil
(ssget "_CP" (list pt (mapcar '+ '(1 1) pt))) - nil
(ssget "_CP" (list pt (mapcar '+ pt  '(1 1)))) - nil
(ssget "_W" pt (mapcar '+ '(1 1) pt)) - nil
(ssget "_W" pt (mapcar '+ pt  '(1 1))) - nil
(ssget "_C" pt (mapcar '+ '(1 1) pt)) - nil
(ssget "_C" pt (mapcar '+ pt  '(1 1))) - nil

Если pt присвоить (setq pt (0 0)), то блок сразу попадает в набор.
Подскажите метод определяющий попадет ли точка в область блока!

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

Тут две задачи
1. Определить область блока. Вопрос на форуме поднимался, советую заняться поиском
2. Определить вхождение точки в контур (может быть, даже не существующий) - тоже поднимался на форуме. Опять же, поиск.

[Doctor_Che]

Здравствуйте, товарищи корифеи.
В лиспе не силён, попробовал оптимизировать работу из кусков кода, нашёл здесь на форуме и в интернете.
Сначала выходило вроде полезно. Но когда файл DWG разросся, то код оказался очень медленным.
Подскажите - можно ли как-то оптимизировать код, увеличить скорость работы?

Идея такая - код подсчитывает количество вхождений каждого вида блоков. Блоки динамические. Названия блоков могут быть типа: ИМЯ_БЛОКА_ХХ, где ХХ - версия блока.
На выходе получается: количество светильников - 25 шт., количество выключателей - 3 шт., количество розеток - 8 шт. и т.д.

Код:

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

 ;; (vl-load-com)

;;;Глобальная переменная имени блока светильника
(setq block_name_lamp "ЭО_Светильник")

;;;Глобальная переменная имени блока выключателя
(setq block_name_switch "ЭТО_Выключатель")

;;;Глобальная переменная для маски добавляемой к имени блока
(setq block_name_mask "_##")

;;;-----------------------------------------------------------------------------------------------;;;
;;;Функция замера времени выполнения кода;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;-----------------------------------------------------------------------------------------------;;;
(setq BenchStart nil)
(defun BenchTime (start / millisecs)
  (if start
    (setq BenchStart (getvar "Millisecs"))
    (if BenchStart
      (progn
        (princ (strcat "\nElapsed: " (rtos (* 0.001 (- (getvar "Millisecs") BenchStart)))))
        (setq BenchStart nil)
      )
      (princ "\nThere's an error. The bechmark wasn't started yet.")
    )
  )
  t
)

;;;-----------------------------------------------------------------------------------------------;;;
;; Get Anonymous References  -  Lee Mac
;; Returns the names of all anonymous references of a block.
;; blk - [str] Block name/wildcard pattern for which to return anon. references
;;;-----------------------------------------------------------------------------------------------;;;

(defun LM:getanonymousreferences (blk / ano def lst rec ref)
  (setq blk (strcase blk))
  (while (setq def (tblnext "block" (null def)))
    (if
      (and (= 1 (logand 1 (cdr (assoc 70 def))))
     (setq rec
      (entget
        (cdr
          (assoc 330
           (entget
             (tblobjname
         "block"
         (setq ano (cdr (assoc 2 def)))
             )
           )
          )
        )
      )
     )
      )
       (while
   (and
     (not (member ano lst))
     (setq ref (assoc 331 rec))
   )
    (if
      (and
        (entget (cdr ref))
        (wcmatch (strcase (LM:al-effectivename (cdr ref))) blk)
      )
       (setq lst (cons ano lst))
    )
    (setq rec (cdr (member (assoc 331 rec) rec)))
       )
    )
  )
  (reverse lst)
)

;;;-----------------------------------------------------------------------------------------------;;;
;; Effective Block Name  -  Lee Mac
;; ent - [ent] Block Reference entity
;;;-----------------------------------------------------------------------------------------------;;;
(defun LM:al-effectivename (ent / blk rep)
  (if (wcmatch (setq blk (cdr (assoc 2 (entget ent)))) "`**")
    (if
      (and
  (setq rep
         (cdadr
     (assoc -3
      (entget
        (cdr
          (assoc 330
           (entget
             (tblobjname "block" blk)
           )
          )
        )
        '("acdbblockrepbtag")
      )
     )
         )
  )
  (setq rep (handent (cdr (assoc 1005 rep))))
      )
       (setq blk (cdr (assoc 2 (entget rep))))
    )
  )
  blk
)

;;;-----------------------------------------------------------------------------------------------;;;
;;;Список имен всех блоков;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;-----------------------------------------------------------------------------------------------;;;
(defun ax:blocks (block / b bn tl)
  (vlax-for b (vla-get-blocks
                (vla-get-ActiveDocument (vlax-get-acad-object))
              )
              (if (= (vla-get-islayout b) :vlax-false)
                (if (wcmatch (vla-get-name b) block) ;;;Add Doctor_Che 2018-01-16
                    (setq tl (cons (vla-get-name b) tl))
                )
              )
  )
  (reverse tl)
)

;;;-----------------------------------------------------------------------------------------------;;;
;; Flatten List  -  Lee Mac
;; Transforms a nested list into a non-nested list with null values removed
;;;-----------------------------------------------------------------------------------------------;;;
(defun LM:flatten-nils ( l )
    (if l
        (if (atom l)
            (list l)
            (append (LM:flatten-nils (car l)) (LM:flatten-nils (cdr l)))
        )
    )
)

;;;-----------------------------------------------------------------------------------------------;;;
;;;Преобразование списка в строку;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;-----------------------------------------------------------------------------------------------;;;
(defun LM:BlockList->Str (lst del / f)
  ;; © Lee Mac 2011

  (defun f (s) (if (wcmatch s "`**") (strcat "`" s) s))

  (if (cdr lst)
    (strcat (f (car lst)) del (LM:BlockList->Str (cdr lst) del))
    (f (car lst))
  )
)

;;;-----------------------------------------------------------------------------------------------;;;
;;;Проверка на совпадение имени (анонимного имени) блока с указаной строкой;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;-----------------------------------------------------------------------------------------------;;;
(defun check-blockname-blockanonymousname (block_name / tmp)
  (setq tmp (cdr (assoc 2 (entget temp_name_one_object))))
  (or
    (member tmp (LM:getanonymousreferences (strcat block_name block_name_mask)))
    ;; (member tmp (LM:getanonymousreferences block_name))
    (wcmatch tmp (strcat  block_name block_name_mask))
    ;; (wcmatch tmp block_name)
  )
)

;;;-----------------------------------------------------------------------------------------------;;;
;;;Функция выбора объектов и подсчёта их количества;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;-----------------------------------------------------------------------------------------------;;;
(defun C:calculation-of-equipment ( / temp_name_one_object temp_count temp_list )

                    ;;;list_selected_objects   - переменная хранения и передачи списка выбранных линий
                    ;;;temp_name_one_object      - временная переменная хранения имени одной из выбранных линии
                    ;;;temp_count              - временная переменная хранения значения количества выбранных линий
                    ;;;temp_list               - временная переменная хранения списка

  (BenchTime t)
  (setq
    temp_list (list block_name_lamp block_name_switch)  ; создаём список из базовых имён блоков обозначений устройств для подключения
    temp_list (mapcar '(lambda (x) (strcat x block_name_mask)) temp_list)  ; добавляем к базовым именам блоков маску ("_##")
    temp_list (LM:BlockList->Str (append '("") (LM:flatten-nils (mapcar 'ax:blocks temp_list)) (LM:flatten-nils (mapcar 'LM:getanonymousreferences temp_list))) ",") ; производим поиск всех анонимных имён блоков по маскам и переводим результат в строку
  )
  (princ "\nНа создание списка имён блоков потрачено времени: ")
  (BenchTime nil)

  (princ "\n Укажите объекты которые должны быть включены в кабельный блок: \n")
  (BenchTime t)
  (setq list_selected_objects   ;| стартуем выбор объектов с условием |;
    (ssget
      (list
        (cons -4 "<OR")
          (cons -4 "<AND")
            (cons 0 "INSERT")
            (cons 2 temp_list)
            (cons 66 1)
          (cons -4 "AND>")
          (cons -4 "<AND")
            (cons 0 "ARC,ELLIPSE,*LINE")
            (cons -4 "<NOT")
              (cons -4 "<AND")
                (cons 0 "POLYLINE")
                (cons -4 "&")
                (cons 70 80)
              (cons -4 "AND>")
            (cons -4 "NOT>")
          (cons -4 "AND>")
        (cons -4 "OR>")
      ) ; end list
    ) ; end ssget
  ) ; end setq
  (princ "\nНа создание набора потрачено времени: ")
  (BenchTime nil)

  (if
    list_selected_objects
    (progn
        (BenchTime t)
        (setq
          G_count_lamp 0.0    ;| обнуляем или задаём первичное количество светильников в наборе |;
          G_count_switch 0.0    ;| обнуляем или задаём первичное количество выключателей в наборе |;
        )
        (repeat (setq temp_count (sslength list_selected_objects))    ;| выполняем пока не кончится список |;
            (setq temp_name_one_object (ssname list_selected_objects (setq temp_count (1- temp_count)))) ;| перебираем элементы набора |;
            (if (= (cdr (assoc 0 (entget temp_name_one_object))) "INSERT") ; если тип элемента это INSERT (блок)
              (progn
                (if (check-blockname-blockanonymousname block_name_lamp) ; проверяем подходит ли текущий проверяемый блок к блоку с именем block_name_lamp
                  (setq G_count_lamp (1+ G_count_lamp)) ;| добавляем к количеству светильников в наборе |;
                ) ; end if
                (if (check-blockname-blockanonymousname block_name_switch) ; проверяем подходит ли текущий проверяемый блок к блоку с именем block_name_switch
                  (setq G_count_switch (1+ G_count_switch)) ;| добавляем к количеству выключателей в наборе |;
                ) ; end if
              ) ; end progn
            ) ; end if
        ) ; end repeat
        (princ "\nНа подсчёт объектов потрачено времени: ")
        (BenchTime nil)
    ) ; end progn

    (progn
        (alert "Ничего не было выбрано!\nПрограмма будет закрыта!") ; если ничего не выбрали, то выходим.
        (exit)
    ) ; end progn
  ) ; end if

  (setq list_selected_objects nil) ; обнуляем переменную хранения выбора объектов
  (princ "\nСветильников выбрано: ")
  (princ G_count_lamp)
  (princ "\nВыключателей выбрано: ")
  (princ G_count_switch)
  (princ)
)   ; end defun calculation-of-equipment

[Nike]

Doctor_Che, посмотри альтернативные варианты:
http://www.lee-mac.com/nestedblockcounter.html
http://www.lee-mac.com/blockcounter.html

[VVA]

Doctor_Che, Замени анализ имени блока и всех его динамических представлений на сравнение эффективного имени и маски wcmatch
Т.е допустим, если динамические блоки светильника имеют имя "Светильник_01", "СвелильниК_02" и т.п.
то

(if (check-blockname-blockanonymousname block_name_lamp) ; проверяем подходит ли текущий проверяемый блок к блоку с именем block_name_lamp (setq G_count_lamp (1+ G_count_lamp)) ;| добавляем к количеству светильников в наборе |; ) ; end if

замени на

Код:

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

(setq block_name_lamp_mask "СВЕТИЛЬНИК_*") ;_Маска для блоков свельника
(if (wcmatch (strcase (vla-get-effectivename
                        (vlax-ename->vla-object temp_name_one_object)
                      ) ;_ end of vla-get-EffectiveName
             ) ;_ end of strcase
             block_name_lamp_mask
    ) ;_ проверяем подходит ли текущий проверяемый блок к блоку с именем block_name_lamp
  (setq G_count_lamp (1+ G_count_lamp))
  ;| добавляем к количеству светильников в наборе |;
) ;_ end if

и убери комментарий с 1 строчки (vl-load-com)

[Doctor_Che]

VVA, спасибо огромное. Теперь фрагмент с подсчётом блоков просто летает!
А можно ли оптимизировать момент с выбором блоков?
Там у меня идея такая, что бы выбирались только определённые типы блоков (светильники, выключатели и т.д.), если выбор идёт рамкой. И что бы все левые объекты отсеивались. Потом я всё что удовлетворяет требованию упаковываю в блок.
Вот здесь я создаю список всех вхождений блоков, которые удовлетворяют условию.

Код:

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

   (setq
    temp_list (list block_name_lamp block_name_switch)  ; создаём список из базовых имён блоков обозначений устройств для подключения
    temp_list (mapcar '(lambda (x) (strcat x block_name_mask)) temp_list)  ; добавляем к базовым именам блоков маску ("_##")
    temp_list (LM:BlockList->Str (append '("") (LM:flatten-nils (mapcar 'ax:blocks temp_list)) (LM:flatten-nils (mapcar 'LM:getanonymousreferences temp_list))) ",") ; производим поиск всех анонимных имён блоков по маскам и переводим результат в строку
  )

А здесь выбор с фильтром:

Код:

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

     (ssget
      (list
        (cons -4 "<OR")
          (cons -4 "<AND")
            (cons 0 "INSERT")
            (cons 2 temp_list)
            (cons 66 1)
          (cons -4 "AND>")
          (cons -4 "<AND")
            (cons 0 "ARC,ELLIPSE,*LINE")
            (cons -4 "<NOT")
              (cons -4 "<AND")
                (cons 0 "POLYLINE")
                (cons -4 "&")
                (cons 70 80)
              (cons -4 "AND>")
            (cons -4 "NOT>")
          (cons -4 "AND>")
        (cons -4 "OR>")
      ) ; end list
    ) ; end ssget

Может есть альтернатива?

[VVA]

Я думаю будет быстрее в ssget отфильтровать только блоки (ssget '((0 . "INSERT")), а затем пробежаться по полученному набору и удалить блоки, у которых эффективное имя не соответствует маске wcmatch см #3456
затем SSSETFIRST подсветить нужные

[Nike]

А не проще было бы блоки размещать в своих слоях (светильники в слое "Светильники", выключатели в "Выключатели" и т.д.) и выбирать с фильтром по слою?

[Doctor_Che]

Сообщение от Nike А не проще было бы блоки размещать в своих слоях (светильники в слое "Светильники", выключатели в "Выключатели" и т.д.) и выбирать с фильтром по слою?

Точно. У меня не каждый тип блока в своём слое, а каждый раздел. Но это как раз подошло.
Сделал фильтрацию (sget '((cons 0 "INSERT")(cons 8 "ЭО*,ЭМ*"))) - скорость выросла до реактивной.

[VVA]

Сообщение от Doctor_Che Точно. У меня не каждый тип блока в своём слое, а каждый раздел. Но это как раз подошло. Сделал фильтрацию (sget '((cons 0 "INSERT")(cons 8 "ЭО*,ЭМ*"))) - скорость выросла до реактивной.

Offtop: Даешь 1-ю космическую скорость

[Browning Zed]

Пытаюсь создать функцию цикла. Цикл должен запускать entsel, условие выхода из цикла - выбор таблицы. Написал следующую конструкцию:

Код:

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

   (while (not
	(setq tab1 (entsel "\nВыберите таблицу: "
	(ssget "X" '((0 . "ACAD_TABLE")))))
  ))

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

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

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

Код:

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

 (defun t1 (/ ent)
  (while (and (not
                (vl-catch-all-error-p
                  (setq ent (vl-catch-all-apply
                              (function (lambda () (car (entsel "\nВыберите что-нибудь, кроме таблицы <Отмена> : "))))
                              ) ;_ end of vl-catch-all-apply
                        ) ;_ end of setq
                  ) ;_ end of vl-catch-all-error-p
                ) ;_ end of not
              ent
              (/= (cdr (assoc 0 (entget ent))) "ACAD_TABLE")
              ) ;_ end of and
    (alert (strcat "Выбран примитив \"" (cdr (assoc 0 (entget ent))) "\""))
    ) ;_ end of while
  ) ;_ end of defun

(defun t2 (/ ent)
  (while (setq ent (ssget "_+.:S:E" '((-4 . "<NOT") (0 . "ACAD_TABLE") (-4 . "NOT>"))))
    (setq ent (ssname ent 0))
    (alert (strcat "Выбран примитив \"" (cdr (assoc 0 (entget ent))) "\""))
    ) ;_ end of while
  ) ;_ end of defun

[Browning Zed]

логика какая-то странная...

Это логика чайника в лиспе.

А если вообще ничего не выбрать? А если человеку надо "вотпрямщас" прекратить выполнение кода?

Если ничего не выбрать - вновь запрашивается выбор, до тех пор, пока не будет выбрана таблица. Обрыв команды по клавише Esc.
Попытался вшить предложенную функцию в код, но не сработало. Может подскажешь куда копать? Суть такова:
1. нужно выбрать таблицу (строку в таблице), и, если выбор сделан =>
2. нужно выбрать мвыноску, и, если выбор сделан =>
3. в таблицу вставляется строка с текстом выноски и ее координатами
4. циклический возврат к пункту 1

На данный момент в пункте 1 и 2 выбираются любые объекты, а нужно, чтобы в п. 1 можно было выбрать только таблицу, а в п. 2 - только мвыноску.

Код:

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

 (defun C:ins-row-in-tabl (/ n table_obj max-num-row n-max temp-n D NUM NUM_ROW POINT_LIST T1 VINOSKA VLA_VINOSKA pik-point temp-list)
  (vla-StartUndoMark active_document)
  (while T
  (progn
  (while (not
	(setq temp-list (entsel "\nВыберите таблицу: "))))
  (while (not
	(setq vinoska(car (entsel "\nВыберите выноску: ")))))
  (setq table_obj (car temp-list))
  (setq pik-point (cadr temp-list))
  (if table_obj
    (progn
      (if (= (cdr (assoc 0 (entget table_obj)))"ACAD_TABLE")
	(if vinoska
	  (if (= (cdr (assoc 0 (entget vinoska)))"MULTILEADER")
	    (progn
	      (setq table_obj (vlax-ename->vla-object table_obj))
	      (setq max-num-row (vla-get-rows table_obj))
	      (setq n-max (atoi (vla-GetText table_obj (1- max-num-row) 0)))
	      (if (= :vlax-true(vla-HitTest table_obj (vlax-3d-point (trans pik-point 1 0)) (vlax-3d-point (trans (getvar "VIEWDIR") 1 0)) 'row 'col))
		(if (< row 2)(setq n 1)(setq n (1- row)))
		(progn
		  (initget 1)(setq n (getint (strcat "\nВ какую строку вставлять?(max="(itoa n-max)"): ")))
		  ))
	      (if (or (< (1+ n) max-num-row) (= (1+ n) max-num-row))
		(progn
		  (setq vla_vinoska(vlax-ename->vla-object vinoska))
		  (setq point_list (vlax-safearray->list(vlax-variant-value(vla-GetLeaderLineVertices vla_vinoska 0))))
		  (setq t1 (list (car point_list) (cadr point_list)))
		  (if (eq (vla-get-ContentBlockName vla_vinoska) "")
		    (setq d (vla-get-TextString vla_vinoska))
		    (setq d (strcat"т."(cadr(extract_302 (entget vinoska))))))
		  (vla-InsertRows table_obj (1+ n) 8 1)
		  (setq max-num-row (vla-get-rows table_obj))
		  (vla-SetText table_obj (1+ n) 0 (if (= n 1)"=1"(strcat "=A"(rtos (1+ n) 2 0)"+1")))
		  (vla-SetText table_obj (+ n 2) 0 (strcat "=A"(rtos (+ n 2) 2 0)"+1"))
		  (vla-SetCellAlignment table_obj (1+ n) 0 acMiddleCenter)
		  (vla-SetText table_obj (1+ n) 1 d)
		  (vla-SetCellAlignment table_obj (1+ n) 1 acMiddleLeft)
		  (vla-SetText table_obj (1+ n) 2 (rtos (nth 1 t1) 2 2))
		  (vla-SetCellAlignment table_obj (1+ n) 2 acMiddleCenter)
		  (vla-SetCellTextHeight table_obj (1+ n) 2 2.8)
		  (vla-SetText table_obj (1+ n) 3 (rtos (nth 0 t1) 2 2))
		  (vla-SetCellAlignment table_obj (1+ n) 3 acMiddleCenter)
		  (vla-SetCellTextHeight table_obj (1+ n) 3 2.8)
		  )
		(princ "\nОшибка! Недопустимый ввод!")
		)
	      )
	    (alert "Ошибка! Необходимо выбрать выноску.")
	    )
	  )
	(alert (strcat " Ошибка! Необходимо выбрать таблицу."))
	)
      )
    )
	));!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  (vla-EndUndoMark active_document)
  (princ)
  )

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

Я бы делал ставку на фильтры selset - быстро, просто, предсказуемо

[Browning Zed]

OK. Вот пример из автодесковской справки About Selection Set Filter Lists:

Код:

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

 (ssget "X" (list (cons 0 "ACAD_TABLE")))

Но непонятно как этот фильтр правильно внедрить в код, чтобы он отработал.

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

Я ж в t2 показал варианты выбора. В чем трудность?
И настоятельно все же рекомендую разобраться со скобками: код вообще непонятно как должен работать.

[Сергей812]

Сообщение от Browning Zed (ssget "X" (list (cons 0 "ACAD_TABLE")))

просто получите все таблицы в чертеже) а вот если напишете как

Код:

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

 (ssget (list(cons 0 "ACAD_TABLE")))

то он просто не даст включить в набор не таблицу.

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

Сообщение от Browning Zed OK. Вот пример из автодесковской справки About Selection Set Filter Lists: Код: [Выделить все] (ssget "X" (list (cons 0 "ACAD_TABLE")))

Не обратил сразу внимания. Код не сработает в локализованной версии AutoCAD.

[Сергей812]

Сообщение от Кулик Алексей aka kpblc Код не сработает в локализованной версии AutoCAD.

а код и так лишен смысла - с алгоритмом:

Сообщение от Browning Zed 1. нужно выбрать таблицу (строку в таблице), и, если выбор сделан => 2. нужно выбрать мвыноску, и, если выбор сделан => 3. в таблицу вставляется строка с текстом выноски и ее координатами 4. циклический возврат к пункту 1

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

[Browning Zed]

На счет качества кода не скажу - код не мой. Я лишь пытаюсь допилить его под себя.

постоянно прыгать от выноски в чертеже к таблице (таблицам) и обратно

А вот в этом и фишка. Дело в том, что новая строка вставляется не вниз таблицы, а выше строки которую ты выбрал. При этом, в левой колонке идет нумерация строк, которая автоматически пересчитывается при вставке новой строки. Т.е., если нужно добавить новую строку между строками имеющими номера пунктов 1 и 2 - кликаем на вторую строку, она перемещается вниз, автоматом становится номером 3, а на ее место встает новая строка. В общем, так надо.

Кулик Алексей aka kpblc,

Я ж в t2 показал варианты выбора. В чем трудность?

Функция t2 работает следующим образом:
1. если выбран объект кроме таблицы (либо ничего не выбрано) - функция возвращает nil.
2. если выбрана таблица - цикл выбора продолжается.
Но это не то, что мне нужно. Попробую пояснить на примере.
В выражении:

Код:

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

 (setq X (entsel "\nВыберите таблицу: "))

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

[VVA]

Сообщение от Browning Zed А нужно, чтобы переменной X была возможность присвоить только имя таблицы, в противном случае цикл выбора продолжается.

Код:

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

(setq X (mip-ssentget-by-type "Выбери таблицу" '("ACAD_TABLE") 0))

Недостающие функции здесь

[Browning Zed]

Спасибо, VVA. То, что нужно! Но есть один косяк. Эта функция работает, только, если в процессе выполнения кода нужно выбрать один тип объекта. В моем случае - сначала необходимо выбрать таблицу, а затем мультивыноску. Т.е., если в коде будут два выражения, типа:

Код:

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

 (setq X (mip-ssentget-by-type "Выбери таблицу" '("ACAD_TABLE") 0))

Код:

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

 (setq Y (mip-ssentget-by-type "Выбери выноску" '("MULTILEADER") 0))

на втором выражении функция выдаст ошибку (в моем случае, ошибка: неверный тип аргумента: 2D/3D-точка: nil).
Это можно как-то поправить?

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

При выборе мультивыноски надо "кликать" не на аннотации, а на самой выноске. Кстати, выноски могут быть и стандартные.
И ты уверен, что именно функция mip-ssentget-by-type срабатывает неправильно?

[Browning Zed]

Кулик Алексей aka kpblc,
Неважно куда кликать, на текст или линию выноски - функция прерывается с ошибкой.

И ты уверен, что именно функция mip-ssentget-by-type срабатывает неправильно?

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

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

Ок, замени вызов на обычный ssget: (ssget '((0 . "ACAD_TABLE"))) и (ssget '((0 . "MULTILEADER"))) и посмотри, что будет в результате. Мне кажется, что проблема совершенно в другом месте.

[Сергей812]

Сообщение от Browning Zed Скорее всего, дело в ней. Потому как, если функцию прописать для одного типа объекта (только для таблицы, или только для выноски), она отрабатывает корректно. Но, если, функция задействуется для обоих типов - возникает ошибка.

используйте трассировку - редактор лиспа акадовский это позволяет. Чем гадать...

[VVA]

Сообщение от Browning Zed В моем случае - сначала необходимо выбрать таблицу, а затем мультивыноску.

Сообщение от Browning Zed на втором выражении функция выдаст ошибку (в моем случае, ошибка: неверный тип аргумента: 2D/3D-точка: nil)

Не подтверждаю. Функции безразлично, какой тип примитива ты запрашиваешь.
Поэтому

Сообщение от Сергей812 используйте трассировку - редактор лиспа акадовский это позволяет

В редакторе лиспа в меню "Отладка" поставь чек-бокс на "Прервать на ошибке".
Запусти лисп.
После ошибки вернить в редактор и выбери "Отладка"->"Причина последнего останова" (Ctrl+F9) Перейдешт на строчку, в которой возникла ошибка
Клик правой кнопкой на переменной -> "Изучить"
Смотри что в ней содержится

[Red Nova]

Доброго. Нубовопрос.
После того как отработала переопределенная функция (*error* nil), разве не должен происходить выход из вычислений? Я наивно пологал что вызов error остановит вычисления на моменте где собственно и вызвать error . Но у меня в данном примере после (+ 1 1) отрабатывает error а после этого отрабатывает и (+ 2 2). Все так и должно быть?
Если все так и должно быть, то как грамотно обеспечить выход при error?

Код:

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

 (defun c:test ( / )
  (defun *error* ( msg )
    (princ  "\nError: Function cancelled")
    (princ)
    )

  (+ 1 1)
  (*error* nil)
  (+ 2 2)
  )

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

http://autolisp.ru/2009/09/13/error-catch/ ?

[Red Nova]

Ну у меня то как раз вариант где требовалось остановить выполнение кода после (*error* nil). Выходит мне нужно вместо (*error* nil) использовать (exit), которая уже в свою очередь вызовет *error*...

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

А разве настолько необходимо локальное переопределение *error*?

[Red Nova]

Ну в общем нет. Но так уж у меня пока все написано

[skkkk]

Offtop: Привет, Red Nova
Даже и не знаю, с чем тебя поздравлять: с золотом или с бронзой? Однако очень мне жаль, что наши наши не схлестнулись с вашими нашими

Насчёт твоего вопроса - то чувство, когда знаешь откуда ноги растут...

Сообщение от Red Nova После того как отработала переопределенная функция (*error* nil), разве не должен происходить выход из вычислений? Я наивно пологал что вызов error остановит вычисления на моменте где собственно и вызвать error .

С чего, интересно, ты так полагал? Припоминаю, что когда-то я мог тебя направить на этот путь, вот только, где точно, найти быстро не смог.

Мысль была такова, что после выполнения всех действий программы нам надо восстановить состояние среды: вернуть все системные переменные, удалить временные и вспомогательные примитивы, перерисовать (redraw) и т.д. То же самое (как правило) надо сделать в случае вылета программы с ошибкой, когда автоматически вызывается локально переопределенная функция *error*. И в ней по задуманному алголитму содержится (как правило) тот же сценарий, что и после завершения программы. Поэтому, дабы не дублировать куски кода, можно вместо этого в конце функции вызвать (*error* nil). Таким образом, вызвав посреди кода (*error* nil), ты просто вернешь состояние среды в первоначальное, не дождавшись завершения работы программы.

Изначально я эту мысль извлек среди прочих из урока gomer'а. Она мне очень понравилась и прижилась. Помню, что делился ею с тобой в какой-то теме, вроде бы даже в этой, но пролистал поиск на несколько десятков страниц - и не нашел. А ты, видимо, чуть подзабыв, интерпретировал ее так, как тебе было удобно в какой-то момент

Сообщение от Red Nova Но у меня в данном примере после (+ 1 1) отрабатывает error а после этого отрабатывает и (+ 2 2). Все так и должно быть? Если все так и должно быть, то как грамотно обеспечить выход при error?

Иными словами, так и должно быть. Но что ты имел в виду под "выход при error"?

Обеспечить выход (если не говорить о вылете с ошибкой), разумеется, можно через (exit), который спровоцирует вызов *error*. Но давно когда-то читал тут на форуме, что такого выхода лучше избегать. Причин не помню, вроде как они и озвучены не были. Предполагаю, что по мнению автора этой идеи было неправильным искусственно провоцировать ошибку с записью в командной строке "Ошибка завершить/выйти/прервать" (или что-то типа того). И вышло так, что я приучил себя выходить из программы при помощи соответствующего построения алгоритма. Например, использовать cond, и в случае, если не выполняется ни одно из условий, то собственно, ничего и не делать и завершать программу по-тихому. И параллельно приучил себя после урока gomer'a просто вызвать (*error* nil) после завершения cond.
То есть приучился не вызывать искусственно завершение программы, так как это приводит к ошибке, но при этом искусственно вызывать программу, которая должна сработать при ошибке

Вот такие вот пироги. Да.

[Red Nova]

skkkk,
Спасибо за развернутый ответ. Познавательно.

Сообщение от skkkk С чего, интересно, ты так полагал? Припоминаю, что когда-то я мог тебя направить на этот путь, вот только, где точно, найти быстро не смог.

После того как error у меня стал делать то чего делать не должен я не в чем не уверен )).
Offtop:

Сообщение от skkkk Offtop: Привет, Red Nova Даже и не знаю, с чем тебя поздравлять: с золотом или с бронзой? Однако очень мне жаль, что наши наши не схлестнулись с вашими нашими

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

[Ivv]

Всем привет!

Пишу программу на AUTOLISP с диалоговым окном DCL.

Обнаружил некие ограничения элемента диалога list_box с установленным атрибутом multiple_select=true.

Возвращаемое значение функции get_tile ограничено длиной строки приблизительно 2017 символов.
Если количество выбранных элементов списка листбокса формирует строку длиннее 2017 символов (а это максимум 532 первых элементов списка листбокса) get_tile возвращает nil.

Значение переменной действия $value ограничено 256 элементами списка листбокса. При указании большего числа элементов в диалоге значение переменной всё равно 256 элементов.

Сталкивался ли кто-либо с подобным ограничением?
Существуют ли другие способы получить корректное значение из list_box окна DCL при указании более 532 элементов?

Версия AutoCAD 2012.

[Сергей812]

может, попробовать написать сам диалог не на DCL - например, в виде сборки dll с атрибутом LispFunction

[Ivv]

К сожалению ООП, Active X и (.NET) для меня пока слишком высокие материи...

Кроме того, если я верно пониманаю, применение dll подразумевает установку программы и наличие прав администратора?

Их у меня нет, - политика компании и всё такое.


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

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

Ожидаемое количество элементов списка вышеуказанного листбокса - до 1000 элементов. За две операции выбора задачу по обработке списка можно решить.


Однако, удивляет что подобная особенность поведения функции get_tile и переменной $value не описана у Полещука. Также не обнаружил упоминания об этих особенностях на ресурсах Autodesk и у Ли Мака. Вот и закралось подозрение - может проблеммы и нет вовсе... Может чего не то с настройками автокада или проблема как то решается.

[Сергей812]

Сообщение от Ivv применение dll подразумевает установку программы и наличие прав администратора?

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

[Ivv]

Сообщение от Сергей812 не требует - просто надо будет положить dll в "доверенную" папку.

Благодарю за разъяснение!..

P.S.: Только сегодня зарегистрировался, наблюдаю какие-то то проблемы с форумом: сообщения не публикуются часами, со стационарного компьютера вообще на страницу форума попасть не могу... Пишу с мобильного телефона...

[Wanted]

Всем доброй ночи, помогите поправить LISP, при его использовании пропадают привязки. Помогите вернуть привязки по окончанию LISP-a.
Благодарю Вас!

Код:

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

;бесконечный вызов
(defun c:p5 (/)
  (while T (c:p2))
)

;*******************************************************
 ; Проставление размеров по точкам
 ;*******************************************************
(defun C:P2 (/ DELTA J KT L1 L2 L3 LP  OB6 OLD P1 P2 POB SP SPOINT  T1 T2 TS1 TS11 U1 U2 UGG UGR V0 VK VN W
	       dim_list ss maxp minp x y old_ucsicon flag flag1 obstruct1 obstruct2 obstruct0 detail_int_list stop_list only_one_inters achivement textbox1
	       dim_list_1 ss0 KILL_LIST CUR_POS CUR_WIDTH_F X_KILL_FLAG
	       last_obj_before_bound inner_dim_list inner_complex_list inner_walls_list
	    )
 ; (vl-cmdf "_.style" "GOST_B" "GOST type B" "250" "1" "0" "_n" "_n");если нет такого стиля - создать
  ;(vl-cmdf "_.style" "GOST_B" "Arial" "250" "1" "0" "_n" "_n");если нет такого стиля - создать
  ;(setvar "TEXTSTYLE" "GOST_B")
  (IF (= (member "_Area"         (LayerNameList)) nil)  (command "_LAYER" "_N" "_Area" ""))
  (IF (= (member "_Perimeter"    (LayerNameList)) nil)  (command "_LAYER" "_N" "_Perimeter" ""))
  (IF (= (member "_DIM"          (LayerNameList)) nil)  (command "_LAYER" "_N" "_DIM" ""))
  ;(IF (= (member "del"          (LayerNameList)) nil)  (command "_LAYER" "_N" "del" ""))
  ;(command "_-LAYER" "_off" "del" "")
  (IF (= (member "_Hidden"       (LayerNameList)) nil)  (command "_LAYER" "_N" "_Hidden" ""))  
  (setq  HT (cdr (assoc 40 (tblsearch "STYLE" (getvar 'textstyle))))) ; - высота букв (0, если высота не фиксирована)
  (if (= HT 0.0) (progn (alert "В текстовом стиле задай высоту текста!") (command "'_style") (Quit)))
    (setvar "CmdEcho" 0)
    (setvar "PDMODE" 0)
    (setvar "PDSIZE" 1)
    (setq OLD (getvar "OSMODE")) (setq old_ucsicon (getvar "ucsicon")) (setq only_one_inters nil)
    (setvar "OSmode" 0)
    (SetVar "PICKSTYLE" 1)
    (setvar "FILEDIA" 1)
    (setvar "ucsicon" 0)
    (setq last_obj_before_bound (entlast))
  
  
  

  
  ;   (Repeat 1000000
    (setq Ts1 (getpoint "\nТочка внутри контура :"))
    (setq Ts11 Ts1)
       
       ;(setvar "CeColor" "2")
       (command "_-Boundary" Ts1 "")
       (setq Ob6 (entlast)); исходная полилиния
 (setq inner_complex_list (inner_walls Ob6 last_obj_before_bound HT))
 (setq inner_dim_list (car inner_complex_list))
 (setq inner_walls_list (cadr inner_complex_list))

  
;Оптимизация контура       
       (setq LP (poly Ob6)); к-во и список точек полилинии

(setq KT (- (car LP) 1)); кол-во точек
(setq L1 (cdr LP)); список точек без кол-ва
(setq L2 (cdr (reverse L1)));обратный список точек без последней
(setq L3 (reverse L2)); нормальный список точек без последней
       (setq w 0) (setq SPoint nil)
       (Repeat KT
	  (If (= w 0)  (setq VN (last L3))  (setq VN (nth (- w 1) L3)))
	  (If (= w (- KT 1)) (setq VK (nth 0 L3)) (setq VK (nth (+ w 1) L3)))
	  (setq V0 (nth w L3))
      		(setq U1 (atof (rtos (r2g (angle V0 VK)) 2 2)))
      		(setq U2 (atof (rtos (r2g (angle VN V0)) 2 2)))
                (If (= U1 360.0) (setq U1 0.0))
                (If (= U2 360.0) (setq U2 0.0))
	 (if (/= U1 U2) (setq SPoint (cons V0 SPoint)))
	 (setq w (+ 1 w))
	 )
(entdel Ob6)

  ;(setvar "CLAYER" "_Perimeter");эта строка зачем-то была закомментирована
  ;(setvar "CeColor" "10")
       
(Setq KT (- (length Spoint)1 ))
       (command "_PLINE" (car SPoint) "_W" 35.0 35.0)
       (setq w 1)
       (Repeat KT
	 (setq V0 (nth w Spoint))
	 (command V0)
	 (setq w (+ 1 w))
	 )
(command "_C");замыкание полилинии

(Setq Pob (entlast)); объект контура!!!!!!!!!!!!
(setq LP (poly POb))
    (setq j 1)
;(setvar "CLAYER" "_DIM");;эта строка зачем-то была закомментирована
  ;(setvar "CeColor" "224")       
    (Repeat (- (car LP) 1)
            (setq T1 (nth j LP))
	    (setq T2 (nth (+ j 1) LP))
            (setq Delta (distance T1 T2))
	           (if (> (car T1)  (car T2)) (setq P1 T2 P2 T1) (setq P1 T1 P2 T2))
    	    (setq UgR      (angle P1 P2))
	    (setq UgG (r2g (angle P1 P2)))
                   (if (= (fix UgG) 270.0) (setq UgG 90.0))
       ;(setq T0  (polar (seredina P1 P2) (G2R (+ UgG 90.0))(/  HT 3.0)))
       ;(setq T00 (polar (seredina P1 P2) (G2R (+ UgG 90.0))(+ (* 0.5 HT)  HT 3.0)))
  ;#########################################################################################
  ;#########################################################################################
       (setq SP (PSW1 Pob (polar (seredina P1 P2) (G2R (+ UgG 90.0)) 0.01))); 0.01 - размер "щупа" для определения направления сегмента полилинии. был 100. много!
  ;#########################################################################################
  ;#########################################################################################
    (if (= SP 1) (setq T00 (polar (seredina T1 T2) (G2R (+ UgG 90.0)) (+ (* 0.5 HT) 100.0))))
    (if (= SP 0) (setq T00 (polar (seredina T1 T2) (G2R (- UgG 90.0)) (+ (* 0.5 HT) 100.0))))
      
         (command "_TEXT" "_j" "_MC" T00 (+ UgG 0.0) (rtos (/ Delta 1000.0) 2 2)) (setq Ob (entLAST))

;;;;;;;;;;;;;;;;;;;;;;добавка 1 - СПИСОК РАЗМЕРНЫХ ТЕКСТОВ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
         (setq dim_list (append dim_list (list (list
					   Ob
					   (distof (vla-get-TextString (vlax-ename->vla-object Ob)))
					   (angle (seredina T1 T2) T00)
					   (vla-get-ScaleFactor (vlax-ename->vla-object Ob))
					   T00
;;;					   (cons "dir_ang" (angle (seredina T1 T2) T00))
;;;					   (cons "sc_f" (vla-get-ScaleFactor (vlax-ename->vla-object (entLAST))))
					 ))
			)
	 );конец добавки 1
	;???????????????????????????????????????????????????????????
    (setq j (+ 1 j))
  )

  ;#########################################################################################
 
 ; );REPEAT 10000000000000000000000
 ;**********************************************
 (if inner_dim_list (setq dim_list (append dim_list inner_dim_list)))

  
;общая "прополка"
(cleanup dim_list pob T inner_walls_list)
  
(setq dim_list (vl-remove-if-not '(lambda (y) (entget (car y))) dim_list))
  (foreach w dim_list
    (setq flag (inters_detect w dim_list pob nil nil))
        (if (cdr (assoc "general_flag" (car flag))) ;безнадежных фтопку. как вариант - можно на выключенный слой
          (vla-delete (vlax-ename->vla-object (car w)))
	)
  )  

(if inner_walls_list
	(foreach k inner_walls_list
	  (entdel k);внутренние контуры фтопку 
	)
)
  
;главный контур фтопку  
(entdel pob)

  
(SetVAR "OsMode" Old)
(setvar "ucsicon" old_ucsicon)
 (princ)
(setvar "osmode" osm)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;добавка 3
(defun inters_detect (ent dimlist pob inner inner_walls / minp maxp ss ss0  flag_full flag flag0 int_dimlist found_list new_found_list cp_list FLAG1 POB_FLAG)
     (setq flag nil new_found_list nil minp nil maxp nil)
     (setq FLAG1 nil POB_FLAG nil flag_full nil)
 (setq int_dimlist  dimlist)
     ; проверка на принадлежность контуру
 (if inner
   (progn  
     (setq ss0 (ssget "_CP" (plv1 (vlax-ename->vla-object pob))))
     (if ss0
	(if (ssmemb (car ent) ss0)
	  (setq flag0 t);размер внутри контура, можно проверять дальше
	  (setq flag t); размер не внутри контура, все плохо
	)
     )
     (setq ss0 nil); (setq flag flag0)
   )
   (setq flag0 t);размер и не должен быть внутри контура
 );eo if inner
  
;если размер внутри контура или не должен там быть, можно проверять дальше
     (if flag0
       (progn
	     (if inner (setq int_dimlist (append dimlist (list (list pob)))))
             (foreach f inner_walls
	       (setq int_dimlist (append int_dimlist (list (list f))))
	     )
	     (setq int_dimlist (vl-remove ent int_dimlist))
	     (setq int_dimlist (mapcar 'car int_dimlist))
	  
	     (vl-cmdf "_ucs" "_OB" (car ent))
	     (gc:UcsBoundingBox (car ent) 'minp 'maxp)
	     (setq cp_list (list
				     (trans (list (car minp) (cadr minp) (caddr minp)) 1 0)
				     (trans (list (car minp) (cadr maxp) (caddr minp)) 1 0)
				     (trans (list (car maxp) (cadr maxp) (caddr minp)) 1 0)
				     (trans (list (car maxp) (cadr minp) (caddr minp)) 1 0)
		           )
	     )
	     (vl-cmdf "_ucs" "_p")
	     (setq ss (ssget "_CP" cp_list))
  
	     (if ss
	       (progn
	        (setq found_list (ssnamex ss))
		(setq ss nil)
		(setq found_list (mapcar 'cadr found_list))
		(setq found_list (vl-remove-if-not '(lambda (x) (eq (type x) 'ENAME)) found_list))
		(setq found_list (vl-remove (car ent) found_list))
		(foreach z found_list
		  (if (member z int_dimlist)
		   (setq new_found_list (append new_found_list (list z)))
		  )
		)
		(if new_found_list (setq flag T))
	       );eo progn
     	     )
	 )
      )
 (if new_found_list 
	 (if (or (member pob new_found_list)
		 (vl-some '(lambda (jj) (member jj inner_walls)) new_found_list)
	     )
	   (setq pob_flag T); размер пересекает внешний или внутр. контур, все плохо
	   (if (= 1 (length new_found_list)) (setq flag1 T));объект не пересекает контур, но пересекает один из размеров. причем только один
	 )
 )
 ;(setq flag_full (list (cons "general_flag" flag) (cons "pob_flag" pob_flag) (cons "flag1" flag1)))
 (setq flag_full (list
		   (cons "general_flag" flag)
		   (cons "pob1_flag" (and (not pob_flag)  flag1))
		   (cons "pob_flag" (not pob_flag));!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
		 )
 )
 
 (list flag_full new_found_list)
)
;;;;;;;;конец добавки 3
;;;;;;;;добавка 4
(defun inters_detect1 (ent detail_int_list pob / text_int_list textbox1 point)
  	(setq text_int_list detail_int_list)
  	(if (member pob text_int_list)
	  (setq text_int_list (vl-remove pob text_int_list))
	)	    
  	(if (= 1 (length text_int_list))
	  (progn
	    ;(vla-put-color (vlax-ename->vla-object (car text_int_list)) acred)
	    (setq textbox1 (textbox (entget (car text_int_list))))
	    (vla-put-TextAlignmentPoint
	      (vlax-ename->vla-object (car ent))
	      (vlax-3d-point
		      (polar
			(vlax-safearray->list (vlax-variant-value (vla-get-TextAlignmentPoint (vlax-ename->vla-object (car ent)))))
			(nth 2 ent)
			;(* 1.1 (min_dist_inters (car ent)  (car text_int_list)))
			;(* 1.2 (vla-get-Height (vlax-ename->vla-object (car text_int_list))))
			;(* 0.5 textbox1)
			(* 0.35(- (caadr textbox1) (caar textbox1)))
		      ); eo polar
	      );eo vlax-3d-point
	    ); eo vla-put-TextAlignmentPoint  
	    (car text_int_list)
	  );eo progn  
	  nil;else
	);eo if  

)

;;;;;;;;конец добавки 4

;;;;;;;;;;;;;  
;############################################################################
;############################################################################
(defun POISK1 (_P1 _P2 /  _DELTA _DIS _DL _S _T0 _TC _UGG _UGR _W1 _W2 _W3 _W4 )
    ;(setq  HT 150.0)
  (setq A (List 1000000.0 (List 0.0 0.0 0.0)))
   (setq _DELTA (distance _P1 _P2 ))
    		            (setq _UgR      (angle _P1 _P2))
			    (setq _UgG (r2g (angle _P1 _P2)))
    (if (= (fix _UgG) 270.0) (setq _UgG 90.0))
       (command "_TEXT" "_j" "_C" T0 (+ _UgG 0.0) (rtos _UgG 2 2))
       (setq _DL (TXTLen (entlast))) (setq Ob (entlast)) (entdel OB)
       (setq _DIS (+ _DL (* 0.5 _DELTA)))
       (setq _T0 (seredina _P1 _P2))
       (setq _TC (Polar _T0 (G2R (+ _UgG 90.0))(/  HT 3.0)))

; Верх назад ----------------------------------------------------       
       (setq _W1 (Polar _TC (G2R (- _UgG 180.0)) (* 0.5 _DL)))
       (setq _W2 (Polar _W1 (G2R (+ _UgG   0.0)) (* 1.0 _DL)))
       (setq _W3 (Polar _W2 (G2R (+ _UgG  90.0))  HT))
       (setq _W4 (Polar _W1 (G2R (+ _UgG  90.0))  HT))  
       (setq _S (ssget "_CP" (list _W1 _W2 _W3 _W4 _W1)))
       (IF (= _S nil) (progn
	 ;(command "_TEXT" "_j" "_C" (seredina _W1 _W2) (+ _UgG 0.0) (rtos _UgG 2 2))
	 ;(command "_PLINE" _W1 _W2 _W3 _W4 "_c")
	 (setq A (List (distance (seredina _W1 _W3) (seredina _P1 _P2)) (seredina _W1 _W3) (seredina _W1 _W3)))
	 (setq _DIS 0.0)
	 )) 
       ;(command "_PLINE" _W1 _W2 _W3 _W4 "_c") 
       (while (> _DIS (Distance _TC _W1))
	       (setq _W1 (Polar _W1 (G2R (- _UgG 180.0)) (/  HT 3.0)))
	       (setq _W2 (Polar _W2 (G2R (- _UgG 180.0)) (/  HT 3.0)))
	       (setq _W3 (Polar _W3 (G2R (+ _UgG 180.0)) (/  HT 3.0)))
	       (setq _W4 (Polar _W4 (G2R (+ _UgG 180.0)) (/  HT 3.0)))
	       ;(command "_PLINE" _W1 _W2 _W3 _W4 "_c")
	       (setq _S (ssget "_CP" (list _W1 _W2 _W3 _W4 _W1)))
	       (IF (= _S nil) (progn
		 ;(command "_TEXT" "_j" "_C" (seredina _W1 _W2) (+ _UgG 0.0) (rtos _UgG 2 2))
		 (setq A (List (distance (seredina _W1 _W3) (seredina _P1 _P2)) (seredina _W1 _W3) (seredina _W1 _W3)))
		 (setq _DIS 0.0)
		 )) 
	 
	 )
  (princ) (setq A A)
  )
 ; Верх ВПЕРЕД  ----------------------------------------------------
(defun POISK2 (_P1 _P2 /  _DELTA _DIS _DL _S _T0 _TC _UGG _UGR _W1 _W2 _W3 _W4 )
    ;(setq  HT 150.0)
  (setq A (List 1000000.0 (List 0.0 0.0 0.0)))
   (setq _DELTA (distance _P1 _P2 ))
    		            (setq _UgR      (angle _P1 _P2))
			    (setq _UgG (r2g (angle _P1 _P2)))
    (if (= (fix _UgG) 270.0) (setq _UgG 90.0))
       (command "_TEXT" "_j" "_C" T0 (+ _UgG 0.0) (rtos _UgG 2 2))
       (setq _DL (TXTLen (entlast))) (setq Ob (entlast)) (entdel OB)
       (setq _DIS (+ _DL (* 0.5 _DELTA)))
  
       (setq _T0 (seredina _P1 _P2))
       (setq _TC (Polar _T0 (G2R (+ _UgG 90.0))(/  HT 3.0)))
  
       (setq _W1 (Polar _TC (G2R (- _UgG 180.0)) (* 0.5 _DL)))
       (setq _W2 (Polar _W1 (G2R (+ _UgG   0.0)) (* 1.0 _DL)))
       (setq _W3 (Polar _W2 (G2R (+ _UgG  90.0))  HT))
       (setq _W4 (Polar _W1 (G2R (+ _UgG  90.0))  HT))
  
       (setq _S (ssget "_CP" (list _W1 _W2 _W3 _W4 _W1)))
       (IF (= _S nil) (progn
	 ;(command "_TEXT" "_j" "_C" (seredina _W1 _W2) (+ _UgG 0.0) (rtos _UgG 2 2))
	 ;(command "_PLINE" _W1 _W2 _W3 _W4 "_c")
	  (setq A (List (distance (seredina _W1 _W3) (seredina _P1 _P2)) (seredina _W1 _W3) (seredina _W1 _W3)))
	 (setq _DIS 0.0)
	 )) 

       ;(command "_PLINE" _W1 _W2 _W3 _W4 "_c")
       (while (> _DIS (Distance _TC _W1))
	       (setq _W1 (Polar _W1 (G2R (- _UgG 0.0)) (/  HT 3.0)))
	       (setq _W2 (Polar _W2 (G2R (- _UgG 0.0)) (/  HT 3.0)))
	       (setq _W3 (Polar _W3 (G2R (+ _UgG 0.0)) (/  HT 3.0)))
	       (setq _W4 (Polar _W4 (G2R (+ _UgG 0.0)) (/  HT 3.0)))
	       ;(command "_PLINE" _W1 _W2 _W3 _W4 "_c")
	       (setq _S (ssget "_CP" (list _W1 _W2 _W3 _W4 _W1)))
	       (IF (= _S nil) (progn
		 ;(command "_TEXT" "_j" "_C" (seredina _W1 _W2) (+ _UgG 0.0) (rtos _UgG 2 2))
		 (setq A (List (distance (seredina _W1 _W3) (seredina _P1 _P2)) (seredina _W1 _W3) (seredina _W1 _W3)))
		 (setq _DIS 0.0)
		)) 
	 )
(princ) (setq A A)
)
;############################################################################
; НИЗ назад ----------------------------------------------------
(defun POISK3 (_P1 _P2 /  _DELTA _DIS _DL _S _T0 _TC _UGG _UGR _W1 _W2 _W3 _W4 )
    ;(setq  HT 150.0)
  (setq A (List 1000000.0 (List 0.0 0.0 0.0)))
   (setq _DELTA (distance _P1 _P2 ))
    		            (setq _UgR      (angle _P1 _P2))
			    (setq _UgG (r2g (angle _P1 _P2)))
    (if (= (fix _UgG) 270.0) (setq _UgG 90.0))
       (command "_TEXT" "_j" "_C" T0 (+ _UgG 0.0) (rtos _UgG 2 2))
       (setq _DL (TXTLen (entlast))) (setq Ob (entlast)) (entdel OB)
       (setq _DIS (+ _DL (* 0.5 _DELTA)))
;----------------------------------------------------------------------  
       (setq _T0 (seredina _P1 _P2))
       (setq _TC (Polar _T0 (G2R (- _UgG 90.0))(/  HT 3.0)))
  
       (setq _W1 (Polar _TC (G2R (- _UgG 180.0)) (* 0.5 _DL)))
       (setq _W2 (Polar _W1 (G2R (+ _UgG   0.0)) (* 1.0 _DL)))
       (setq _W3 (Polar _W2 (G2R (- _UgG  90.0))  HT))
       (setq _W4 (Polar _W1 (G2R (- _UgG  90.0))  HT))  

       (setq _S (ssget "_CP" (list _W1 _W2 _W3 _W4 _W1)))
       (IF (= _S nil) (progn
	 ;(command "_TEXT" "_j" "_C" (seredina _W4 _W3) (+ _UgG 0.0) (rtos _UgG 2 2))
	 ;(command "_PLINE" _W1 _W2 _W3 _W4 "_c")
	  (setq A (List (distance (seredina _W1 _W3) (seredina _P1 _P2)) (seredina _W3 _W1) (seredina _W1 _W3)))
	 (setq _DIS 0.0)
	 )) 


  
       ;(command "_PLINE" _W1 _W2 _W3 _W4 "_c")
       (while (> _DIS (Distance _TC _W1))
	       (setq _W1 (Polar _W1 (G2R (- _UgG 180.0)) (/  HT 3.0)))
	       (setq _W2 (Polar _W2 (G2R (- _UgG 180.0)) (/  HT 3.0)))
	       (setq _W3 (Polar _W3 (G2R (+ _UgG 180.0)) (/  HT 3.0)))
	       (setq _W4 (Polar _W4 (G2R (+ _UgG 180.0)) (/  HT 3.0)))
	       ;(command "_PLINE" _W1 _W2 _W3 _W4 "_c")
	       (setq _S (ssget "_CP" (list _W1 _W2 _W3 _W4 _W1)))
	       (IF (= _S nil) (progn
		 ;(command "_TEXT" "_j" "_C" (seredina _W3 _W4) (+ _UgG 0.0) (rtos _UgG 2 2))
		 (setq A (List (distance (seredina _W1 _W3) (seredina _P1 _P2))(seredina _W3 _W1)  (seredina _W1 _W3)))
		 (setq _DIS 0.0)
		)) 
	 )
(princ) (setq A A)
)
;############################################################################
; НИЗ ВПЕРЕД  ----------------------------------------------------
  (defun POISK4 (_P1 _P2 /  _DELTA _DIS _DL _S _T0 _TC _UGG _UGR _W1 _W2 _W3 _W4 )
  ;(setq  HT 150.0)
   (setq A (List 1000000.0 (List 0.0 0.0 0.0))) 
   (setq _DELTA (distance _P1 _P2 ))
    		            (setq _UgR      (angle _P1 _P2))
			    (setq _UgG (r2g (angle _P1 _P2)))
    (if (= (fix _UgG) 270.0) (setq _UgG 90.0))
       (command "_TEXT" "_j" "_C" T0 (+ _UgG 0.0) (rtos _UgG 2 2))
       (setq _DL (TXTLen (entlast))) (setq Ob (entlast)) (entdel OB)
       (setq _DIS (+ _DL (* 0.5 _DELTA)))
;----------------------------------------------------------------------    
       (setq _T0 (seredina _P1 _P2))
       (setq _TC (Polar _T0 (G2R (- _UgG 90.0))(/  HT 3.0)))
  
       (setq _W1 (Polar _TC (G2R (- _UgG 180.0)) (* 0.5 _DL)))
       (setq _W2 (Polar _W1 (G2R (+ _UgG   0.0)) (* 1.0 _DL)))
       (setq _W3 (Polar _W2 (G2R (- _UgG  90.0))  HT))
       (setq _W4 (Polar _W1 (G2R (- _UgG  90.0))  HT))  

       (setq _S (ssget "_CP" (list _W1 _W2 _W3 _W4 _W1)))
       (IF (= _S nil) (progn
	 ;(command "_TEXT" "_j" "_C" (seredina _W3 _W4) (+ _UgG 0.0) (rtos _UgG 2 2))
	 ;(command "_PLINE" _W1 _W2 _W3 _W4 "_c")
	  (setq A (List (distance (seredina _W1 _W2) (seredina _P1 _P2)) (seredina _W3 _W1) (seredina _W1 _W3)))
	 (setq _DIS 0.0)
	 )) 

    
       ;(command "_PLINE" _W1 _W2 _W3 _W4 "_c")
       (while (> _DIS (Distance _TC _W1))
	       (setq _W1 (Polar _W1 (G2R (- _UgG 0.0)) (/  HT 3.0)))
	       (setq _W2 (Polar _W2 (G2R (- _UgG 0.0)) (/  HT 3.0)))
	       (setq _W3 (Polar _W3 (G2R (+ _UgG 0.0)) (/  HT 3.0)))
	       (setq _W4 (Polar _W4 (G2R (+ _UgG 0.0)) (/  HT 3.0)))
	       ;(command "_PLINE" _W1 _W2 _W3 _W4 "_c")
	       (setq _S (ssget "_CP" (list _W1 _W2 _W3 _W4 _W1)))
	       (IF (= _S nil) (progn
		 ;(command "_TEXT" "_j" "_C" (seredina _W3 _W4) (+ _UgG 0.0) (rtos _UgG 2 2))
		 (setq A (List (distance (seredina _W1 _W2) (seredina _P1 _P2)) (seredina _W3 _W1) (seredina _W1 _W3)))
		 (setq _DIS 0.0)
		)) 
	 )
(princ) (setq A A)
)
;############################################################################
;############################################################################
;############################################################################
;############################################################################
;############################################################################
;############################################################################
;############################################################################
;############################################################################
;############################################################################
;############################################################################
(defun SEREDINA (TE1 TE2 / AA DX DY DZ)
    (setq DX (/ (+ (car TE1) (car TE2)) 2.0))
    (setq DY (/ (+ (cadr TE1) (cadr TE2)) 2.0))
    (setq DZ 0.0)
    (if (and (/= (caddr TE1) NIL) (/= (caddr TE2) NIL))
        (progn
            (setq DZ (/ (+ (caddr TE1) (caddr TE2)) 2.0))
        )
    )
    (setq AA (list DX DY DZ))
) ;END DEFUN


;###############################################################################
;###############################################################################  
;;--------------------------------------------------------
;; Функция получает строковое представление ObjectID
;; вне зависимости от того AutoCAD x86 или x64
;; Источник: https://discussion.autodesk.com/forums/message.jspa?messageID=6172961
;;--------------------------------------------------------
(defun get-objectid-x86-x64 (obj / util)
  (setq util (vla-get-utility (vla-get-activedocument (vlax-get-acad-object))))
  (if (= (type obj) 'ename)
    (setq obj (vlax-ename->vla-object obj))
    ) ;_ end of if
  (if (= (type obj) 'vla-object)
    (if (> (vl-string-search "x64" (getvar "platform")) 0)
      (vlax-invoke-method util "GetObjectIdString" obj :vlax-false)
      (rtos (vla-get-objectid obj) 2 0)
      ) ;_ end of if
    ) ;_ end of if
  ) ;_ end of defun  
  ;###############################################################################
  
  
  
;###############################################################################
;Программа создания поля, отображающего, длину указанного отрезка
;###############################################################################
(defun InsFld (_obj _T1 / adoc ent pt)
 
(vl-load-com)
  (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
  (if (and (= (type
                (setq
                  ent (vl-catch-all-apply
                        (function
                          (lambda ()
                            (vlax-ename->vla-object
                              _Obj ;(car (entsel "\nУкажите отрезок, полилинию или сплайн <Отмена> : ")) ;_ end of car
                              ) ;_ end of vlax-ename->vla-object
                            ) ;_ end of lambda
                          ) ;_ end of function
                        ) ;_ end of vl-catch-all-apply
                  ) ;_ end of setq
                ) ;_ end of type
              'vla-object
              ) ;_ end of =
           (vlax-property-available-p ent 'length)
           (= (type (setq pt (vl-catch-all-apply
                               (function
                                 (lambda ()
		                        _T1 ; (getpoint "\nУкажите точку для простановки поля <Отмена> : ")
                                   ) ;_ end of lambda
                                 ) ;_ end of function
                               ) ;_ end of vl-catch-all-apply
                          ) ;_ end of setq
                    ) ;_ end of type
              'list
              ) ;_ end of =
           pt
           ) ;_ end of and
    (vla-addtext
      (vla-objectidtoobject
        adoc
        (vla-get-ownerid ent)
        ) ;_ end of vla-ObjectIDToObject
      (strcat "%<\\AcObjProp Object(%<\\_ObjId "
              (vl-princ-to-string (get-objectid-x86-x64 ent))
              ">%).Length \\f \"%lu6\">%"
              ) ;_ end of strcat
      (vlax-3d-point pt)
      250
      ) ;_ end of vla-addtext
    ) ;_ end of if
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun



(defun PSW1 ( _e1 _Pt1 /)
  (vl-load-COM)
  (and
    ;(setq _e1 (car(entsel "\nВыбери полилинию-контур: ")))
    ;(setq _pt1 (getpoint "\nУкажи точку (не на контуре): "))
    (setq _pt2 (vlax-curve-getclosestpointto _e1 _pt1)) ;_ см п.2 пост #20
    (setq _pt3 (vlax-curve-getFirstDeriv _e1 (vlax-curve-getParamAtPoint _e1 _pt2)));_ см п.3 пост #20
    (setq _pt1 (mapcar '- _pt1 _pt2))
    (setq _ang (3d_Wnorm _pt1 _pt3)) ;_ см п.4 пост #20
    (if (lib:pline_clockwise _e1) ;;; если контур по часовой стрелке
      (progn
        ;;;Если бы точка была снаружи, то угол был бы отрицательным
        (if (minusp (last _ang))
          (setq _Kon 0);(alert "Точка снаружи")
          (setq _Kon 1);(alert "Точка внутри")
          )
        )
      (progn  ;;; если контур против часовой стрелки
        (if (minusp (last _ang))
          (setq _Kon 1) ;(alert "Точка внутри")
          (setq _Kon 0);(alert "Точка снаружи")
          )
        )
      )
    )
  (setq _kon _Kon)
  )

;********************************
; Векторное произведение векторов
;********************************
; W1, W2 - вектора
; Возвращает: вектор нормали к плоскости заданной векторами  в правой системе координат.
;W1 и W2 не должны лежать на одной прямой).
(defun 3d_Wnorm (W1 W2)
  (if (< (length W1) 3)(setq W1 (list (car W1)(cadr W1) 0)))
  (if (< (length W2) 3)(setq W2 (list (car W2)(cadr W2) 0)))
  (list (- (* (cadr W1)(caddr W2))(* (caddr W1)(cadr W2)))
        (- (* (caddr W1)(car W2)) (* (car W1)(caddr W2)))(- (* (car W1)(cadr W2)) (* (cadr W1)(car W2))))
  )


(defun lib:pline_clockwise ( lw  / LST MAXP MINP)
  
(if (= (type lw) 'ENAME)
    (setq lw (vlax-ename->vla-object lw)))  
		(vla-GetBoundingBox lw 'MinP 'MaxP)
		(setq
			minp(vlax-safearray->list minp)
			MaxP(vlax-safearray->list MaxP)
			lst(mapcar(function(lambda(x)
			(vlax-curve-getParamAtPoint lw
			(vlax-curve-getClosestPointTo lw x))))
			(list minp(list(car minp)(cadr MaxP))MaxP(list(car MaxP)(cadr minp))))
		)
		(if(or
			(<=(car lst)(cadr lst)(caddr lst)(cadddr lst))
			(<=(cadr lst)(caddr lst)(cadddr lst)(car lst))
			(<=(caddr lst)(cadddr lst)(car lst)(cadr lst))
			(<=(cadddr lst)(car lst)(cadr lst)(caddr lst)))
		  t nil)
  )
 ;************************************************************************
 ;************************************************************************
 ;************************************************************************
  ; ПРОВЕРКА НАЛИЧИЯ СЛОЯ
; Пример вызова (member "LyrName" (LayerNameList))
(defun LayerNameList ( / res)
  (setq res '())
  (vlax-for lyr (vla-get-Layers (vla-get-ActiveDocument (vlax-get-acad-object)))
    (setq res (cons (vla-get-Name lyr) res))
  )
  (cond (res (acad_strlsort res)))
)
 ;************************************************************************
 ;************************************************************************
;************************************************************************
 ; Функция переводит градусы в радианы
 ; Параметр  - угол в градусах
 ;************************************************************************
(defun G2R (GG / AA _n)
      (setq _n (fix (/ GG 360.0)))
    (setq GG (- GG (* _n 360.0))) 
    (setq AA (/ (* pi GG) 180.0))
) ;END DEFUN
 ;************************************************************************
 ;************************************************************************
 ; Функция переводит радианы в  градусы 
 ; Параметр  - угол в радианах
 ;************************************************************************
(defun R2G (GG / AA _n)
    (setq AA (/ (* 180.0 GG) pi))
    (setq _n (fix (/ AA 360.0)))
    (setq AA (- AA (* _n 360.0)))
) ;END DEFUN
 ;************************************************************************
 ;************************************************************************
 ;************************************************************************
 ;***************************************************
 ; Функция определения длины текста
 ; параметр - имя примитива (car (entsel))
 ;***************************************************
(defun TXTLEN (_EN / _E1 _ED _LENGTH1 _PT1 _PT2)
    (setq _ED (entget _EN))
    (if
        (= "TEXT" (cdr (assoc 0 _ED)))
           (progn
               (setq _E1 _ED)
               (setq _ED (subst (cons 72 2) (assoc 72 _ED) _ED))
               (entmod _ED)
               (setq _ED (entget _EN))
               (setq _PT1 (cdr (assoc 10 _ED)))
               (setq _PT2 (cdr (assoc 11 _ED)))
               (setq _LENGTH1 (distance _PT1 _PT2))
               (setq _ED _E1)
               (entmod _ED)
           ) ; progn
    ) ; if
    (if (/= "TEXT" (cdr (assoc 0 _ED)))
        (setq _LENGTH1 NIL)
    )
    (setq _LENGTH1 _LENGTH1)
) ; end defun txtlen
 ;***************************************************
;****************************************************************
; Функция возвращает список всех точек полилинии
; первый элемент кол-во точек полилинии
; ( 5 (0.0 0.0) (1.0 0.0)  (0.0 2.0) (5.0 5.0) (10.0 -20.0) 
;****************************************************************
(defun POLY (A1 / _P1 _A1 _A2 _TIP _A200 _N_MAX _N1 _N2 _I)
    (setq _A2 (entget A1))
    (setq _TIP (cdr (assoc 0 _A2)))
    (setq _A200 NIL)
 ;**************************************************************
    (if (= _TIP "LWPOLYLINE")
        (progn
            (setq _N_MAX (length _A2))
            (setq _I 0)
            (setq _ii 0)
            (repeat _N_MAX
                (setq _SP (nth _I _A2))
                (if (= (car _SP) 10)
                    (progn
                    (setq _A200 (cons (cdr _SP) _A200))
                    (if (= _ii 0) (setq _T0 (cdr _SP)))
                    (setq _ii 1)
                ))
                		
                (setq _I (+ 1 _I))
            ) ;Repeat
            					(setq _CLOSE (cdr (assoc 70 _A2)))
            					(IF (= _CLOSE 1) (setq _A200 (cons _T0 _A200)))
            (setq _N_MAX (length _A200))
            (setq _A200 (reverse _A200))
            (setq _A200 (cons _N_MAX _A200))            
        ) ;progn
    ) ;if
 ;**************************************************************
 ;**************************************************************
    (if (= _TIP "LINE")
        (progn
            (setq N1 (cdr (assoc 10 _A2)))
            (setq N2 (cdr (assoc 11 _A2)))
            (setq _A200 (list 2 N1 N2))
        ) ;progn
    ) ;if
;***************************************************************    
    (if (= _TIP "SOLID")
        (progn
            (setq N1 (cdr (assoc 10 _A2)))
            (setq N2 (cdr (assoc 11 _A2)))
            (setq N3 (cdr (assoc 12 _A2)))
            (setq N4 (cdr (assoc 13 _A2)))
            (setq _A200 (list 4 N1 N2 N3 N4))
        ) ;progn
    ) ;if
;***************************************************************    
(setq _A200 _A200)
);END DEFUN
 ;******************************************************************


;; gc:UcsBoundingBox - Lee Mac
;; Returns the UCS coordinates of the object bounding box about current UCS
;;
;; Arguments
;; obj: an entity (ENAME or VLA-OBJCET)
;; _OutputMinPtSym: a quoted symbol (output)
;; _OutputMaxPtSym: a quoted symbol (output)
(defun gc:UcsBoundingBox ( obj _OutputMinPtSym _OutputMaxPtSym )
(and (= (type obj) 'ename)
(setq obj (vlax-ename->vla-object obj))
)
(vla-transformby obj (vlax-tmatrix (gc:TMatrixFromTo 1 0)))
(vla-getboundingbox obj _OutputMinPtSym _OutputMaxPtSym)
(vla-transformby obj (vlax-tmatrix (gc:TMatrixFromTo 0 1)))
(set _OutputMinPtSym (vlax-safearray->list (eval _OutputMinPtSym)))
(set _OutputMaxPtSym (vlax-safearray->list (eval _OutputMaxPtSym)))
)
;; gc:TMatrixFromTo
;; Returns the 4X4 transformation matrix from a coordinate system to an other one
;;
;; Arguments
;; from to: same arguments as for the 'trans' function
(defun gc:TMatrixFromTo ( from to )
(append
(mapcar
(function
(lambda ( v o )
(append (trans v from to t) (list o))
)
)
'(
(1.0 0.0 0.0)
(0.0 1.0 0.0)
(0.0 0.0 1.0)
)
(trans '(0.0 0.0 0.0) to from)
)
'((0.0 0.0 0.0 1.0))
)
)


(defun plv1 (plyn / K listvert ) ;список вершин полилинии без излишеств
 
 
       (setq k 0) 
       (while 
    (not 
      (vl-catch-all-error-p 
        (vl-catch-all-apply 
          (function 
       (lambda (x) 
         (setq vert     (vla-get-coordinate x k) 
          listvert (cons vert listvert) 
         ) ;_ end of setq 
       ) ;_ end of lambda 
          ) ;_ end of function 
          (list  plyn)
        ) ;_ end of vl-catch-all-apply 
      ) ;_ end of VL-CATCH-ALL-ERROR-P 
    ) ;_ end of not 
     (setq k (1+ k)) 
       ) ;_ end of while 
       (setq listvert (mapcar 'vlax-safearray->list 
               (mapcar 'vlax-variant-value listvert) 
            ) ;_ end of mapcar 
       ) ;_ end of setq
    

) ;_ end of defun 


;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun min_dist_inters (ent1 ent2 / l1_pl l2_pl dist_list minp maxp
		       )
  (setq dist_list nil)

	(vl-cmdf "_ucs" "_OB" ent1)
	(gc:UcsBoundingBox ent1 'minp 'maxp)
	(setq l1_pl (list
			     (trans (list (car minp) (cadr minp) (caddr minp)) 1 0)
			     (trans (list (car minp) (cadr maxp) (caddr minp)) 1 0)
			     (trans (list (car maxp) (cadr maxp) (caddr minp)) 1 0)
			     (trans (list (car maxp) (cadr minp) (caddr minp)) 1 0)
	           )
	)
	(vl-cmdf "_ucs" "_p")

	(vl-cmdf "_ucs" "_OB" ent2)
	(gc:UcsBoundingBox ent2 'minp 'maxp)
	(setq l2_pl (list
			     (trans (list (car minp) (cadr minp) (caddr minp)) 1 0)
			     (trans (list (car minp) (cadr maxp) (caddr minp)) 1 0)
			     (trans (list (car maxp) (cadr maxp) (caddr minp)) 1 0)
			     (trans (list (car maxp) (cadr minp) (caddr minp)) 1 0)
	           )
	)
	(vl-cmdf "_ucs" "_p")  
 
  (foreach x l1_pl
    (foreach y l2_pl
	     (setq dist_list (append dist_list (list (distance x y))))
    )
  )
  (setq dist_list (vl-sort dist_list (function (lambda (e1 e2)
					          (< e1 e2)
					       )
			             )
	          )
  )
  (car dist_list)
)



;;;;;;;;;функция зачистки;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;функция зачистки;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;функция зачистки;;;;;;;;;;;;;;;;;;;;
(defun cleanup (dim_list pob inner inner_walls
	       /
	       ACHIVEMENT CUR_POS CUR_WIDTH_F DIM_LIST_1 FLAG KILL_LIST OBSTRUCT0 OBSTRUCT1 OBSTRUCT2 ONLY_ONE_INTERS SS0 TEXTBOX1 X_KILL_FLAG Y
	       )
 (setq dim_list (vl-sort dim_list (function (lambda (e1 e2)
					      (< (cadr e1) (cadr e2))
					    )
			          )
	        )
 ); сортировка
 (setq dim_list_1 dim_list);используется в конце для сверки и зачистки

 (foreach x dim_list
   (setq y nil flag nil only_one_inters nil achivement nil obstruct1 nil obstruct2 nil obstruct0 nil x_kill_flag nil);предполагаем плохой вариант - пересечения есть  и не одно.

    (setq flag (inters_detect x dim_list pob inner inner_walls)); первая проверка пересечений
    (if (cdr (assoc "pob1_flag" (car flag))); если при даннном варианте единич. пересечение
		  (setq only_one_inters (list
					  (cons "align_1" (vla-get-Alignment (vlax-ename->vla-object (car x))))
					  (cons "width_1"(vla-get-ScaleFactor (vlax-ename->vla-object (car x))))
				        )
		  )
    )
    (if (cdr (assoc "pob_flag" (car flag))) (setq achivement (append achivement ;сколько на хвосте при каких обстоятельствах
									     (list (list
									       (cons "trail" (length (cadr flag)))
									       (cons "align_1" (vla-get-Alignment (vlax-ename->vla-object (car x))))
									       (cons "width_1"(vla-get-ScaleFactor (vlax-ename->vla-object (car x))))								       
									     ))  
							     )
					    )
    )  
   
    (if (cdr (assoc "general_flag" (car flag)));если проверка выше не пройдена - двигаемся дальше
      (progn
      	(vla-put-Alignment (vlax-ename->vla-object (car x)) acAlignmentMiddleRight);изначально размеры выровнены по центру. пробуем подвигать сначала вправо
	(vla-update (vlax-ename->vla-object (car x)));@@@@@@@@@@@@@@@@@@@@@@@@
	(setq flag (inters_detect x dim_list pob inner inner_walls)); проверка того, что получилось
	(if (cdr (assoc "pob1_flag" (car flag))); если при даннном варианте единич. пересечение
		  (setq only_one_inters (list
					  (cons "align_1" (vla-get-Alignment (vlax-ename->vla-object (car x))))
					  (cons "width_1"(vla-get-ScaleFactor (vlax-ename->vla-object (car x))))
				        )
		  )
	)
        (if (cdr (assoc "pob_flag" (car flag))) (setq achivement (append achivement ;сколько на хвосте при каких обстоятельствах
									     (list (list
									       (cons "trail" (length (cadr flag)))
									       (cons "align_1" (vla-get-Alignment (vlax-ename->vla-object (car x))))
									       (cons "width_1"(vla-get-ScaleFactor (vlax-ename->vla-object (car x))))								       
									     ))  
							     )
					    )
        ) 	
      ); eo progn
    );eo if

    
    
    (if (cdr (assoc "general_flag" (car flag)));если проверка выше не пройдена - двигаемся дальше
	      (progn
	      	(vla-put-Alignment (vlax-ename->vla-object (car x)) acAlignmentMiddleLeft);потом влево
		(vla-update (vlax-ename->vla-object (car x)));@@@@@@@@@@@@@@@@@@@@@@@@
		(setq flag (inters_detect x dim_list pob inner inner_walls)); проверка того, что получилось
		(if (cdr (assoc "pob1_flag" (car flag))); если при даннном варианте единич. пересечение
			  (setq only_one_inters (list
						  (cons "align_1" (vla-get-Alignment (vlax-ename->vla-object (car x))))
						  (cons "width_1"(vla-get-ScaleFactor (vlax-ename->vla-object (car x))))
					        )
			  )
		)
	        (if (cdr (assoc "pob_flag" (car flag))) (setq achivement (append achivement ;сколько на хвосте при каких обстоятельствах
									     (list (list
									       (cons "trail" (length (cadr flag)))
									       (cons "align_1" (vla-get-Alignment (vlax-ename->vla-object (car x))))
									       (cons "width_1"(vla-get-ScaleFactor (vlax-ename->vla-object (car x))))								       
									     ))   
								     )
						    )
	        ) 		
	      ); eo progn

    )
    
    (if (and (cdr (assoc "general_flag" (car flag))) achivement);если проверка выше не пройдена - двигаемся дальше. пробуем просто отодвинуть. без других условий
	      (progn
		 (setq achivement (vl-sort achivement (function (lambda (e1 e2)
							            (< (cdar e1) (cdar e2))
						                )
					              )
			          )
		 ); сортировка
		(vla-put-Alignment (vlax-ename->vla-object (car x)) (cdr (assoc "align_1" (car achivement))));ставим вариант, когда перечечений меньше всего
		(vla-put-ScaleFactor (vlax-ename->vla-object (car x)) (cdr (assoc "width_1" (car achivement))));ставим вариант, когда перечечений меньше всего
		(setq textbox1 (textbox (entget (car x))))
		(vla-put-TextAlignmentPoint
		      (vlax-ename->vla-object (car x))
		      (vlax-3d-point
			      (polar
				(vlax-safearray->list (vlax-variant-value (vla-get-TextAlignmentPoint (vlax-ename->vla-object (car x)))))
				(nth 2 x)
				(* 0.6 (- (caadr textbox1) (caar textbox1)))
				;(* 1.2 (vla-get-Height (vlax-ename->vla-object (car x))))
			      ); eo polar
		      );eo vlax-3d-point
		); eo vla-put-TextAlignmentPoint  		
		(vla-update (vlax-ename->vla-object (car x)));@@@@@@@@@@@@@@@@@@@@@@@@
		(setq flag (inters_detect x dim_list pob inner inner_walls)); проверка того, что получилось
		
	      ); eo progn

    )   
   
     
  ;не помогло? а может угловые? тогда один подвинуть
    (if (and (cdr (assoc "general_flag" (car flag)))
	     (or (cdr (assoc "pob1_flag" (car flag))) only_one_inters)
	);eo and - если пересечения остались, но только одно или был отмечен вариант, когда пересечение только одно
      (progn;пошла передвижка
	(if (and (not (cdr (assoc "pob1_flag" (car flag)))) only_one_inters); если вариант, когда было одно пересечение, сбит - возвращаем его
	  (progn
		(vla-put-Alignment (vlax-ename->vla-object (car x)) (cdr (assoc "align_1" only_one_inters)));ставим вариант, когда перечечение только одно
		(vla-put-ScaleFactor (vlax-ename->vla-object (car x)) (cdr (assoc "width_1" only_one_inters)));ставим вариант, когда перечечение только одно
	        (vla-put-TextAlignmentPoint (vlax-ename->vla-object (car x)) (vlax-3d-point(nth 4 x)));ставим на место, если вдруг неудачно сместился в пред. пункте
	        (vla-update (vlax-ename->vla-object (car x)));@@@@@@@@@@@@@@@@@@@@@@@@
	        (setq flag (inters_detect x dim_list pob inner inner_walls))
	  );eo progn
	);eo if
	
	(setq obstruct1 (inters_detect1 x (cadr flag) pob));двигаем текущий размер и получаем ename того размера, что мешает или мешал
	(setq obstruct2 (car (vl-member-if '(lambda (y) (eq obstruct1 (car y))) dim_list)));расширенная версия того что мешает по структуре dim_list
	
	(vla-update (vlax-ename->vla-object (car x)));@@@@@@@@@@@@@@@@@@@@@@@@
	(setq flag (inters_detect x dim_list pob inner inner_walls));проверяем предпоследний раз
	(if (and
	      (cdr (assoc "general_flag" (car flag)))
	      obstruct2
	    )  ; если пересечение до сих пор есть
          (progn
	  	(inters_detect1 obstruct2 (list (car x)) pob);двигаем второго из пары
	        (vla-update (vlax-ename->vla-object (car obstruct2)));@@@@@@@@@@@@@@@@@@@@@@@@
	    	(setq flag (inters_detect x dim_list pob inner inner_walls));проверяем последний раз
	  ); eo progn
	 );eo if
	;по второму разу
	(if (and
	      (cdr (assoc "general_flag" (car flag)))
	      obstruct2
	    )  ; если пересечение до сих пор есть
          (progn
	  	(inters_detect1 obstruct2 (list (car x)) pob);двигаем второго из пары
	        (vla-update (vlax-ename->vla-object (car obstruct2)));@@@@@@@@@@@@@@@@@@@@@@@@
	    	(setq flag (inters_detect x dim_list pob inner inner_walls));проверяем последний раз
	  ); eo progn
	 );eo if 	
;^^^^^^^^^^^^^^^^^^^^^^^^^^^^^если все совсем плохо^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
	 (if  (cdr (assoc "general_flag" (car flag)))
          	(progn
		        (vla-put-TextAlignmentPoint (vlax-ename->vla-object (car x)) (vlax-3d-point(nth 4 x)));ставим на место, если вдруг неудачно сместился в пред. пункте
		        (vla-update (vlax-ename->vla-object (car x)));@@@@@@@@@@@@@@@@@@@@@@@@
		  	(setq flag (inters_detect x dim_list pob inner inner_walls))
		  	(setq obstruct0 (car (vl-member-if '(lambda (y) (eq (caadr flag) (car y))) dim_list)));что еще мешает - расширенная версия по структуре dim_list
		        (if obstruct0
			  (progn
			        (setq textbox1 (textbox (entget (car obstruct0))))
				(vla-put-TextAlignmentPoint
				      (vlax-ename->vla-object (car obstruct0))
				      (vlax-3d-point
					      (polar
						(vlax-safearray->list (vlax-variant-value (vla-get-TextAlignmentPoint (vlax-ename->vla-object (car obstruct0)))))
						(nth 2 obstruct0)
						(* 0.4 (- (caadr textbox1) (caar textbox1)))
						;(* 1.1 (min_dist_inters (car ent)  (car text_int_list)))
						;(* 1.2 (vla-get-Height (vlax-ename->vla-object (car obstruct0))))
					      ); eo polar
				      );eo vlax-3d-point
				); eo vla-put-TextAlignmentPoint  		
			        (vla-update (vlax-ename->vla-object (car obstruct0)));@@@@@@@@@@@@@@@@@@@@@@@@
			    	(setq flag (inters_detect x dim_list pob inner inner_walls));проверяем самый последний раз
			        (if  (cdr (assoc "general_flag" (car flag)))
				  (progn
					(vla-put-TextAlignmentPoint
					      (vlax-ename->vla-object (car obstruct0))
					      (vlax-3d-point
						      (polar
							(vlax-safearray->list (vlax-variant-value (vla-get-TextAlignmentPoint (vlax-ename->vla-object (car obstruct0)))))
							(nth 2 obstruct0)
							(* 0.5 (- (caadr textbox1) (caar textbox1)))
							;(* 1.1 (min_dist_inters (car ent)  (car text_int_list)))
							;(* 1.2 (vla-get-Height (vlax-ename->vla-object (car obstruct0))))
						      ); eo polar
					      );eo vlax-3d-point
					); eo vla-put-TextAlignmentPoint
				    (vla-update (vlax-ename->vla-object (car obstruct0)));@@@@@@@@@@@@@@@@@@@@@@@@
				    (setq flag (inters_detect x dim_list pob inner inner_walls));проверяем самый распоследний раз
				  )
			       )	  
			  )
			)  
		)
	   )  ; eo if

	
       	  
        );eo progn


    );eo if - проверка угловых

   ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    ;если просто так не получилось - возвращаем выравнивание и позицию назад и пробуем сузить, потом подвигать
    (if (cdr (assoc "general_flag" (car flag)));если проверка выше не пройдена - двигаемся дальше
      (progn
		(vla-put-Alignment (vlax-ename->vla-object (car x)) acAlignmentMiddleCenter)
	        (vla-put-TextAlignmentPoint (vlax-ename->vla-object (car x)) (vlax-3d-point(nth 4 x)))
		(if obstruct0 (vla-put-TextAlignmentPoint (vlax-ename->vla-object (car obstruct0)) (vlax-3d-point(nth 4 obstruct0))))
		(if obstruct2 (vla-put-TextAlignmentPoint (vlax-ename->vla-object (car obstruct2)) (vlax-3d-point(nth 4 obstruct2))))
		(vla-put-ScaleFactor (vlax-ename->vla-object (car x))
			(* 0.75 (vla-get-ScaleFactor (vlax-ename->vla-object (car x))))
	      	)
		(vla-update (vlax-ename->vla-object (car x)));@@@@@@@@@@@@@@@@@@@@@@@@
		(setq flag (inters_detect x dim_list pob inner inner_walls)); проверка того, что получилось
		(if (cdr (assoc "pob1_flag" (car flag))); если при даннном варианте единич. пересечение
			  (setq only_one_inters (list
						  (cons "align_1" (vla-get-Alignment (vlax-ename->vla-object (car x))))
						  (cons "width_1"(vla-get-ScaleFactor (vlax-ename->vla-object (car x))))
					        )
			  )
		)
	        (if (cdr (assoc "pob_flag" (car flag))) (setq achivement (append achivement ;сколько на хвосте при каких обстоятельствах
									     (list (list
									       (cons "trail" (length (cadr flag)))
									       (cons "align_1" (vla-get-Alignment (vlax-ename->vla-object (car x))))
									       (cons "width_1"(vla-get-ScaleFactor (vlax-ename->vla-object (car x))))								       
									     ))  
								     )
						    )
	        ) 	
	);eo progn
	
    )
	
      
   
    (if (cdr (assoc "general_flag" (car flag)));если проверка выше не пройдена - двигаемся дальше
	      (progn
	      	(vla-put-Alignment (vlax-ename->vla-object (car x)) acAlignmentMiddleRight);снова вправо
		(vla-update (vlax-ename->vla-object (car x)));@@@@@@@@@@@@@@@@@@@@@@@@
		(setq flag (inters_detect x dim_list pob inner inner_walls)); проверка того, что получилось
		(if (cdr (assoc "pob1_flag" (car flag))); если при даннном варианте единич. пересечение
			  (setq only_one_inters (list
						  (cons "align_1" (vla-get-Alignment (vlax-ename->vla-object (car x))))
						  (cons "width_1"(vla-get-ScaleFactor (vlax-ename->vla-object (car x))))
					        )
			  )
		)
	        (if (cdr (assoc "pob_flag" (car flag))) (setq achivement (append achivement ;сколько на хвосте при каких обстоятельствах
									     (list (list
									       (cons "trail" (length (cadr flag)))
									       (cons "align_1" (vla-get-Alignment (vlax-ename->vla-object (car x))))
									       (cons "width_1"(vla-get-ScaleFactor (vlax-ename->vla-object (car x))))								       
									     ))  
								     )
						    )
	        ) 		
	      ); eo progn

    )

    (if (cdr (assoc "general_flag" (car flag)));если проверка выше не пройдена - двигаемся дальше
	      (progn
	      	(vla-put-Alignment (vlax-ename->vla-object (car x)) acAlignmentMiddleLeft);потом влево
		(vla-update (vlax-ename->vla-object (car x)));@@@@@@@@@@@@@@@@@@@@@@@@
		(setq flag (inters_detect x dim_list pob inner inner_walls)); проверка того, что получилось
		(if (cdr (assoc "pob1_flag" (car flag))); если при даннном варианте единич. пересечение
			  (setq only_one_inters (list
						  (cons "align_1" (vla-get-Alignment (vlax-ename->vla-object (car x))))
						  (cons "width_1"(vla-get-ScaleFactor (vlax-ename->vla-object (car x))))
					        )
			  )
		)
	        (if (cdr (assoc "pob_flag" (car flag))) (setq achivement (append achivement ;сколько на хвосте при каких обстоятельствах
									     (list (list
									       (cons "trail" (length (cadr flag)))
									       (cons "align_1" (vla-get-Alignment (vlax-ename->vla-object (car x))))
									       (cons "width_1"(vla-get-ScaleFactor (vlax-ename->vla-object (car x))))								       
									     ))  
								     )
						    )
	        ) 		
	      ); eo progn

    )
   


   
    (if (cdr (assoc "general_flag" (car flag))) ;безнадежных фтопку. как вариант - можно на выключенный слой
      (progn
	;(vla-put-Layer (vlax-ename->vla-object (car x)) "del")
	(if obstruct2 (vla-put-TextAlignmentPoint (vlax-ename->vla-object (car obstruct2)) (vlax-3d-point(nth 4 obstruct2))));зря двигали второго из пары угловых. вернем на место
	(if obstruct0 (vla-put-TextAlignmentPoint (vlax-ename->vla-object (car obstruct0)) (vlax-3d-point(nth 4 obstruct0))))
	;(if (cdr (assoc "pob_flag" (car flag))) (Setq x_kill_flag T));зацепил контур - сразу фтопку
	(foreach q (cadr flag)
	  (if (vlax-property-available-p (vlax-ename->vla-object q) 'TextString)
		  (if (> (distof (vla-get-TextString (vlax-ename->vla-object (car x))))
			 (distof (vla-get-TextString (vlax-ename->vla-object q)))
		      )
		      (setq kill_list (append kill_list (list q)));если рассматриваемый элемент затрагивает мелочь пузатую, ее фтопку
		    ;else
		      (setq x_kill_flag T); если затрагивает кого-то крупнее себя - его самого фтопку
		  )
	  )
	)
	
	(if (and kill_list (not x_kill_flag))
	  (foreach z kill_list
	    (if (entget z)
	    	(vla-delete (vlax-ename->vla-object z))
	    )  
	    ;(setq dim_list (vl-remove (car (vl-member-if '(lambda (i) (eq z (car i))) dim_list)) dim_list))
	  )
	)
	(if x_kill_flag (vla-delete (vlax-ename->vla-object (car x))))
	;(setq flag (inters_detect x dim_list pob inner inner_walls))
	;(if (cdr (assoc "general_flag" (car flag))) (vla-delete (vlax-ename->vla-object (car x))))
	;(vla-put-color (vlax-ename->vla-object (car x)) acByLayer)
	
      );eo progn	
    ); eo if - если не помогло - удаляем

 );eo foreach x
  
 ;зачистка выпавших

	 (setq dim_list_1 (vl-remove-if-not '(lambda (y) (entget (car y))) dim_list_1))
	  
	 (foreach y dim_list_1
	     (if (not (vlax-erased-p (vlax-ename->vla-object (car y))))
	       (progn
		  (setq ss0 (ssget "_WP" (plv1 (vlax-ename->vla-object pob))))
		  (if ss0
			(if (not (ssmemb (car y) ss0))
			  (vla-delete (vlax-ename->vla-object (car y))); размер не внутри контура, все плохо. фтопку
			)
		        
	     	  )
	     	  (setq ss0 nil)
		);eo progn
	      )
	 )
  (if inner_walls
    (progn
	 (setq dim_list_1 (vl-remove-if-not '(lambda (y) (entget (car y))) dim_list_1))
	  
	 (foreach y dim_list_1
	     (if (not (vlax-erased-p (vlax-ename->vla-object (car y))))
	       (progn
		 (foreach z inner_walls
		  (setq ss0 (ssget "_CP" (plv1 (vlax-ename->vla-object z))))
		  (if ss0
			(if (ssmemb (car y) ss0)
			  (vla-delete (vlax-ename->vla-object (car y))); размер пересекает внутр. контур, все плохо. фтопку
			)
		        
	     	  )
	     	  (setq ss0 nil)
		 )  
		);eo progn
	      )
	 )
    )
  )  
  
 
	 ;зачистка неоправданно узких и сдвинутых
	 (setq dim_list_1 (vl-remove-if-not '(lambda (y) (entget (car y))) dim_list_1))
	 (foreach y dim_list_1
		  (setq cur_width_f (vla-get-ScaleFactor (vlax-ename->vla-object (car y))))
		  (vla-put-ScaleFactor (vlax-ename->vla-object (car y)) (nth 3 y))
	          (vla-update (vlax-ename->vla-object (car y)));@@@@@@@@@@@@@@@@@@@@@@@@   
		  (setq flag (inters_detect y dim_list_1 pob inner inner_walls))
		  (if (cdr (assoc "general_flag" (car flag)))
		    (vla-put-ScaleFactor (vlax-ename->vla-object (car y)) cur_width_f)
	          )
	   
	   	  (setq cur_pos (vla-get-TextAlignmentPoint (vlax-ename->vla-object (car y))))
	          (vla-put-TextAlignmentPoint (vlax-ename->vla-object (car y)) (vlax-3d-point(nth 4 y)))
	          (vla-update (vlax-ename->vla-object (car y)));@@@@@@@@@@@@@@@@@@@@@@@@   
		  (setq flag (inters_detect y dim_list_1 pob inner inner_walls))
		  (if (cdr (assoc "general_flag" (car flag)))
		    (vla-put-TextAlignmentPoint (vlax-ename->vla-object (car y)) cur_pos)
	          )   	  
	 )

)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;внутр. стены;;;;;;;;;;;;;;;;;;;;;;;;;
(defun inner_walls (boundary_object last_obj_before_bound HT
		    /
		    INNER_OBJECT INNER_OBJECTS_LIST io_points
		    DELTA  I P1 P2 SP T00 T1 T2 UGG UGR
		    dim_list_cur dim_list_inner_full Ob
		    )
  (if (not (eq (entnext last_obj_before_bound) boundary_object)) (setq inner_object (entnext last_obj_before_bound)))
  (setq	inner_objects_list nil)
  (if inner_object
    (progn
    	  (while (not (eq inner_object boundary_object))
		(setq inner_objects_list (append inner_objects_list (list inner_object)))
	        (vla-put-color (vlax-ename->vla-object inner_object) acblue)
		(setq inner_object (entnext inner_object))
	  )
	  (foreach io inner_objects_list
	    (setq io_points (plv1 (vlax-ename->vla-object io)))
	    (setq i 0 dim_list_cur nil)
	    (while (<= i (- (length io_points) 1))
	      (setq t1 (nth i io_points))
	      (if	(< i (- (length io_points) 1))
	        (setq t2 (nth (1+ i) io_points))
	        (setq t2 (nth 0 io_points))
	      )
	      (setq Delta (distance T1 T2))
	      (if (> (car T1) (car T2))
	        (setq P1 T2 P2 T1)
	        (setq P1 T1 P2 T2)
	      )
	      (setq UgR (angle P1 P2))
	      (setq UgG (r2g (angle P1 P2)))
	      (if (= (fix UgG) 270.0) (setq UgG 90.0))
	      (setq SP (PSW1 io (polar (seredina P1 P2) (G2R (- UgG 90.0)) 0.01))); 0.01 - размер "щупа" для определения направления сегмента полилинии. был 100. много!
	      (if (= SP 1) (setq T00 (polar (seredina T1 T2) (G2R (+ UgG 90.0)) (+ (* 0.5 HT) 100.0)) ))
	      (if (= SP 0) (setq T00 (polar (seredina T1 T2) (G2R (- UgG 90.0)) (+ (* 0.5 HT) 100.0)) ))
	      (command "_TEXT" "_j" "_MC" T00 (+ UgG 0.0) (rtos (/ Delta 1000.0) 2 2))
	      (setq Ob (entLAST))
	      (setq dim_list_cur (append dim_list_cur (list (list
							   Ob
							   (distof (vla-get-TextString (vlax-ename->vla-object Ob)))
							   (angle (seredina T1 T2) T00)
							   (vla-get-ScaleFactor (vlax-ename->vla-object Ob))
							   T00
		;;;					   (cons "dir_ang" (angle (seredina T1 T2) T00))
		;;;					   (cons "sc_f" (vla-get-ScaleFactor (vlax-ename->vla-object (entLAST))))
							 ))
			        )
	      )
	      (setq i (1+ i))
	    ); eo while i
	    ;(cleanup dim_list_cur io nil)
	    (setq dim_list_cur (vl-remove-if-not '(lambda (y) (entget (car y))) dim_list_cur))
	    (setq dim_list_inner_full (append dim_list_inner_full  dim_list_cur))
	  );eo foreach io	    
    )
  )
  (list dim_list_inner_full inner_objects_list)
)

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

М-да, код вызывает оторопь
В функции c:p2, похоже, идет генерация ошибки до того, как вызываются функции восстановления значения переменных. Проходи пошагово, выясняй, в каком именно месте геренируется ошибка.

[Wanted]

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

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

Ну тогда советую обратиться к автору кода.

[koMon]

закомментируйте сторку 153 в коде.

Сообщение от Wanted (setvar "osmode" osm)

----- добавлено через ~3 мин. -----

Сообщение от Кулик Алексей aka kpblc М-да, код вызывает оторопь

я бы хотел сказать по-другому…

[Wanted]

Дело в том что я не помню автора, я работал с 4-5ю авторами по разным вопросам) Осталось высчитать в блокноте 153-ю страницу.


Я туда строку вставил?
https://c2n.me/3SRXgsC

[koMon]

Сообщение от Wanted Я туда строку вставил?

её не нужно вставлять, её нужно закомментировать, поставить в начале ";"

[Wanted]

Спасибо попробую, просто я не знал что такое закомментировать.

[Wanted]

Сообщение от koMon её не нужно вставлять, её нужно закомментировать, поставить в начале ";"

Не помогло

[trushev]

Сообщение от Wanted Всем доброй ночи, помогите поправить LISP, при его использовании пропадают привязки. Помогите вернуть привязки по окончанию LISP-a. Благодарю Вас!

Не вникая в суть подам идею. Профи меня поправят.
Функцию

Код:

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

 ;бесконечный вызов
(defun c:p5 (/)
  (while T (c:p2))
)
Дополнить
(defun c:p5 (/
                   Именами используемых ниже функций
                  )
   Сохранением действующих значений системных переменных
  (while T (c:p2))
   Восстановлением значений переменных
); перенести скобку в последнею строку программы

[koMon]

Сообщение от Wanted Не помогло

Если выполнять P2, то возврат к привязкам должен осуществляться.
Если выполнять P5 с выходом из цикла по ошибке, то возврата не будет.
Если нужен такой цикл, для выполнения возврата, его нужно менять

----- добавлено через ~16 ч. -----
например цикл вызова P2 aka комманду P5 можно реализовать таким образом:

Код:

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

 (defun c:p5 (/)
	(while (= t (vl-catch-all-apply 'apply (list '(lambda (x) x) '(t))))
		(p2)
	)
)

но всё это будет выполняться корректно только пока где-то не случится выход по ошибке и поскольку на этот случай в коде ничего не предусмотрено, то привязки не вернутся опять.

всё-таки наверное не поможет…

Wanted, а что хоть делает это творение?

[Wanted]

Сообщение от koMon Wanted, а что хоть делает это творение?

Проставляет размеры стен, с последующим удалением, сдвигом или сужением наложенных размеров (для тех. планов)

видео:
https://youtu.be/iPOS3xs0V50.

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

----- добавлено через ~3 мин. -----
А если в коде поменять название P2 на Р5 это не поможет?

[koMon]

Сообщение от Wanted А если в коде поменять название P2 на Р5 это не поможет?

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

Сообщение от Wanted в последующем использовании на полилинии появляется ширина

ну тут всё-же лучше обратиться к автору…

[Wanted]

Спасибо, функция Р2 действительно возвращает привязки, но ширина остается. Нельзя ли найти строку в коде, которая присваивает полилинии ширину 35 мм. и кк-то поменять на 0? Мне эта ширина в принципе не нужна.

Все уже сам нашел. Всем спасибо, исправил код с минимумом правок.

[Alexll]

Всем привет.
Потратил день на то что бы изменить параметр видимости у атрибута динамического блока.
Добрался до атрибута, как я понял за видимость отвечает 60й код.

Код:

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

	(if (assoc 60 x)			; проверяю, есть ли в наборе "х" 60й код
	(subst nil '(60 . 1) x))        ; если есть, то пытаюсь его удалить (заменой на nil)

Если вывести значение получаемое командой subst, то там действительно 60й код заменен на nil, но в самом атрибуте изменения не происходят.
Подскажите пожалуйста как внести изменения в атрибут?
Желательно средствами Lisp, а не vla и не командами командной строки

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

Я пользую нечто типа

Код:

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

 (defun _kpblc-ent-modify-autoregen (ent bit value ent_regen / ent_list old_dxf new_dxf layer_dxf70)
                                   ;|
*    Функция модификации указанного бита примитива
*    Параметры вызова:
  entity     примитив, полученный через (entsel), (entlast) etc
  bit        dxf-код, значение которого надо установить
  value      новое значение
  ent_regen  выполнять или нет регенерацию примитива сразу. t/ nil
*    Примеры вызова:
(_kpblc-ent-modify-autoregen (entlast) 8 "0" t)  ; перенести последний примитив на слой 0
(_kpblc-ent-modify-autoregen (entsel) 62 10 nil)  ; установить выбранному примитиву цвет 10
*    Возвращаемое значение:
*  примитив с модифицированным dxf-списком. Примитив перерисовывается в
* зависимости от значения ключа ext_regen
|;
  (if (not (and (or (= (strcase (cdr (assoc 0 (entget ent))) nil) "STYLE")
                    (= (strcase (cdr (assoc 0 (entget ent))) nil) "DIMSTYLE")
                    (= (strcase (cdr (assoc 0 (entget ent))) nil) "LAYER")
                    ) ;_ end of or 
                (= bit 100)
                ) ;_ end of and 
           ) ;_ end of not 
    (progn (setq ent_list (entget ent)
                 new_dxf  (cons bit
                                (if (and (= bit 62) (= (type value) 'str))
                                  (if (= (strcase value) "BYLAYER")
                                    256
                                    0
                                    ) ;_ end of if 
                                  value
                                  ) ;_ end of if 
                                ) ;_ end of cons 
                 ) ;_ end of setq 
           (if (not (equal new_dxf (setq old_dxf (assoc bit ent_list))))
             (progn (entmod (if old_dxf
                              (subst new_dxf old_dxf ent_list)
                              (append ent_list (list new_dxf))
                              ) ;_ end of if 
                            ) ;_ end of entmod
                    (if ent_regen
                      (progn (entupd ent) (redraw ent))
                      ) ;_ end of if
                    ) ;_ end of progn 
             ) ;_ end of if 
           ) ;_ end of progn 
    ) ;_ end of if 
  ent
  ) ;_ end of defun

[Alexll]

Спасибо за пример. Но что то у меня с 1го класса сложно получается списывать ))). Сложно мне разбираться в чужих примерах, на пальцах проще.
С удалением dxf кода вроде разобрался. А как на счет добавления?
Когда я пытаюсь добавить с помощью такой конструкции:

Код:

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

 (entmod (list (cons 60 1) x))

Автокад пишет ошибку: "ошибка: неверная DXF-группа:". Полагаю что каждый dxf код должен стоять на своем месте, и не допускается установка когда в начало. Я правильно понимаю?
Если да, то что делать? разбивать dxf код посередине ,вставлять новую точечную пару туда, и соединять? Если да, то при помощи какой команды обычно идет разбиение?

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

Есть разница между list, cons и append. Проверни одно, второе, третье - и посмотри на результаты.

[Alexll]

append - у меня почему то вообще не получилось использовать. Жалуется на неверный список.
list действительно как то не так формирует список. Он их не сливает, а разделяет скобками
а вот cons - создает список похожий на правду. И даже entmod не ругается. Но точечная пара не добавляется, и атрибут не исчезает.
Самый правильный вариант(вроде). Но все равно не отрабатывает

Код:

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

(entmod (cons (cons 60 1) x))

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

А обновлять примитив кто будет? entupd на что существует?

----- добавлено через ~1 мин. -----
Какие результаты будут у такого:

Код:

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

 (setq att (car (nentsel "\nВыбери скрываемый объект ")))
(_kpblc-ent-modify-autoregen att 60 1 t)

[Alexll]

Для этого кода нужно какую то библиотеку подключать? ругается: ошибка: no function definition: _KPBLC-ENT-MODIFY-AUTOREGEN

Код:

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

 (setq att (car (nentsel "\nВыбери скрываемый объект ")))
(_kpblc-ent-modify-autoregen att 60 1 t)

Допустимо ли такое обновление? Или обязательно нудно по имени обновлять?

Код:

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

 (entupd (entmod (cons (cons 60 1) x)))

После обновления то же не работает. Да и я же смотрю, dxf код не поменялся. Точечная пара не появилась.

Пытаюсь еще как то так выйти из положения

Код:

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

 (entmod (subst '((8 . "Мой слой")(60 . 1)) '(8 . "Мой слой") x))

тут ему не нравится сдвоенная точечная пара '((8 . "Мой слой")(60 . 1))

[AlexSheep]

Alexll,

Сообщение от Alexll Для этого кода нужно какую то библиотеку подключать?

Загрузка файла Лисп

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

Alexll, код функции я приводил выше - бери, загружай, пользуй.
Прочитай справку, какие параметры понимает entupd.
И, кстати, "видимость" для слоя, кажется, особого смысла не имеет. Проще выключить.

[koMon]

Сообщение от Alexll Добрался до атрибута, как я понял за видимость отвечает 60й код.

А разве за видимость атрибута отвечает 60-я, а не 70-я группа?

Сообщение от Alexll а не vla

а почему не vla? ведь можно ревлизовать гораздо проще.

Код:

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

 (setq Attribute_to_hide_dxf_List (entget (setq Attribute_to_hide (car (nentsel "\nPick an Attribute to hide: "))))
      Attribute_to_hide_dxf_List (subst (cons 70 1) (assoc 70 Attribute_to_hide_dxf_List) Attribute_to_hide_dxf_List)
)
(entmod Attribute_to_hide_dxf_List)
(entupd Attribute_to_hide)

[Alexll]

Сообщение от Кулик Алексей aka kpblc Прочитай справку, какие параметры понимает entupd. И, кстати, "видимость" для слоя, кажется, особого смысла не имеет. Проще выключить.

Справка всегда под рукой (entupd <ename>), только лисп для меня сложен. Все делаю методом тыка. Никогда не знаю как оно заработает.
А почему видимость слоя? я меняю видимость атрибута блока, то есть примитива.

Сообщение от koMon а почему не vla? ведь можно ревлизовать гораздо проще.

vla совсем не понимаю. Но не отказываюсь. Несколько команд можно и применить.

Сообщение от koMon А разве за видимость атрибута отвечает 60-я, а не 70-я группа?

т.к. знаниями не обладаю, занимаюсь исследованиями. Сравнил код со скрытым параметром и с не скрытым. 70й код в обоих случаях равен нулю.
dxf коды отличаются только отсутствием или наличием 60й точечной пары.
У той таблички есть продолжение? можно на нее целиком взглянуть. Как то искал dxf коды, так и не нашел.

атрибут виден, и скрыт:

Код:

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

 
((-1 . <Имя объекта: 7ffff86baf0>) (0 . ATTRIB) (330 . <Имя объекта: 7ffff86ba20>) (5 . 33847) (100 . AcDbEntity) (67 . 0) (410 . Model) (8 . Электроосвещение)          (100 . AcDbText) (10 53102.9 -26081.6 0.0) (40 . 2.5) (1 . Гр.1) (50 . 0.0) (41 . 1.0) (51 . 0.0) (7 . Standard) (71 . 0) (72 . 0) (11 0.0 0.0 0.0) (210 0.0 0.0 1.0) (100 . AcDbAttribute) (280 . 0) (2 . ГРУППА) (70 . 0) (73 . 0) (74 . 0) (280 . 1))
((-1 . <Имя объекта: 7ffff86baf0>) (0 . ATTRIB) (330 . <Имя объекта: 7ffff86ba20>) (5 . 33847) (100 . AcDbEntity) (67 . 0) (410 . Model) (8 . Электроосвещение) (60 . 1) (100 . AcDbText) (10 53102.9 -26081.6 0.0) (40 . 2.5) (1 . Гр.1) (50 . 0.0) (41 . 1.0) (51 . 0.0) (7 . Standard) (71 . 0) (72 . 0) (11 0.0 0.0 0.0) (210 0.0 0.0 1.0) (100 . AcDbAttribute) (280 . 0) (2 . ГРУППА) (70 . 0) (73 . 0) (74 . 0) (280 . 1))

Может дело в том, что я не просто примитив прячу, или слой. Я прячу атрибут динамического блока. И для того что бы прятать этот атрибут, есть специальная ручка.

[kurstep]

Здравствуйте, подскажите кто знает... мне надо совместить в одном коде команду "command" ("vl-cmdf") и затем после выполнения обычный код типа :

Код:

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

 (vl-cmdf "_AecConvertToTable")
 (setq table (vlax-ename->vla-object (entlast)))
........

(команда _AecConvertToTable - из Autocad Architecture - она преобразует таблицу ADT в обычную акад таблицу,)
Но в таком случае вначале выполняется весь код, пропуская команду command (компьютер будто ее пролетает, а выполняет уже в конце кода) - мне же обязательна нужен порядок, чтобы вначале разбилась таблица а потом выполнялся код, Как этого добится?

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

Версия AA?

[koMon]

Сообщение от Alexll Я прячу атрибут динамического блока. И для того что бы прятать этот атрибут, есть специальная ручка.

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

[Alexll]

Сообщение от koMon Если есть специальная ручка у чего-нибудь в блоке, то это уже не атрибут, а динамический параметр у динамического блока. DWG и что нужно спрятать нужно показать бы.

Там только одна ручка для скрытия (ГРУППА - Гр2)
Дело в том, что показать блок, уже удалось, манипулирую свойствами атрибута. Поэтому и продолжаю идти в том же направлении.
Боролся с cons - вроде победил ,вроде что то понял.
Но есть другие вопросы, может кто подскажет?
1. Возможно ли при помощи subst заменить одну точечную пару на две? что бы они вошли в список, как точечные пары, а не как подсписок?
2. При добавление точечной пары в примитив, необходимо ставить точечную пару в то место, где она обычно стоит, или можно добавить в начало?

[kurstep]

Сообщение от Кулик Алексей aka kpblc Версия AA?

Версия AA - 2014rus
Ну я уже нашел выход, сделал так :

Код:

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

   (sssetfirst nil (ssget ))
  (setq pt0 nil)
(while (null pt0)
  (setq pt0 (getpoint "\nТочка левого верхнего угла таблицы: ")))

  
(vl-cmdf "_AecConvertToTable" pt0 )
 
 (setq table1 (vlax-ename->vla-object (entlast)))

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

А если

Код:

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

(vl-cmdf "_AecConvertToTable" pause)

??

[koMon]

Сообщение от Alexll Возможно ли при помощи subst заменить одну точечную пару на две?

Нет. Subst заменяет элемент списка на другой элемент списка. Если элемент списка ТП, то и замена должна быть одна ТП.

Сообщение от Alexll При добавление точечной пары в примитив, необходимо ставить точечную пару в то место, где она обычно стоит, или можно добавить в начало?

Я думаю, что ТП встанет на своё место после выполнения entmod.

----- добавлено через ~5 мин. -----

Сообщение от kurstep Там только одна ручка для скрытия (ГРУППА - Гр2)

Это атрибут в составе динамического параметра видимости. Нужно из лиспа управлять видимостью этого параметра?

[kurstep]

Сообщение от Кулик Алексей aka kpblc А если Код: [Выделить все] (vl-cmdf "_AecConvertToTable" pause) ??

Неа, так не получается

[Alexll]

Сообщение от koMon Нет. Subst заменяет элемент списка на другой элемент списка. Если элемент списка ТП, то и замена должна быть одна ТП.

Понял. спасибо, а то и дальше бы с этим вариантом бился... )

Сообщение от koMon Это атрибут в составе динамического параметра видимости. Нужно из лиспа управлять видимостью этого параметра?

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

[koMon]

Сообщение от Alexll Да. Хочу потом все выделить, и все спрятать, что бы на каждый не тыкать.

Чисто в качестве теста)

Код:

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

 
(defun c:Dyn_Visibility_Off ()
	(setq acad_Object (vlax-get-acad-object)
		  document_object (vla-get-ActiveDocument acad_Object)
		  document_Selection_sets (vla-get-SelectionSets document_object)
		  there_is_Blocks_Sset nil
	)
	(vlax-for selection_set document_Selection_sets
		(if (= "Blocks_Sset" (vla-get-name selection_set))
			(setq there_is_Blocks_Sset t
				  Blocks_sset_Object selection_set
			)
		)
	)
	(if there_is_Blocks_Sset
		(progn
			(vla-delete Blocks_sset_Object)
			(vlax-release-object Blocks_sset_Object)
			(setq Blocks_sset_Object (vla-Add document_Selection_sets "Blocks_Sset"))
		)
		(setq Blocks_sset_Object (vla-Add document_Selection_sets "Blocks_Sset"))
	)
	(setq group_Code (vlax-make-safearray vlax-vbInteger '(0 . 0))
		  vlax_function_executed (vlax-safearray-put-element group_Code 0 0)
	      data_Value (vlax-make-safearray vlax-vbVariant '(0 . 0))
	      vlax_function_executed (vlax-safearray-put-element data_Value 0 "INSERT")
		  vlax_function_executed (vl-catch-all-apply 'vla-SelectOnScreen (list Blocks_sset_Object group_Code data_Value))
	)

	(if (< (vla-get-count Blocks_sset_Object) 1)
		(princ "\nНичего не выбрано или команда прервана.")
		(progn
		    (vlax-for sset_block Blocks_sset_Object	(vla-highlight sset_block :vlax-true))
			(setq initget_setting (initget 1 "Показать Скрыть")
				  Visibility_Action (vl-catch-all-apply 'GetKWord (list "\nСвойство \"Видимость1\" [Показать/Скрыть]?"))
			)
			(vlax-for sset_block Blocks_sset_Object
				(if (> (vlax-safearray-get-u-bound (vlax-variant-value (vla-GetDynamicBlockProperties sset_block)) 1) 0)
						(if (setq visibility_object_found (car
															   (vl-member-if '(lambda (dyn_property) (= "Видимость1" (vla-get-PropertyName dyn_property)))
																		      (vlax-safearray->list (vlax-variant-value (vla-GetDynamicBlockProperties sset_block)))
														  	   )
														  )
							)
							(if (/= Visibility_Action (vla-get-PropertyName visibility_object_found))
								(vla-put-Value visibility_object_found Visibility_Action)
							)
						)
				)
				(vla-highlight sset_block :vlax-false)
			)
		)
	)
	(princ)
)

[Nike]

Товарищи дорогие, помогите!

Пытался вынуть содержимое из атрибута блока и напоролся на такую штуку - в описании атрибута дважды встречается список с его содержимым, причем первый список содержит только фрагмент, а полное содержимое во втором.
"(cdr (assoc 1 (entget ..." цепляет первый список. Как добраться до второго списка с полным текстом?

Код:

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

Команда: (entget(car(entsel)))
Выберите объект: ((-1 . <Имя объекта: 7ef2ef50>) (0 . "ATTDEF") (5 . "6A") (102 
. "{ACAD_XDICTIONARY") (360 . <Имя объекта: 7ef2ef58>) (102 . "}") (330 . <Имя 
объекта: 7ef2ec10>) (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . 
"BC-АТРИБУТЫ") (100 . "AcDbText") (10 -2.91064e-011 -13.8363 0.0) (40 . 2.5)
 (1 . "Шкаф для установки приборов системы") (50 . 0.0) (41 . 1.0) (51 . 0.0) (7 . 
"ISOCPEUR") (71 . 0) (72 . 0) (11 -2.91064e-011 -12.5863 0.0) (210 0.0 0.0 1.0) 
(100 . "AcDbAttributeDefinition") (280 . 0) (3 . "") (2 . "ТЕХНИЧЕСКАЯ_ХАР-КА") 
(70 . 9) (73 . 0) (74 . 2) (280 . 1) (71 . 4) (72 . 0) (11 -2.91064e-011 
-12.5863 0.0) (101 . "Embedded Object") (10 -2.91064e-011 -12.5863 0.0) (40 . 
2.5) (41 . 161.512) (46 . 0.0) (71 . 4) (72 . 5) (1 . "Шкаф для установки. 
приборов системы \"Орион\" на DIN рейки. Содержит источник \"РИП-12 RS\", 
автомат защиты по 220В и УЗО. Место для установки одного или двух батарей 
12В-17АЧ. ") (7 . "ISOCPEUR") (210 0.0 0.0 1.0) (11 1.0 0.0 0.0) (42 . 152.125) 
(43 . 7.41667) (50 . 0.0) (73 . 1) (44 . 1.0))

Пример блока во вложении.

[Сергей812]

еще бы сохраняли чертеж не из редактора блока)

[Nike]

Сергей812, это "wblock" мне так наэкспортировал.

[koMon]

Сообщение от Nike "(cdr (assoc 1 (entget ..." цепляет первый список. Как добраться до второго списка с полным текстом?

А если так?

Код:

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

 
(setq block_object (vlax-ename->vla-object (car (entsel "\nВыберите блок с атрибутами: ")))
      attributes_list (vlax-safearray->list (vlax-variant-value (vla-getattributes block_object)))
)
(princ "\n\n")
(foreach attribute_item attributes_list
  	(princ (strcat (vla-get-tagstring attribute_item) ": " (vla-get-textstring attribute_item) "\n"))
) 

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

Забыл про постоянные атрибуты...
Как один из вариантов:

Код:

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

 (defun _kpblc-block-attr-get-pointer-mask (blk mask / _kpblc-conv-vla-to-list)
                                          ;|
*    Получение списка атрибутов блока по маске. Учитываются также постоянные атрибуты.
*    Параметры вызова:
  blk      указатель на вставку блока. Без проверки типа.
  mask     строка с маской тэга атрибута
|;
  (defun _kpblc-conv-vla-to-list (value / res) ;|
*    Преобразовывает vlax-variant или vlax-safearray в список.
|;  (cond ((listp value) (mapcar (function _kpblc-conv-vla-to-list) value))
          ((= (type value) 'variant) (_kpblc-conv-vla-to-list (vlax-variant-value value)))
          ((= (type value) 'safearray)
           (if (>= (vlax-safearray-get-u-bound value 1) 0)
             (_kpblc-conv-vla-to-list (vlax-safearray->list value))
             ) ;_ end of if
           )
          ((vlax-property-available-p value 'count)
           (vlax-for sub (_kpblc-conv-ent-to-vla value) (setq res (cons sub res)))
           )
          (t value)
          ) ;_ end of cond
    ) ;_ end of defun
  (if (and blk
           (setq blk (cond ((= (type blk) 'ename) (vlax-ename->vla-object blk))
                           ((= (type blk) 'vla-object) blk)
                           ) ;_ end of cond
                 ) ;_ end of setq
           (wcmatch (strcase (vla-get-objectname blk)) "*BLOCKREF*")
           (or (and (vlax-property-available-p blk 'hasattributes)
                    (equal (vla-get-hasattributes blk) :vlax-true)
                    (> (vlax-safearray-get-u-bound (vlax-variant-value (vla-getattributes blk)) 1) -1)
                    ) ;_ end of and
               (and (vlax-method-applicable-p blk 'getconstantattributes)
                    (> (vlax-safearray-get-u-bound (vlax-variant-value (vla-getconstantattributes blk)) 1) -1)
                    ) ;_ end of and
               ) ;_ end of or
           ) ;_ end of and
    (progn (if (not mask)
             (setq mask "*")
             ) ;_ end ofif
           (vl-remove-if-not (function (lambda (x) (wcmatch (strcase (vla-get-tagstring x)) (strcase mask))))
                             (apply (function append)
                                    (mapcar (function _kpblc-conv-vla-to-list)
                                            (list (vla-getattributes blk) (vla-getconstantattributes blk))
                                            ) ;_ end of mapcar
                                    ) ;_ end of apply
                             ) ;_ end of vl-remove-if-not
           ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of defun

----- добавлено через ~1 мин. -----
Ну и пример вызова:

Код:

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

 (foreach att (_kpblc-block-attr-get-pointer-mask (car (entsel)) nil)
  (princ (strcat "\nTag : \"" (vla-get-tagstring att) "\"; value = \"" (vla-get-textstring att) "\""))
  ) ;_ end of foreach

[koMon]

Сообщение от Кулик Алексей aka kpblc Забыл про постоянные атрибуты...

ну, для нэофита, я думаю это простительно)

[Nike]

Кулик Алексей aka kpblc, koMon, спасибо, коды работают, но они работают собственно с блоками.
А я копаюсь в свойствах определения атрибута.

Вот в этом блоке текст из атрибута вообще размазался по двум группам
И как его поднять?

Код:

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

Команда: (entget(car(entsel)))
Выберите объект: ((-1 . <Имя объекта: 7ef61f50>) (0 . "ATTDEF") (5 . "6A") (102 
. "{ACAD_XDICTIONARY") (360 . <Имя объекта: 7ef61f58>) (102 . "}") (330 . <Имя 
объекта: 7ef61c10>) (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . 
"BC-АТРИБУТЫ") (100 . "AcDbText") (10 -2.91064e-011 -13.8363 0.0) (40 . 2.5) (1 
. "Адресный расширитель. Размещается внутри охранного") (50 . 0.0) (41 . 1.0) 
(51 . 0.0) (7 . "ISOCPEUR") (71 . 0) (72 . 0) (11 -2.91064e-011 -12.5863 0.0) 
(210 0.0 0.0 1.0) (100 . "AcDbAttributeDefinition") (280 . 0) (3 . "") (2 . 
"ТЕХНИЧЕСКАЯ_ХАР-КА") (70 . 9) (73 . 0) (74 . 2) (280 . 1) (71 . 4) (72 . 0) 
(11 -2.91064e-011 -12.5863 0.0) (101 . "Embedded Object") (10 -2.91064e-011 
-12.5863 0.0) (40 . 2.5) (41 . 93.2144) (46 . 0.0) (71 . 4) (72 . 5) (3 . 
"Адресный расширитель. Размещается внутри охранного извещателя, питается от 
двухпроводной линии, передает состояние контактов сигнального реле (на 
замыкание) и датчика вскрытия корпуса через «С2000-КДЛ» на пульт «С2000» или 
АРМ. Рабочая температура от")  (1 . " минус 30 до +50°С") (7 . "ISOCPEUR") (210 
0.0 0.0 1.0) (11 1.0 0.0 0.0) (42 . 0.0) (43 . 0.0) (50 . 0.0) (73 . 1) (44 . 
1.0))

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

Уже говорили - не надо было сохранять под редактором блоков.
Второе. Атрибут имеет как минимум 2 характеристики: TagString и TextString. Для многострочного атрибута есть еще и свойство MTextAttributeContent.

[Nike]

Кулик Алексей aka kpblc, спасибо, понятно. Что ничего не понятно.
Делал массовый экспорт блоков (много) из одного файла каждый блок в свой файл с помощью wblock - нашел несколько программ и все они в таком разблоченном виде выдают.
Чтоб в нормальном виде блоки были - не нашел.
Буду теперь искать способ все файлы массово заблочивать и читать уже атрибуты, а не их определения.

ЗЫ Wipeout-ы все наверх повылезают..

[koMon]

Сообщение от Nike А я копаюсь в свойствах определения атрибута.

ну тогда так?

Код:

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

 
(setq attdef_object (vlax-ename->vla-object (car (entsel "\nВыберите определение арибута: "))))
(princ "\n\n")
(princ (strcat (vla-get-tagstring attdef_object) ": " (vla-get-textstring attdef_object) "\n"))

[Nike]

koMon, да! Спасибище!!!

[sathalex]

Здравствуйте.
У меня в программе есть две переменные st1 и st2. Им назначено численное значение.

Код:

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

 (defun sl_check ()
(vl-load-com)
(vla-GetBoundingBox
    (vlax-ename->vla-object
      (car (entsel "\nУкажите объект <Esc для выхода>: ")))
    'minpt
    'maxpt)
  (setq st1 (rtos (last (vlax-safearray->list minpt)) 2 3))
  (setq st2 (rtos (last (vlax-safearray->list maxpt)) 2 3))
  )

Я пытаюсь создать третью переменную (разницу первых двух)

Код:

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

 (setq st3 (- st2 st1))

но ничего не выходит. Помогите советом, как это реализовать правильно.
Разобрался:

Код:

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

 (setq st3 (rtos (- (last (vlax-safearray->list maxpt)) (last (vlax-safearray->list minpt))) 2 3)

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

Сообщение от sathalex Им назначено численное значение.

Это было бы правдой, если бы не rtos

[mindchamber]

^C^Cразметить \ Б пс 2

Хочу сделать автоматический макрос для разметки линии блоком. Почему не работает? Спасибо

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

Выполняй команду через ком.строку и смотри на запросы. Это будет быстрее и проще, чем гадать.

[kurstep]

Всем привет, подскажите пожалуйста... Мне надо разбить мультилинию и получить все образовавшиеся из нее объекты(отрезки). Вначале думал все просто решаемо :

Код:

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

 (vlax-safearray->list (vlax-variant-value (vla-explode MultiLine)))

Но в итоге так не работает...
Все хорошо разбивается таким способом:

Код:

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

   (setq nabor1 (ssget))
(vl-cmdf "_.explode" nabor1)

Но как в таком случает получить указатели на полученные объекты?... entlast возвращает только один объект, а у меня их много

[Сергей812]

Сообщение от kurstep entlast возвращает только один объект, а у меня их много

а если вызвать entlast и запомнить последний объект БД перед разбивкой, а потом пройтись после разбивки в цикле entnext от запомненного ранее объекта?

[kurstep]

Сообщение от Сергей812 а если вызвать entlast и запомнить последний объект БД перед разбивкой, а потом пройтись после разбивки в цикле entnext от запомненного ранее объекта?

В таком случае в моей программке entlast может выдать указатель на Мультилинию - так как пользователь перед разбиением может как раз создать мультилинию, и мне кажется в таком случае комп будет ругаться на бесконечный цикл

[Сергей812]

Сообщение от kurstep В таком случае в моей программке entlast может выдать указатель на Мультилинию - так как пользователь перед разбиением может как раз создать мультилинию, и мне кажется в таком случае комп будет ругаться на бесконечный цикл

entlast используется только для получения текущего последнего объекта в БД чертежа, а когда разобьете мультилинию, то акад создаст новые объекты и добавит их в БД чертежа. И они будут идти после объекта, полученного ранее entlast. Просто при первом вызове entnext нужно что-то принять в роли отправной точки, и это будет объект - полученный по entlast. Что это будет за объект - в данном случае вообще не играет роли. А потом в цикле будете получать объект за объектом, пока не вернет nil. Соответственно, в качестве аргумента entnext надо будет подставлять предыдущий найденный элемент - или действительно цикл подвесите.

Ну или как вариант - разбивайте на отдельном вспомогательном слое, а потом разом сгребете все объекты полученные.

[koMon]

Сообщение от kurstep Мне надо разбить мультилинию и получить все образовавшиеся из нее объекты(отрезки).

Можно так. Выбрать млинию, определить и запомнить её прямоугольные границы. Взорвать млинию, выбрать отрезки рамкой/секрамкой по запомненным ранеет границам млинии.

[Сергей812]

Сообщение от koMon Можно так. Выбрать млинию, определить и запомнить её прямоугольные границы. Взорвать млинию, выбрать отрезки рамкой/секрамкой по запомненным ранеет границам млинии.

а если попадутся в пределах контейнера "чужие" отрезки - то это уже их проблемы)

[koMon]

Сообщение от Сергей812 это уже их проблемы)

пожалуй, это скорее неприятный нюанс

----- добавлено через ~20 мин. -----
но и его можно обойти, например, сделав предварительный набор по границам млинии, и если он будет не нулевой после удаления млинии, вычесть его из выделенных отрезков, после взрыва млинии.

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

Выбор по точкам будет работать только при одном условии - все точки, определяющие границы, видны на экране. Так охота тратить тьму времени на регенерацию чертежа?

[koMon]

Сообщение от Кулик Алексей aka kpblc Так охота тратить тьму времени на регенерацию чертежа?

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

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

Без проверок, насухую:

Код:

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

 (defun tt (/ ent lastent res)
(setq ent     (car (entsel "\nSelect MLINE : "))  lastent (entlast))
(command-s "_.explode" ent)
(while (setq lastent (entnext lastent)) (setq res (cons lastent res)))
(reverse res)
)

[kurstep]

Сообщение от Кулик Алексей aka kpblc Без проверок, насухую:

Кулик Алексей aka kpblc спасибо, все вроде работает, Но почему-то выдается такое окно... Никогда мне такую ошибку комп не выдавал, это как так?

[sdv79]

Подскажите как масштабировать vla способом последний активный объект?

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

kurstep, сейчас прогнал код на ACAD2016 (отладку другой задачи приостановил) - работает корректно, ошибки ядра не выдает
sdv79, см. vla-scaleentity

[sdv79]

Алексей спасибо, заработало)

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

только сейчас сообразил - а (command-s "_.explode" ent) случайно не надо завершать пустой строкой? А то как-то я с командными методами не очень...

[Сергей812]

Сообщение от Кулик Алексей aka kpblc (reverse res)

наверно, если нужно получить просто список примитивов после разбития - то можно исключить?

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

Ага, можно. Если действительно порядок не играет никакой роли.

[RrRR]

Сообщение от Кулик Алексей aka kpblc только сейчас сообразил - а (command-s "_.explode" ent) случайно не надо завершать пустой строкой? А то как-то я с командными методами не очень...

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

[VVA]

RrRR, Отслеживание объектов появившихся после pasteclip
Там две функции:
mip:mark - маркировка перед взрывом
mip:get-last-ss - возвращает ввиде набора вновь появившиеся объекты

[RrRR]

VVA, спасибо за ссылку!
А мой пост относился только к проверке лиспа Алексея #3550

[BithSachs]

Что я делаю не так?
ssget не хочет работать

Код:

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

 (defun c:ВРАЩАТЬ ()
	(setq ss (ssget "_P")
	(setq p1 (getpoint "/nПервая точка"))
	(setq p2 (getpoint "/nВторая точка"))
	(command "ПОВЕРНУТЬ" ss p1 "О" p1 p2)
	)
)

После "command", думаю, понятно, что я хочу сделать

[1958]

Сообщение от BithSachs Что я делаю не так?

закрывающую скобку из строки 6 перенесите в строку 2.

[BithSachs]

Сообщение от 1958 закрывающую скобку из строки 6 перенесите в строку 2.

Спасибо, в этом была ошибка, но все равно ничего не работает.
В конце, после определения второй точки, появляется рамка выбора и все..
И команда начинается сразу с определения первой точки, минуя ssget почему-то..

[1958]

Код:

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

 (defun c:rt (/)
;;; (setq ss (ssget))
 (setq ss (ssget "_P"))
 (setq p1 (getpoint "\nПервая точка"))
 (setq p2 (getpoint "\nВторая точка"))
 (setq ang (angtos (angle p1 p2)))
 (command "_rotate" ss "" p1 ang)
)

Попробуйте так

[BithSachs]

1958, игнорирует ssget вначале все равно

[1958]

Сообщение от BithSachs игнорирует ssget вначале все равно

А вы перед этим набор создавали?
(setq ss (ssget "_P")) - это создание набора из элементов предыдущего набора.
Включите вторую строчку и посмотрите результат.

[BithSachs]

Неа, не работает

[1958]

Сообщение от BithSachs Неа, не работает

В каком месте?
Смутное подозрение, что у вас в (setq ss (ssget "_P")) вместо P (Пэ на латинице) стоит Р (эР на кириллице).

[gnuvse]

Здравствуйте.

Хочу написать программу, которая просто меняет Justify на right<->left

Подскажите пожалуйста как получить значение Justify текста.
Или как его можно сразу перезаписать.

vla-get-Justification выдает ошибку.

Спасибо за ответ и ваше время.

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

http://autolisp.ru/2010/04/06/text-and-attrib-entities/ ?

[gnuvse]

Сообщение от Кулик Алексей aka kpblc http://autolisp.ru/2010/04/06/text-and-attrib-entities/ ?

Прочитал статью.

Смог получить значение TextJustify от 1 до 3 в зависимости от положения текста.
Как теперь можно перезаписать это значение?

Спасибо.

[BithSachs]

Сообщение от 1958 В каком месте? Смутное подозрение, что у вас в (setq ss (ssget "_P")) вместо P (Пэ на латинице) стоит Р (эР на кириллице).

Нет, там все нормально. Я не понимаю.. это самое примитивное, что можно вообще придумать, и оно не работает.

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

Сообщение от gnuvse Как теперь можно перезаписать это значение?

Если через ActiveX, то vla-put-<ИмяСвойства>. Просто про точки вставки не забудь.

Сообщение от BithSachs это самое примитивное, что можно вообще придумать, и оно не работает.

Тупой (ssget) работает? pickfirst чему равна?

[gnuvse]

Сообщение от Кулик Алексей aka kpblc Если через ActiveX, то vla-put-<ИмяСвойства>. Просто про точки вставки не забудь. Тупой (ssget) работает? pickfirst чему равна?

Алексей, пожалуйста, приведите пример кода.

Спасибо.

[BithSachs]

Сообщение от Кулик Алексей aka kpblc Тупой (ssget) работает? pickfirst чему равна?

Не работает, Пикфест - 1
После всех setq пишет, что функция прервана, и запускает _rotate

Даже вот так не работает

Код:

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

 (defun c:ТЕСТ (/)
	(command) "ПОВЕРНУТЬ" (ssget) (getpoint "\nДай точку") "опорный угол" "30"
)

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

Примерно так, на скорую руку:

Код:

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

 (vl-load-com)

(defun test (/ adoc selset pt1 pt2)
  (if (and (= (type (setq selset (vl-catch-all-apply (function (lambda () (ssget "_:L")))))) 'pickset)
           (= (type
                (setq pt1 (vl-catch-all-apply
                            (function (lambda () (getpoint "\nУкажите точку, вокруг которой вращаем <Отмена> : ")))
                            ) ;_ end of vl-catch-all-apply
                      ) ;_ end of setq
                ) ;_ end of type
              'list
              ) ;_ end of =
           pt1
           (= (type (setq pt2 (vl-catch-all-apply
                                (function (lambda () (getangle pt1 "\nУкажите, насколько поворачиваем <Отмена> : ")))
                                ) ;_ end of vl-catch-all-apply
                          ) ;_ end of setq
                    ) ;_ end of type
              'real
              ) ;_ end of =
           pt2
           ) ;_ end of and
    (progn (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
           (foreach ent (mapcar (function vlax-ename->vla-object)
                                ((lambda (/ item tab)
                                   (repeat (setq tab  nil
                                                 item (sslength selset)
                                                 ) ;_ end setq
                                     (setq tab (cons (ssname selset (setq item (1- item))) tab))
                                     ) ;_ end of repeat
                                   ) ;_ end of lambda
                                 )
                                ) ;_ end of mapcar
             (vla-rotate ent (vlax-3d-point pt1) pt2)
             ) ;_ end of foreach
           (vla-regen adoc acactiveviewport)
           (vla-endundomark adoc)
           ) ;_ end of progn
    ) ;_ end of if
  (princ)
  ) ;_ end of defun

----- добавлено через 44 сек. -----
Код написан без оптимизации, некоторые проверки там лишние - воткнул по привычке.

[RrRR]

BithSachs, а если ещё упростить:

Код:

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

 (ssget)

Так работает?
Перезапустить acad и в новом документе пробовать...

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

gnuvse, пример какого кода? Изменения выравнивания, что ли?

----- добавлено через ~8 мин. -----
Говорит, что

Сообщение от BithSachs Не работает

Вот интересно, какие дополнения установлены и в каком количестве?

[1958]

Сообщение от BithSachs Нет, там все нормально. Я не понимаю.. это самое примитивное, что можно вообще придумать, и оно не работает.

Вы бы выложили кусок файла (желательно версии 2007)

[BithSachs]

И для такой тривиальной задачи нужно писать 40 строк с vla функциями? (считая проверки)
Мне просто нужна стандартная команда, только, чтобы она сразу строила по опорному углу
Т.е. последовательность такая:
1) Команда: ПОВЕРНУТЬ
2) Базовая точка: указываем точку
3) Выбираем опцию: "Опорный угол"
4) Впечатываем "@", чтобы вернуть последнюю точку
5) Указываем вторую точку
Т.е. получается, мы поворачиваем объект как в ревите: сразу строим опорный отрезок и затем поворачиваем его.

Можно было бы просто использовать рекордер операций, но он не видит, что я впечатываю "@", к сожалению, поэтому нужно долбить по одной и той же точке два раза (да, раздражает).

Сообщение от Кулик Алексей aka kpblc Вот интересно, какие дополнения установлены и в каком количестве?

3 штуки установлено, но я их убрал из автозагрузки, перезапустил и попробовал без них - ничего не изменилось.

Я думал, это вполне реализуемо command функциями, кто-то же в начале темы рекомендовал с них изучать автолисп.

Сообщение от 1958 Вы бы выложили кусок файла (желательно версии 2007)

В других файлах все точно также. Я не совсем понимаю, как они могут влиять на это.

[gnuvse]

Сообщение от Кулик Алексей aka kpblc gnuvse, пример какого кода? Изменения выравнивания, что ли? ----- добавлено через ~8 мин. ----- Говорит, что Вот интересно, какие дополнения установлены и в каком количестве?

C vla-put..., если можно законченный пример, чтобы можно было запустить и посмотреть. Не обязательно на TextJustify

Спасибо.

[1958]

Сообщение от BithSachs Мне просто нужна стандартная команда, только, чтобы она сразу строила по опорному углу

Что вы хотите строить? Отрезок, линию? Вы уж определитесь. В самом начале у вас речь шла о повороте выбранных объектов по указанным двум точкам.
Попробуйте так:

Код:

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

 (defun c:rt (/)
 (setq ss (ssget))
 (setq p1 (getpoint "\nПервая точка"))
 (setq p2 (getpoint "\nВторая точка"))
 (setq ang (angtos (angle p1 p2)))
 (command "_rotate" ss "" p1 ang)
)

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

BithSachs, масса слов написано, а ответа на вопрос "работает код или нет" так и не получено. Offtop: Не нравится - не используй. Лень анализировать - я снесу код, не проблема ни разу.
Я начинаю подозревать, что удаление приложений (кстати, каких - это что, военная тайна?) из автозагрузки ничего не дало: есть масса вариантов принудительной тихой загрузки дополнений. Тот факт, что у тебя не работает штатная функция лиспа, может означать что угодно - вплоть до того, что ACAD надо будет полностью переустанавливать.

----- добавлено через 43 сек. -----

Сообщение от gnuvse C vla-put..., если можно законченный пример, чтобы можно было запустить и посмотреть. Не обязательно на TextJustify

Код:

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

 (vl-load-com)
(defun test1 (/ ent ins a b ta)
  (if (and (= (type
                (setq ent (vl-catch-all-apply
                            (function (lambda () (vlax-ename->vla-object (ssname (ssget "_+.:S:E:L" '((0 . "TEXT"))) 0))))
                            ) ;_ end of VL-CATCH-ALL-APPLY
                      ) ;_ end of setq
                ) ;_ end of type
              'vla-object
              ) ;_ end of =
           (member (setq a (vla-get-alignment ent))
                   (list acalignmentleft acalignmentright acalignmenttopleft acalignmenttopright acalignmentmiddleleft acalignmentmiddleright acalignmentbottomleft acalignmentbottomright)
                   ) ;_ end of member
           ) ;_ end of and
    (progn (setq ins (vla-get-insertionpoint ent)
                 ta  (vla-get-textalignmentpoint ent)
                 ) ;_ end of setq
           (vla-put-alignment
             ent
             (cond ((= a acalignmentleft) acalignmentright)
                   ((= a acalignmentright) acalignmentleft)
                   ((= a acalignmenttopleft) acalignmenttopright)
                   ((= a acalignmenttopright) acalignmenttopleft)
                   ((= a acalignmentmiddleleft) acalignmentmiddleright)
                   ((= a acalignmentmiddleright) acalignmentmiddleleft)
                   ((= a acalignmentbottomleft) acalignmentbottomright)
                   ((= a acalignmentbottomright) acalignmentbottomleft)
                   ) ;_ end of cond
             ) ;_ end of vla-put-Alignment
           (vl-catch-all-apply (function (lambda () (vla-put-textalignmentpoint ent ta))))
           (vla-put-insertionpoint ent ins)
           ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of defun

[BithSachs]

Сообщение от Кулик Алексей aka kpblc кстати, каких - это что, военная тайна?

Все от Ли Мака
1 Реактор на Орто
2 Layer Director
3 Смена фона

Сама по себе ssget работает, но в тех строках с функцией command она не работала, и я у хотел узнать почему. (Ну серьезно, почему у тебя не возникает никаких вопросов, почему эти 8 несчастных строчек не работают?)

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

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

Сообщение от BithSachs Ну серьезно, почему у тебя не возникает никаких вопросов, почему эти 8 несчастных строчек не работают?

Потому что я помню тему (за точность названия не поручусь) "Применить explode к набору". И потому, что команды в лиспе могут срабатывать совсем не так, как в обычном режиме.

[koMon]

Сообщение от BithSachs Что я делаю не так? ssget не хочет работать Код: Код: [Выделить все] (defun c:ВРАЩАТЬ () (setq ss (ssget "_P") (setq p1 (getpoint "/nПервая точка")) (setq p2 (getpoint "/nВторая точка")) (command "ПОВЕРНУТЬ" ss p1 "О" p1 p2) ) ) После "command", думаю, понятно, что я хочу сделать

Так будет работать задуманная команда.
Причём, как verb->noun, так и noun<-verb)

Код:

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

  
(defun c:ВРАЩАТЬ ()
   	(setq ss (ssget))
	(setq p1 (getpoint "/nПервая точка"))
	(setq p2 (getpoint "/nВторая точка"))
	(command "_Rotate" "_P" ""  p1 "О" p1 p2)
)

[koMon]

Сообщение от gnuvse Хочу написать программу, которая просто меняет Justify на right<->left

я тоже хотел… но не то, чтобы left-right, а вообще перебор всего… не думаю, что подойдёт в качестве примера, но может пригодится!?-)
Offtop: да простит меня setvar

[BithSachs]

koMon, работает, действительно. Но я не понимаю, почему присваиваем ss набор, но потом его не используем, а просто пишем _P
И зачем пустые кавычки после этого самого _P?

А в одной строчке это нельзя сделать?

Код:

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

 (defun c:ТЕСТ ()
   	(setq ss (ssget))
	(command "_Rotate" "_P" ""  getpoint "О" getpoint "@")
)

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

[koMon]

BithSachs,

Сообщение от BithSachs почему присваиваем ss набор, но потом его не используем

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

Сообщение от BithSachs И зачем пустые кавычки после этого самого _P?

в команду передаётся селекшн сет, команда ожидает дальнейшшего добавления объектоа, чтобы завершить выбор нужен "", эквивалент <Enter>

Сообщение от BithSachs А в одной строчке это нельзя сделать?

можно.

Код:

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

 (command "_Rotate" "_P" "" (getpoint) "_R" "@")

[BithSachs]

koMon, спасибо большое!

[koMon]

BithSachs,
по ходу я был не прав, я посмотрел и так тоже работает), всё короче и короче...

Код:

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

 (command "_Rotate" (ssget) "" (getpoint) "_R" "@")

[sathalex]

Привет всем.
Есть функция по выбору объектов на слое:

Код:

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

 (defun sel_obj (etype msg lay / e el)
	(setvar 'errno 0)
	(if
	  (setq e (car (entsel msg)))
	  (setq el (entget e))
	  )
	(cond
	   ((= (getvar 'errno) 7)
	   (princ "\nМимо.. Попробуйте ещё раз.")
	   (sel_obj etype msg lay)
	   )
	  ((not e) nil)
	  ((not (wcmatch (strcase (cdr (assoc 0 el))) (strcase etype)))
	   (princ (strcat "\nВыбранный объект не является " etype "... Попробуйте ещё раз."))
	   (sel_obj etype msg lay)
	   )
	  
	  ((eq (vla-get-lock (vla-item (vla-get-Layers (vla-get-activedocument(vlax-get-acad-object))) (cdr (assoc 8 el)))) :vlax-true)
	   (princ "\nСлой заблокирован.. Попробуйте ещё раз.")
	   (sel_obj etype msg lay)
	   )
	  ((and lay (wcmatch (strcase (cdr (assoc 8 el))) (strcase lay)))
	   (princ "\nСлой уже был выбран.. Попробуйте ещё раз.")
	   (sel_obj etype msg lay)
	   )
	   (T (cdr (assoc 8 el)))
	)
)

Пытаюсь добавить в функцию переменную, которая бы хранила имя слоя, на котором объекты были выбраны:

Код:

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

 (if
	  (setq e (car (entsel msg)))
          (setq layname (cdr (assoc 8 e)))
          (setq el (entget e))
	  )

но ничего не получается.
Помогите пожалуйста советом.

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

А не проще ли фильтры ssget использовать?

[frostmourn]

Так можно

Код:

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

 
(if
  (setq e (car (entsel msg)))
         (setq layname (cdr (assoc 8 e))
                  el (entget e))
  )

[sathalex]

Сообщение от frostmourn Так можно Код: [Выделить все] (if (setq e (car (entsel msg))) (setq layname (cdr (assoc 8 e)) el (entget e)) )

Получаю ошибку:
неверный тип аргумента: listp <Имя объекта: 1b25f35be70>

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

В каком месте ошибка?

[frostmourn]

Сообщение от sathalex Получаю ошибку: неверный тип аргумента: listp <Имя объекта: 1b25f35be70>

Ну да, не проверил написанное. Надо чуть поменять

Код:

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

 
(if
  (setq e (car (entsel msg)))
         (setq el (entget e)
             layname (cdr (assoc 8 el)))
  )

[sathalex]

Сообщение от frostmourn Ну да, не проверил написанное. Надо чуть поменять

Спасибо большое, всё получается как надо!

[gnuvse]

Сообщение от Кулик Алексей aka kpblc BithSachs, масса слов написано, а ответа на вопрос "работает код или нет" так и не получено. Offtop: Не нравится - не используй. Лень анализировать - я снесу код, не проблема ни разу. Я начинаю подозревать, что удаление приложений (кстати, каких - это что, военная тайна?) из автозагрузки ничего не дало: есть масса вариантов принудительной тихой загрузки дополнений. Тот факт, что у тебя не работает штатная функция лиспа, может означать что угодно - вплоть до того, что ACAD надо будет полностью переустанавливать. ----- добавлено через 43 сек. ----- Код: [Выделить все] (vl-load-com) (defun test1 (/ ent ins a b ta) (if (and (= (type (setq ent (vl-catch-all-apply (function (lambda () (vlax-ename->vla-object (ssname (ssget "_+.:S:E:L" '((0 . "TEXT"))) 0)))) ) ;_ end of VL-CATCH-ALL-APPLY ) ;_ end of setq ) ;_ end of type 'vla-object ) ;_ end of = (member (setq a (vla-get-alignment ent)) (list acalignmentleft acalignmentright acalignmenttopleft acalignmenttopright acalignmentmiddleleft acalignmentmiddleright acalignmentbottomleft acalignmentbottomright) ) ;_ end of member ) ;_ end of and (progn (setq ins (vla-get-insertionpoint ent) ta (vla-get-textalignmentpoint ent) ) ;_ end of setq (vla-put-alignment ent (cond ((= a acalignmentleft) acalignmentright) ((= a acalignmentright) acalignmentleft) ((= a acalignmenttopleft) acalignmenttopright) ((= a acalignmenttopright) acalignmenttopleft) ((= a acalignmentmiddleleft) acalignmentmiddleright) ((= a acalignmentmiddleright) acalignmentmiddleleft) ((= a acalignmentbottomleft) acalignmentbottomright) ((= a acalignmentbottomright) acalignmentbottomleft) ) ;_ end of cond ) ;_ end of vla-put-Alignment (vl-catch-all-apply (function (lambda () (vla-put-textalignmentpoint ent ta)))) (vla-put-insertionpoint ent ins) ) ;_ end of progn ) ;_ end of if ) ;_ end of defun

Уважаемый Кулик Алексей, я еще новичок в программирование.
Пытаюсь запускать ваш код, выделяю текст и не работает(mtext, text и то и то попробовал).
При отладке понимаю, что в ent передается nil. При помощи vl-catch-all-error-message выявил ошибку - bad argument type - lselsetp nil

Значит у нас не проходит проверка по типу (type) из этого следует, что я выделяю не тот объект какой надо.

Поясните пожалуйста.

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

UPD. Я понял. Мы сравниваем с 'vla-object значит мой текст не является vla объектом.

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

Строка

Код:

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

 (ssget "_+.:S:E:L" '((0 . "TEXT")))

дословно означает следующее:
- выбирать только объекты TEXT
- исключить выбор на заблокированных слоях
- выбирать только один примитив
- выбирать примитив под курсором
Проверь, что у тебя с состоянием слоев. Ну или образец файла в студию. Сейчас у меня нет возможности проверять код. Может быть, позже - если не забуду.

[gnuvse]

Сообщение от Кулик Алексей aka kpblc Ну или образец файла в студию

test1.dwg

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

У меня нет доступа на яндекс.диск

Вот интересно, а кто мешает файл напрямую в пост приложить?

[gnuvse]

Сообщение от Кулик Алексей aka kpblc У меня нет доступа на яндекс.диск Вот интересно, а кто мешает файл напрямую в пост приложить?

Так я ссылку на скачивание отправил, вроде и без яндекс-диска можно качать.

test.dwg

[Maksim7enov]

Здравствуйте! Написал маленькую программу с диалоговым окном DCL, для построения продольных профилей, все вроде работает. Так как только учусь не могли бы Вы проверить код на грамотность и подсказать какие места кода можно заменить, чтобы он стал более устойчив в работе. Так же не могу понять как можно объединить все в один файл Lsp, и стоит ли это делать?
Код Lisp

Код:

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

;|
***************************************************************************************************
*
*			Для простроения продольного профиля
*
***************************************************************************************************
* Программа с диалоговым окном для простроения продольного профиля инженерных сетей, работает в паре
*	с блоком профиль, или боковиком по форме 2. Строит участки трубопроводов по заданному уклону
*	и длине. Программа задает в диалоговом окне 3 вопроса.
***************************************************************************************************
* Глобальные переменные (для запонинания предыдущих вычислений):
* - gl_mark_z - Для начальной отметки земли
* - gl_mark_l - Для отметки лотка трубопровода
* - gl_slope - Для назначения уклона трубопровода
* - gl_length_1 - Для указания расстояния между участками
* - gl_diam_1 - Для указания диаметра трубопровода
* - vopros_1 - Вопрос 1. Указываь ли на профиле трубопровод с учетом диаметра?
* - vopros_2 - Вопрос 2. Указываь ли на профиле уклон трубопроводов?
* - vopros_3 - Вопрос 3. Указываь ли на профиле длину участка?
***************************************************************************************************
* Локальные переменные: 
* - pt1 - Точка отчета для построения
* - pt2 - Вспомогательная точка
* - rs_otm_1 - расчет отметки после уклона
* - text_1 - отметка после уклона
* - inpoi_text_1 - точка вставки text_1 для выравнивания (вспомогательная)
* - rasst_2 - Вспомогательная для длины
***************************************************************************************************
|;

(defun c:7en-profil (/ vopros_1 vopros_2 vopros_3)
(vl-load-com)
 (defun 7en_param_dc ()
  (setq gl_mark_z   (atof (get_tile "dc_otm1"))
        gl_mark_l   (atof (get_tile "dc_otm2"))
        gl_slope    (atof (get_tile "dc_uclon"))
        gl_length_1 (atof (get_tile "dc_rasst1"))
        gl_diam_1   (atof (get_tile "dc_diam_1"))
        vopros_1    (get_tile "dc_diam")
        vopros_2    (get_tile "dc_uclon_1")
        vopros_3    (get_tile "dc_dlina")
        ) ;_ end of_setq
  ) ;_ end of_defun
 (defun profil_rs (gl_mark_z gl_mark_l gl_slope gl_length_1 vopros_1 gl_diam_1 vopros_2 vopros_3 / old_value pt1 pt2 text_1 inpoi_text_1 rs_otm_1 step rasst_2)
                    ;---------------------------------------------------------------------;
  (vl-load-com)
  (setq acad_aplication (vlax-get-acad-object))
  (setq active_document (vla-get-activedocument acad_aplication))
  (setq model_space (vla-get-modelspace active_document)) ;------------------------------------;
  (setq old_value (getvar 'osmode))
  (setvar 'osmode 32)
  (setvar "CMDECHO" 0)
  (setq old_text (getvar "textstyle"))
  (if (not (tblobjname "style" "_GOST"))
   (vl-cmdf "_.style" "_GOST" "isocpeur" "0" "1" "0" "_n" "")
   ) ;_ end of_if
  (setvar "textstyle" "_GOST")
  (if (< 0 gl_length_1)
   (progn (setq pt1      (getpoint "\nУкажите начальную точку :")
                pt2      (polar pt1 0 gl_length_1)
                rs_otm_1 (- gl_mark_l (* gl_length_1 gl_slope))
                ) ;_ end of_setq
          (vla-put-lineweight
           (vla-addline
            model_space
            (vlax-3d-point (polar pt1 (/ pi 2) ((lambda (x) (* (/ (- x gl_mark_z) 2) 10)) gl_mark_l)))
            (vlax-3d-point (polar pt2 (/ pi 2) ((lambda (x) (* (/ (- x gl_mark_z) 2) 10)) rs_otm_1))) ;_ end of_vlax-3d-point
            ) ;_ end of_Vla-addLine
           15
           ) ;_ end of_vla-put-Lineweight
          (setq text_1 (vla-addtext
                        model_space
                        (vl-princ-to-string (rtos rs_otm_1 2 2))
                        (vlax-3d-point (polar pt2 (/ pi 2) -3.75))
                        1.25
                        ) ;_ end of_vla-addtext
                ) ;_ end of_setq
          (vla-put-rotation text_1 1.5708)
          (setq inpoi_text_1 (vlax-safearray->list (vlax-variant-value (vla-get-insertionpoint text_1))))
          (vla-put-lineweight text_1 15)
          (vla-put-insertionpoint
           text_1
           (vlax-safearray-fill
            (vlax-make-safearray
             vlax-vbdouble
             (cons 0 (1- (length (mapcar '- inpoi_text_1 (list 0.5 1.6875 0)))))
             ) ;_ end of_vlax-Make-SafeArray
            (mapcar '- inpoi_text_1 (list 0.5 1.6875 0))
            ) ;_ end of_vlax-SafeArray-Fill
           ) ;_ end of_vla-Put-InsertionPoint
          ) ;_ end of_progn
   (progn (setq pt1      (getpoint "\nУкажите начальную точку :")
                pt2      (polar pt1 0 gl_length_1)
                rs_otm_1 (+ gl_mark_l (* gl_length_1 gl_slope))
                ) ;_ end of_setq
          (vla-put-lineweight
           (vla-addline
            model_space
            (vlax-3d-point (polar pt1 (/ pi 2) ((lambda (x) (* (/ (- x gl_mark_z) 2) 10)) gl_mark_l)))
            (vlax-3d-point (polar pt2 (/ pi 2) ((lambda (x) (* (/ (- x gl_mark_z) 2) 10)) rs_otm_1))) ;_ end of_vlax-3d-point
            ) ;_ end of_vla-addline
           15
           ) ;_ end of_vla-put-Lineweight
          (setq text_1 (vla-addtext
                        model_space
                        (vl-princ-to-string (rtos rs_otm_1 2 2))
                        (vlax-3d-point (polar pt2 (/ pi 2) -3.75))
                        1.25
                        ) ;_ end of_vla-addtext
                ) ;_ end of_setq
          (vla-put-rotation text_1 1.5708)
          (vla-put-lineweight text_1 15)
          (setq inpoi_text_1 (vlax-safearray->list (vlax-variant-value (vla-get-insertionpoint text_1))))
          (vla-put-insertionpoint
           text_1
           (vlax-safearray-fill
            (vlax-make-safearray
             vlax-vbdouble
             (cons 0 (1- (length (mapcar '- inpoi_text_1 (list 0.5 1.6875 0)))))
             ) ;_ end of_vlax-Make-SafeArray
            (mapcar '- inpoi_text_1 (list 0.5 1.6875 0))
            ) ;_ end of_vlax-SafeArray-Fill
           ) ;_ end of_vla-Put-InsertionPoint
          ) ;_ end of_progn
   ) ;_ end of_if
                    ;-----------------------построение трубы с учетом диаметра;
  (if (= vopros_1 "1")
   (progn
    (vla-put-lineweight
     (vla-addline
      model_space
      (vlax-3d-point
       (polar pt1 (/ pi 2) ((lambda (x) (* (/ (- x gl_mark_z) 2) 10)) (+ gl_mark_l (/ gl_diam_1 1000))))
       ) ;_ end of_vlax-3d-point
      (vlax-3d-point
       (polar pt2 (/ pi 2) ((lambda (x) (* (/ (- x gl_mark_z) 2) 10)) (+ rs_otm_1 (/ gl_diam_1 1000))))
       ) ;_ end of_vlax-3d-point
      ) ;_ end of_vla-addline
     15
     ) ;_ end of_vla-addline
    ) ;_ end of_progn
   ) ;_ end of_if
                    ;----------------------нанесение улона на профиль-------------------------------------
  (if (= vopros_2 "1")
   (progn (vla-put-lineweight
           (vla-addline
            model_space
            (vlax-3d-point (polar pt1 (/ pi 2) -35))
            (vlax-3d-point (polar pt2 (/ pi 2) -40))
            ) ;_ end of_vla-addline
           15
           ) ;_ end of_vla-put-Lineweight
 ;_ end of_vla-addline
          (vla-put-lineweight
           (vla-addtext
            model_space
            (vl-princ-to-string (rtos (abs gl_length_1) 2 2))
            (vlax-3d-point (mapcar '+ pt1 (list (- (* gl_length_1 0.25) 1.6875) -38.75)))
            1.25
            ) ;_ end of_vla-addtext
           15
           ) ;_ end of_vla-addtext
          (vla-put-lineweight
           (vla-addtext
            model_space
            (vl-princ-to-string (rtos gl_slope 2 4))
            (vlax-3d-point (mapcar '- pt2 (list (+ (* gl_length_1 0.25) 1.5) 37.5)))
            1.25
            ) ;_ end of_vla-addtext
           15
           ) ;_ end of_vla-addtext
          ) ;_ end of  progn
   ) ;_ end of_if
                    ;----------------------нанесение длины на профиль-------------------------------------
  (if (= vopros_3 "1")
   (vla-put-lineweight
    (vla-addtext
     model_space
     (vl-princ-to-string (rtos (abs gl_length_1) 2 2))
     (vlax-3d-point (mapcar '+ pt1 (list (- (/ gl_length_1 2) 1.6875) -43.125)))
     1.25
     ) ;_ end of_vla-addtext
    15
    ) ;_ end of_vla-addtext
   ) ;_ end of  if
  (setvar 'osmode old_value)
  (setvar 'textstyle old_text)
  ) ;_ end of_defun
                    ;---------------Диалоговое окно------------------------;
 (setq dcl_id (load_dialog "C:\\Работаем\\AutoCAD\\ЛИСП\\Dialog_Profil.DCL")) ;Изменить на путь в своей папке
 (setq step 2)
 (if (null rasst_2)
  (setq rasst_2 (vl-princ-to-string gl_length_1))
  ) ;_ end of  if
 (while (>= step 2)
  (if (null (new_dialog "ProfiL" dcl_id))
   (exit)
   ) ;_ end of_if
  (set_tile "dc_otm1" (vl-princ-to-string gl_mark_z))
  (set_tile "dc_otm2" (vl-princ-to-string gl_mark_l))
  (set_tile "dc_uclon" (vl-princ-to-string gl_slope))
  (set_tile "dc_rasst1" (vl-princ-to-string rasst_2))
  (set_tile "dc_rasst1" (vl-princ-to-string rasst_2))


  (action_tile "accept" "(7en_param_dc) (done_dialog 1)") ;Если нажата кнопка "аccept"
  (setq step (start_dialog))
  (cond ((= step 3)
         (setq rasst_2 (vla-get-textstring (vlax-ename->vla-object (car (entsel "\nВыберите длину трубопровода :")))))
         )
        ((= step 1)
         (profil_rs gl_mark_z gl_mark_l gl_slope gl_length_1 vopros_1 gl_diam_1 vopros_2 vopros_3)
         )
        ) ;_ end of  cond
 ;_ end of  while
  ) ;_ end of  while
 (unload_dialog dcl_id) ;выгрузить Диалоговое окно
 ) ;_ end of_DEFUN

Код DCL

Код:

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

ProfiL: dialog {label = "Построение продольного профиля"; // начало диалога

    : text {label = "Введите данные для построения";
    key = "dc_text_1";}  // текстовые
    
: boxed_column {
        : edit_box {label = "Введите отметку уровня земли м.";
    key = "dc_otm1"; edit_width=8; value = "32";}      // редактируемые
    
    : edit_box {label = "Введите начальную отметку лотка м.";
    key = "dc_otm2"; edit_width=8; value = "34.78";}      // редактируемые
    
    : edit_box {label = "Укажите уклон трубопровода ";
    key = "dc_uclon"; edit_width=8; value = "0.02";}   // редактируемые

    :column {
    : edit_box {label = "Укажите длину участка трубопровда:";
    key = "dc_rasst1"; edit_width=8; value = "10.15";}    // редактируемые
  
    :button {label="Указать <";key="mousep";height=0; fixed_width=true;
action="(done_dialog 3)";}
    }
     : edit_box {label = "Укажите диаметр трубопровода:";
    key = "dc_diam_1"; edit_width=8; value = "300";}     // редактируемые
    
    : spacer{height=1;}   // вставка пустой строки
    }

: text {label = "Дополнение";
key = "dc_text_2";}  // текстовые

: boxed_column {
: toggle {label = "Нанести на профиль трубу с диаметром ?"; 
key = "dc_diam"; value = "1"; }

: toggle {label = "Указать на профиле уклон ?"; 
key = "dc_uclon_1"; value = "1"; }

: toggle {label = "Указать на профиле длину участка ?"; 
key = "dc_dlina"; value = "1"; }
}

    : text {label = "*Примечание: при указании длины участка со знаком ";
    key = "dc_text_3";}  // текстовые
        : text {label = "<-> уклон в левую сторону";
    key = "dc_text_4";}  // текстовые
    
    ok_cancel;   // добавление кнопок ОК и Отмена
}  // окончание диалога

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

Maksim7enov, http://autolisp.ru/2015/02/05/dcl-develop/ не поможет?

----- добавлено через ~2 мин. -----
gnuvse, у тебя там нет текстов. Есть мультивыноска - но это отдельная песня.

[Maksim7enov]

Сообщение от Кулик Алексей aka kpblc Maksim7enov, http://autolisp.ru/2015/02/05/dcl-develop/ не поможет?

Пробовал, но не получается у меня) Сегодня и завтра еще раз попробую!
Также пробовал воспользоваться программой которая сама делает из файла DCL лисп, но опять же не получается. Я до выходных опять попробую и результаты выложу, чтобы можно было определить где ошибка.

[gnuvse]

Сообщение от Кулик Алексей aka kpblc gnuvse, у тебя там нет текстов. Есть мультивыноска - но это отдельная песня.

Я выше писал, что и с TEXT и MTEXT тоже самое - возвращает nil

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

А так? Тупо и топорно, но у меня работало корректно. Тексты меняют выравнивание и остаются на местах.

Код:

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

 (vl-load-com)
(defun test2 (/ ent a minps maxps minp maxp)
  (if (and (= (type
                (setq ent (vl-catch-all-apply
                            (function (lambda () (vlax-ename->vla-object (ssname (ssget "_+.:S:E:L" '((0 . "TEXT"))) 0))))
                            ) ;_ end of VL-CATCH-ALL-APPLY
                      ) ;_ end of setq
                ) ;_ end of type
              'vla-object
              ) ;_ end of =
           (member (setq a (vla-get-alignment ent))
                   (list acalignmentleft acalignmentright acalignmenttopleft acalignmenttopright acalignmentmiddleleft acalignmentmiddleright acalignmentbottomleft acalignmentbottomright) 
                   ) ;_ end of member
           ) ;_ end of and
    (progn (vla-getboundingbox ent 'minps 'maxps)
           (vla-put-alignment ent
                              (cond ((= a acalignmentleft) acalignmentright)
                                    ((= a acalignmentright) acalignmentleft)
                                    ((= a acalignmenttopleft) acalignmenttopright)
                                    ((= a acalignmenttopright) acalignmenttopleft)
                                    ((= a acalignmentmiddleleft) acalignmentmiddleright)
                                    ((= a acalignmentmiddleright) acalignmentmiddleleft)
                                    ((= a acalignmentbottomleft) acalignmentbottomright)
                                    ((= a acalignmentbottomright) acalignmentbottomleft)
                                    ) ;_ end of cond
                              ) ;_ end of vla-put-Alignment
           (vla-update ent)
           (vla-getboundingbox ent 'minp 'maxp)
           (vla-move ent
                     (vlax-3d-point (vlax-safearray->list minp))
                     (vlax-3d-point (vlax-safearray->list minps))
                     ) ;_ end of vla-move
           ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of defun

[gnuvse]

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


Подскажите, как можно перебирать элементы строки в цикле?
И верен ли этот метод для списков?

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

Лучше не тестировать, а разбирать код и находить проблемные места

[gnuvse]

Сообщение от Кулик Алексей aka kpblc Лучше не тестировать, а разбирать код и находить проблемные места

Проблемные места пока рано разбирать.
А как работает разбираю конечно.



Как можно строку преобразовать в список?

[Maksim7enov]

Сообщение от Maksim7enov Сегодня и завтра еще раз попробую!

Все скомпилировал в Vlx.

Сообщение от Кулик Алексей aka kpblc http://autolisp.ru/2015/02/05/dcl-develop/ не поможет?

Слабоват я еще для такого, сложно понять как свое туда запихнуть.

Пытался сделать по этому примеру http://autolisp.ru/2010/03/15/dcl-dialogs-create/ но видимо рано мне еще лезть в такие вещи)
В выходные времени будет больше, попытаюсь еще.

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

Да тут все просто - внутрь основной функции lsp засовываешь кусок, который в %temp% создает временный dcl-файл. А потом уже обычными методами вызываешь dcl-окно и обрабатываешь его.

[Maksim7enov]

Сообщение от Кулик Алексей aka kpblc Да тут все просто

Сделал. Пришлось везде в диалоге ставить "\".
Стал выдавать ошибку "Не удается открыть файл C:\TEMP\dld.dcl -- error 0"
Код после изменения прикладываю

Код:

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

(defun c:7en_profil (/ vopros_1 vopros_2 vopros_3)
(vl-load-com)
  
 (defun 7en_param_dc ()
  (setq gl_mark_z   (atof (get_tile "dc_otm1"))
        gl_mark_l   (atof (get_tile "dc_otm2"))
        gl_slope    (atof (get_tile "dc_uclon"))
        gl_length_1 (atof (get_tile "dc_rasst1"))
        gl_diam_1   (atof (get_tile "dc_diam_1"))
        vopros_1    (get_tile "dc_diam")
        vopros_2    (get_tile "dc_uclon_1")
        vopros_3    (get_tile "dc_dlina")
        ) ;_ end of_setq
  ) ;_ end of_defun
 (defun profil_rs (gl_mark_z gl_mark_l gl_slope gl_length_1 vopros_1 gl_diam_1 vopros_2 vopros_3 / old_value pt1 pt2 text_1 inpoi_text_1 rs_otm_1 step rasst_2)
                    ;---------------------------------------------------------------------;
  (vl-load-com)
  (setq acad_aplication (vlax-get-acad-object))
  (setq active_document (vla-get-activedocument acad_aplication))
  (setq model_space (vla-get-modelspace active_document)) ;------------------------------------;
  (setq old_value (getvar 'osmode))
  (setvar 'osmode 32)
  (setvar "CMDECHO" 0)
  (setq old_text (getvar "textstyle"))
  (if (not (tblobjname "style" "_GOST"))
   (vl-cmdf "_.style" "_GOST" "isocpeur" "0" "1" "0" "_n" "")
   ) ;_ end of_if
  (setvar "textstyle" "_GOST")
  (if (< 0 gl_length_1)
   (progn (setq pt1      (getpoint "\nУкажите начальную точку :")
                pt2      (polar pt1 0 gl_length_1)
                rs_otm_1 (- gl_mark_l (* gl_length_1 gl_slope))
                ) ;_ end of_setq
          (vla-put-lineweight
           (vla-addline
            model_space
            (vlax-3d-point (polar pt1 (/ pi 2) ((lambda (x) (* (/ (- x gl_mark_z) 2) 10)) gl_mark_l)))
            (vlax-3d-point (polar pt2 (/ pi 2) ((lambda (x) (* (/ (- x gl_mark_z) 2) 10)) rs_otm_1))) ;_ end of_vlax-3d-point
            ) ;_ end of_Vla-addLine
           15
           ) ;_ end of_vla-put-Lineweight
          (setq text_1 (vla-addtext
                        model_space
                        (vl-princ-to-string (rtos rs_otm_1 2 2))
                        (vlax-3d-point (polar pt2 (/ pi 2) -3.75))
                        1.25
                        ) ;_ end of_vla-addtext
                ) ;_ end of_setq
          (vla-put-rotation text_1 1.5708)
          (setq inpoi_text_1 (vlax-safearray->list (vlax-variant-value (vla-get-insertionpoint text_1))))
          (vla-put-lineweight text_1 15)
          (vla-put-insertionpoint
           text_1
           (vlax-safearray-fill
            (vlax-make-safearray
             vlax-vbdouble
             (cons 0 (1- (length (mapcar '- inpoi_text_1 (list 0.5 1.6875 0)))))
             ) ;_ end of_vlax-Make-SafeArray
            (mapcar '- inpoi_text_1 (list 0.5 1.6875 0))
            ) ;_ end of_vlax-SafeArray-Fill
           ) ;_ end of_vla-Put-InsertionPoint
          ) ;_ end of_progn
   (progn (setq pt1      (getpoint "\nУкажите начальную точку :")
                pt2      (polar pt1 0 gl_length_1)
                rs_otm_1 (+ gl_mark_l (* gl_length_1 gl_slope))
                ) ;_ end of_setq
          (vla-put-lineweight
           (vla-addline
            model_space
            (vlax-3d-point (polar pt1 (/ pi 2) ((lambda (x) (* (/ (- x gl_mark_z) 2) 10)) gl_mark_l)))
            (vlax-3d-point (polar pt2 (/ pi 2) ((lambda (x) (* (/ (- x gl_mark_z) 2) 10)) rs_otm_1))) ;_ end of_vlax-3d-point
            ) ;_ end of_vla-addline
           15
           ) ;_ end of_vla-put-Lineweight
          (setq text_1 (vla-addtext
                        model_space
                        (vl-princ-to-string (rtos rs_otm_1 2 2))
                        (vlax-3d-point (polar pt2 (/ pi 2) -3.75))
                        1.25
                        ) ;_ end of_vla-addtext
                ) ;_ end of_setq
          (vla-put-rotation text_1 1.5708)
          (vla-put-lineweight text_1 15)
          (setq inpoi_text_1 (vlax-safearray->list (vlax-variant-value (vla-get-insertionpoint text_1))))
          (vla-put-insertionpoint
           text_1
           (vlax-safearray-fill
            (vlax-make-safearray
             vlax-vbdouble
             (cons 0 (1- (length (mapcar '- inpoi_text_1 (list 0.5 1.6875 0)))))
             ) ;_ end of_vlax-Make-SafeArray
            (mapcar '- inpoi_text_1 (list 0.5 1.6875 0))
            ) ;_ end of_vlax-SafeArray-Fill
           ) ;_ end of_vla-Put-InsertionPoint
          ) ;_ end of_progn
   ) ;_ end of_if
                    ;-----------------------построение трубы с учетом диаметра;
  (if (= vopros_1 "1")
   (progn
    (vla-put-lineweight
     (vla-addline
      model_space
      (vlax-3d-point
       (polar pt1 (/ pi 2) ((lambda (x) (* (/ (- x gl_mark_z) 2) 10)) (+ gl_mark_l (/ gl_diam_1 1000))))
       ) ;_ end of_vlax-3d-point
      (vlax-3d-point
       (polar pt2 (/ pi 2) ((lambda (x) (* (/ (- x gl_mark_z) 2) 10)) (+ rs_otm_1 (/ gl_diam_1 1000))))
       ) ;_ end of_vlax-3d-point
      ) ;_ end of_vla-addline
     15
     ) ;_ end of_vla-addline
    ) ;_ end of_progn
   ) ;_ end of_if
                    ;----------------------нанесение улона на профиль-------------------------------------
  (if (= vopros_2 "1")
   (progn (vla-put-lineweight
           (vla-addline
            model_space
            (vlax-3d-point (polar pt1 (/ pi 2) -35))
            (vlax-3d-point (polar pt2 (/ pi 2) -40))
            ) ;_ end of_vla-addline
           15
           ) ;_ end of_vla-put-Lineweight
 ;_ end of_vla-addline
          (vla-put-lineweight
           (vla-addtext
            model_space
            (vl-princ-to-string (rtos (abs gl_length_1) 2 2))
            (vlax-3d-point (mapcar '+ pt1 (list (- (* gl_length_1 0.25) 1.6875) -38.75)))
            1.25
            ) ;_ end of_vla-addtext
           15
           ) ;_ end of_vla-addtext
          (vla-put-lineweight
           (vla-addtext
            model_space
            (vl-princ-to-string (rtos gl_slope 2 4))
            (vlax-3d-point (mapcar '- pt2 (list (+ (* gl_length_1 0.25) 1.5) 37.5)))
            1.25
            ) ;_ end of_vla-addtext
           15
           ) ;_ end of_vla-addtext
          ) ;_ end of  progn
   ) ;_ end of_if
                    ;----------------------нанесение длины на профиль-------------------------------------
  (if (= vopros_3 "1")
   (vla-put-lineweight
    (vla-addtext
     model_space
     (vl-princ-to-string (rtos (abs gl_length_1) 2 2))
     (vlax-3d-point (mapcar '+ pt1 (list (- (/ gl_length_1 2) 1.6875) -43.125)))
     1.25
     ) ;_ end of_vla-addtext
    15
    ) ;_ end of_vla-addtext
   ) ;_ end of  if
  (setvar 'osmode old_value)
  (setvar 'textstyle old_text)
  ) ;_ end of_defun


(setq file   (strcat (vl-string-right-trim
           "\\"
           (vla-get-tempfilepath
       (vla-get-files
         (vla-get-preferences (vlax-get-acad-object))
         ) ;_ end of vla-get-files
       ) ;_ end of vla-get-tempfilepath
           ) ;_ end of vl-string-right-trim
         "\\dlg.dcl"
         ) ;_ end of strcat
      handle (open file "w")
      ) ;_ end of setq
(foreach item
        '("dlg:dialog {label = \"lispru dialog\"; // начало диалога

    : text {label = \"Введите данные для построения\";
    key = \"dc_text_1\";}  // текстовые
    
: boxed_column {
        : edit_box {label = \"Введите отметку уровня земли м.\";
    key = \"dc_otm1\"; edit_width=8; value = \"32\";}      // редактируемые
    
    : edit_box {label = \"Введите начальную отметку лотка м.\";
    key = \"dc_otm2\"; edit_width=8; value = \"34.78\";}      // редактируемые
    
    : edit_box {label = \"Укажите уклон трубопровода \";
    key = \"dc_uclon\"; edit_width=8; value = \"0.02\";}   // редактируемые

    :column {
    : edit_box {label = \"Укажите длину участка трубопровда:\";
    key = \"dc_rasst1\"; edit_width=8; value = \"10.15\";}    // редактируемые
  
    :button {label=\"Указать <\";key=\"mousep\";height=0; fixed_width=true;
action=\"(done_dialog 3)\";}
    }
     : edit_box {label = \"Укажите диаметр трубопровода:\";
    key = \"dc_diam_1\"; edit_width=8; value = \"300\";}     // редактируемые
    
    : spacer{height=1;}   // вставка пустой строки
    }

: text {label = \"Дополнение\";
key = \"dc_text_2\";}  // текстовые

: boxed_column {
: toggle {label = \"Нанести на профиль трубу с диаметром ?\"; 
key = \"dc_diam\"; value = \"1\"; }

: toggle {label = \"Указать на профиле уклон ?\"; 
key = \"dc_uclon_1\"; value = \"1\"; }

: toggle {label = \"Указать на профиле длину участка ?\"; 
key = \"dc_dlina\"; value = \"1\"; }
}

    : text {label = \"*Примечание: при указании длины участка со знаком \";
    key = \"dc_text_3\";}  // текстовые
        : text {label = \"<-> уклон в левую сторону\";
    key = \"dc_text_4\";}  // текстовые
    
    ok_cancel;   // добавление кнопок ОК и Отмена
}
")
  (write-line item handle)
  ) ;_ end of foreach
(close handle)
  
                    ;---------------Диалоговое окно------------------------;
 (setq dcl_id (load_dialog file)) ;загружаем диалоговое окно
 (setq step 2)
 (if (null rasst_2)
  (setq rasst_2 (vl-princ-to-string gl_length_1))
  ) ;_ end of  if
 (while (>= step 2)
  (if (null (new_dialog "dlg" dcl_id))
   (exit)
   ) ;_ end of_if
  (set_tile "dc_otm1" (vl-princ-to-string gl_mark_z))
  (set_tile "dc_otm2" (vl-princ-to-string gl_mark_l))
  (set_tile "dc_uclon" (vl-princ-to-string gl_slope))
  (set_tile "dc_rasst1" (vl-princ-to-string rasst_2))
  (set_tile "dc_rasst1" (vl-princ-to-string rasst_2))
  (action_tile "accept" "(7en_param_dc) (done_dialog 1)") ;Если нажата кнопка "аccept"
  (setq step (start_dialog))
  (cond ((= step 3)
         (setq rasst_2 (vla-get-textstring (vlax-ename->vla-object (car (entsel "\nВыберите длину трубопровода :")))))
         )
        ((= step 1)
         (profil_rs gl_mark_z gl_mark_l gl_slope gl_length_1 vopros_1 gl_diam_1 vopros_2 vopros_3)
         )
        ) ;_ end of  cond
 ;_ end of  while
  ) ;_ end of  while
 (unload_dialog dcl_id) ;выгрузить Диалоговое окно
 ) ;_ end of_DEFUN

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

После какого-то обновления на сайте почему-то стали не всегда корректно показываться "\" - пришлось править. Если еще обнаружишь ошибки - пиши прямо там, буду по мере поступления исправлять

[gnuvse]

Здравствуйте.

Пытаюсь написать функцию, которая должна преобразовать строку в список.

На данном этапе она не работает вообще.

При проверке участка кода начинающегося с (if (not flag-quotes) интерпретатор выдает ошибку - error: too many arguments: (IF (NOT FLAG-QUOTES) (IF ( ... ) ( ... ) ( ... )) (PROGN ( ... ) ( ... )) ... )

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


Спасибо.

Код:

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

 (defun substr->list	(str / s)
	(setq s (read (strcat "(" str ")")))
	s
)




(defun str->list (str/ i j l flag word symbol quotes? flag-quotes quotes-counter)
	(setq i 1)
	(setq l '())
	(setq word "")
	(setq symbol " ")

										
	(setq quotes "")
	(setq flag-quotes nil)




	(while (/= (substr str i 1) "")
		(setq symbol (substr str i 1))

		(if	(= symbol "\"")
			(progn
				(setq flag-quotes t)
				(setq quotes-counter 0)
				(setq j i)
			)
		)

		(if	(not flag-quotes)
			(if	(and (/= symbol " ") (/= symbol "(" ")"))
				(setq word (strcat word symbol))
				(progn
					(setq l (append l (substr->list word)))
					(setq word "")
				)
			)
			(progn
				(while (and (/= quotes-counter 2) (= flag-quotes t))
					(setq symbol (substr str j 1))
					(if	(/= symbol "\"")
						(progn
							(setq symbol (substr str j 1))
							(setq word (strcat word symbol))
						)
						(if	(= symbol "\"")
							(progn
								(setq quotes-counter (1+ quotes-counter))
								(setq word (strcat word symbol))
							)
						)
					)
					(setq j (1+ j))
				)
				(setq l (append l (substr->list word)))
			)
			(setq i (1+ i))
		)
	)
	(setq l (append l (substr->list word)))
	l
)

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

Проверяй соответствие скобок.
ИМХО как-то немного наворочен код. У меня другой вариант, пока что нормально работает:

Код:

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

 (defun _kpblc-conv-string-to-list (string separator / i)
                                  ;|
*    Функция разбора строки. Возвращает список
*    Параметры вызова:
*  string    разбираемая строка
*  separator  символ, используемый в качестве разделителя частей
*    Примеры вызова:
(_kpblc-conv-string-to-list "1;2;3;4;5;6" ";")  ;-> '(1 2 3 4 5 6)
(_kpblc-conv-string-to-list "1;2" ";")          ;-> '(1 2)
(_kpblc-conv-string-to-list "1,2" ",")          ;-> '(1 2)
(_kpblc-conv-string-to-list "1.2" ".")          ;-> '(1 2)
|;
  (cond ((= string "") nil)
        ((vl-string-search separator string)
         ((lambda (/ pos res)
            (while (setq pos (vl-string-search separator string))
              (setq res    (cons (substr string 1 pos) res)
                    string (substr string (+ (strlen separator) 1 pos))
                    ) ;_ end of setq
              ) ;_ end of while
            (reverse (cons string res))
            ) ;_ end of lambda
          )
         )
        ((and (not (member separator '("`" "#" "@" "." "*" "?" "~" "[" "]" "-" ",")))
              (wcmatch (strcase string) (strcat "*" (strcase separator) "*"))
              ) ;_ end of and
         ((lambda (/ pos res _str prev)
            (setq pos  1
                  prev 1
                  _str (substr string pos)
                  ) ;_ end of setq
            (while (<= pos (1+ (- (strlen string) (strlen separator))))
              (if (wcmatch (strcase (substr string pos (strlen separator))) (strcase separator))
                (setq res    (cons (substr string 1 (1- pos)) res)
                      string (substr string (+ (strlen separator) pos))
                      pos    0
                      ) ;_ end of setq
                ) ;_ end of if
              (setq pos (1+ pos))
              ) ;_ end of while
            (if (< (strlen string) (strlen separator))
              (setq res (cons string res))
              ) ;_ end of if
            (if (or (not res) (= _str string))
              (setq res (list string))
              (reverse res)
              ) ;_ end of if
            ) ;_ end of lambda
          )
         )
        (t (list string))
        ) ;_ end of cond
  ) ;_ end of defun

[Alan]

Сообщение от gnuvse При проверке участка кода начинающегося с (if (not flag-quotes) интерпретатор выдает ошибку - error: too many arguments: (IF (NOT FLAG-QUOTES) (IF ( ... ) ( ... ) ( ... )) (PROGN ( ... ) ( ... )) ... )

Вот тут всё и написано. Видны явные ошибки текста!

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

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

Вот это и анализируй и понимай. Удачи!

[gnuvse]

Сообщение от Кулик Алексей aka kpblc Проверяй соответствие скобок. ИМХО как-то немного наворочен код. У меня другой вариант, пока что нормально работает:

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

----- добавлено через ~4 мин. -----

Сообщение от Alan Первое, что нужно сделать это отформатировать текст средствами редактора. Появятся метки окончания циклов. Второе. При отладке ставь точки останова и пошагово работай. В этой теме об этом писалось не раз.

1. Уже форматировал так текст, не помогло
2. Код вообще в интерпретатор не загружается, поэтому не могу отладчиком воспользоваться.

Спасибо.

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

Если не загружается - значит, в нем полно ошибок синтаксиса.
О форматировании: http://autolisp.ru/2017/08/11/code-f...ng-principles/
Для отладки возьми свой код и вколоти его напрямую в VLIDE. А потом - http://autolisp.ru/2009/09/10/vlide-misc-01/ и http://autolisp.ru/2009/09/12/vlide-misc-02/ (ну так, для справки )

[Alan]

Сообщение от gnuvse 1. Уже форматировал так текст, не помогло

Я не знаю, что ты понимаешь под словом форматирование. ВСЕ тексты начинающими программировать на ЛИСПе НЕОБХОДИМО писать во VLIDE.

2. Код вообще в интерпретатор не загружается, поэтому не могу отладчиком воспользоваться.

Тут Алексей вроде дал необходимые ссылки.
Я не анализировал текст, но ошибка после форматирования вида невооруженным взглядом.
В конце текста счётчик (setq j (1+ j)) стоит как третий аргумент IF

[gnuvse]

Сообщение от Alan Я не знаю, что ты понимаешь под словом форматирование. ВСЕ тексты начинающими программировать на ЛИСПе НЕОБХОДИМО писать во VLIDE. Тут Алексей вроде дал необходимые ссылки. Я не анализировал текст, но ошибка после форматирования вида невооруженным взглядом. В конце текста счётчик (setq j (1+ j)) стоит как третий аргумент IF

Именно во vlide и пишу.

Ошибку уже нашёл.

Спасибо.

[OKJI]

Сообщение от gnuvse Здравствуйте. Пытаюсь написать функцию, которая должна преобразовать строку в список. На данном этапе она не работает вообще. При проверке участка кода начинающегося с (if (not flag-quotes) интерпретатор выдает ошибку - error: too many arguments: (IF (NOT FLAG-QUOTES) (IF ( ... ) ( ... ) ( ... )) (PROGN ( ... ) ( ... )) ... ) Пытаюсь анализировать код, но не могу понять в чем дело. Подскажите пожалуйста. Спасибо. Код: [Выделить все] (defun substr->list (str / s) (setq s (read (strcat "(" str ")"))) s ) (defun str->list (str/ i j l flag word symbol quotes? flag-quotes quotes-counter) (setq i 1) (setq l '()) (setq word "") (setq symbol " ") (setq quotes "") (setq flag-quotes nil) (while (/= (substr str i 1) "") (setq symbol (substr str i 1)) (if (= symbol "\"") (progn (setq flag-quotes t) (setq quotes-counter 0) (setq j i) ) ) (if (not flag-quotes) (if (and (/= symbol " ") (/= symbol "(" ")")) (setq word (strcat word symbol)) (progn (setq l (append l (substr->list word))) (setq word "") ) ) (progn (while (and (/= quotes-counter 2) (= flag-quotes t)) (setq symbol (substr str j 1)) (if (/= symbol "\"") (progn (setq symbol (substr str j 1)) (setq word (strcat word symbol)) ) (if (= symbol "\"") (progn (setq quotes-counter (1+ quotes-counter)) (setq word (strcat word symbol)) ) ) ) (setq j (1+ j)) ) (setq l (append l (substr->list word))) ) (setq i (1+ i)) ) ) (setq l (append l (substr->list word))) l )

Вот исправил тебе код все работает:

Код:

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

 (DEFUN str->list (str / i j l flag word symbol quotes? flag-quotes quotes-counter)
  (SETQ i 1)
  (SETQ l nil)
  (SETQ word "")
  (SETQ symbol " ")


  (SETQ quotes "")
  (SETQ flag-quotes nil)




  (WHILE (/= (SUBSTR str i 1) "")
    (SETQ symbol (SUBSTR str i 1))

    (IF (= symbol "\"")
      (PROGN
        (SETQ flag-quotes T)
        (SETQ quotes-counter 0)
        (SETQ j i)
      )
    )

    (IF (NOT flag-quotes)
      (IF	(AND (/= symbol " ") (/= symbol "(" ")"))
        (SETQ word (STRCAT word symbol))
        (PROGN
	(SETQ l (APPEND l (substr->list word)))
	(SETQ word "")
        )
      )
      (PROGN
        (WHILE (AND (/= quotes-counter 2) (= flag-quotes T))
	(SETQ symbol (SUBSTR str j 1))
	(IF (/= symbol "\"")
	  (PROGN
	    (SETQ symbol (SUBSTR str j 1))
	    (SETQ word (STRCAT word symbol))
	  )
	  (IF (= symbol "\"")
	    (PROGN
	      (SETQ quotes-counter (1+ quotes-counter))
	      (SETQ word (STRCAT word symbol))
	    )
	  )
	)
	(SETQ j (1+ j))
        )
        (SETQ l (APPEND l (substr->list word)))
      )

    )
    (SETQ i (1+ i))
  )
  (SETQ l (APPEND l (substr->list word)))
  l
)

Результат:

Код:

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

 _$ (str->list "iouhqf fasdf sdasds 3 23452 43 4 ")
(IOUHQF FASDF SDASDS 3 23452 43 4)
_$ 

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

И стоило ли огород городить?

Код:

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

 _$ (setq str "iouhqf fasdf sdasds 3 23452 43 4 ")
"iouhqf fasdf sdasds 3 23452 43 4 "
_$ (read (strcat "(" str ")"))
(IOUHQF FASDF SDASDS 3 23452 43 4)

[gnuvse]

Сообщение от OKJI Вот исправил тебе код все работает: Код: [Выделить все] (DEFUN str->list (str / i j l flag word symbol quotes? flag-quotes quotes-counter) (SETQ i 1) (SETQ l nil) (SETQ word "") (SETQ symbol " ") (SETQ quotes "") (SETQ flag-quotes nil) (WHILE (/= (SUBSTR str i 1) "") (SETQ symbol (SUBSTR str i 1)) (IF (= symbol "\"") (PROGN (SETQ flag-quotes T) (SETQ quotes-counter 0) (SETQ j i) ) ) (IF (NOT flag-quotes) (IF (AND (/= symbol " ") (/= symbol "(" ")")) (SETQ word (STRCAT word symbol)) (PROGN (SETQ l (APPEND l (substr->list word))) (SETQ word "") ) ) (PROGN (WHILE (AND (/= quotes-counter 2) (= flag-quotes T)) (SETQ symbol (SUBSTR str j 1)) (IF (/= symbol "\"") (PROGN (SETQ symbol (SUBSTR str j 1)) (SETQ word (STRCAT word symbol)) ) (IF (= symbol "\"") (PROGN (SETQ quotes-counter (1+ quotes-counter)) (SETQ word (STRCAT word symbol)) ) ) ) (SETQ j (1+ j)) ) (SETQ l (APPEND l (substr->list word))) ) ) (SETQ i (1+ i)) ) (SETQ l (APPEND l (substr->list word))) l ) Результат: Код: [Выделить все] _$ (str->list "iouhqf fasdf sdasds 3 23452 43 4 ") (IOUHQF FASDF SDASDS 3 23452 43 4) _$

Здравствуйте.
Я уже решил задачу и поправил свой код, вот так выглядит.
Но спасибо, что ответили.

Вот код:

Код:

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

 

(defun brackets (symbol)
	(if (or (= symbol "(") (= symbol ")"))
		t
		nil
	)
)


(defun substr->list	(str / s)
	(setq s (read (strcat "(" str ")")))
	s
)





(defun str->list (str		 /			current-line-pos		   
				  l			 word		symbol	   quotes-counter
				  flag-quotes
				 )
	(setq current-line-pos 1)
	(setq l '())
	(setq word "")

	(setq flag-quotes nil)



	(while (/= (substr str current-line-pos	1) "")
		(setq symbol (substr str current-line-pos 1))

		(if	(= symbol "\"")
			(if (= flag-quotes t)
				(progn	
					(setq flag-quotes nil)
					(setq word (strcat word symbol))
					(setq l (append l (substr->list word)))
					(setq word "")
				)
				(progn
					(setq flag-quotes t)
				)
			)
		)
		
		
		(if	(not flag-quotes) 
			(if	(and (/= symbol " ") (not (brackets symbol)))
				(setq word (strcat word symbol))
				(if (brackets symbol)
					(progn)
					(progn
						(setq l (append l (substr->list word)))
						(setq word "")
					)
				)
			)
			(progn
				(setq word (strcat word symbol))
			)
		) ; end if
		(setq current-line-pos (1+ current-line-pos))
	) ; end while
	l
)

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

Код:

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

 (defun brackets (symbol)
	(if (or (= symbol "(") (= symbol ")"))
		t
		nil
	)
)

можно написать короче:

Код:

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

 (defun brackets (symbol)
	 (or (= symbol "(") (= symbol ")"))
)

----- добавлено через 29 сек. -----
Дальше разбираться не буду - тупо много работы.

[gnuvse]

Сообщение от Кулик Алексей aka kpblc И стоило ли огород городить? Код: [Выделить все] _$ (setq str "iouhqf fasdf sdasds 3 23452 43 4 ") "iouhqf fasdf sdasds 3 23452 43 4 " _$ (read (strcat "(" str ")")) (IOUHQF FASDF SDASDS 3 23452 43 4)

Алексей, здравствуйте.

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


Таким образом я могу быстро варьировать время на изучение исходников по autolisp, а тем более попрактиковаться на решение реальной задаче.

Спасибо.

----- добавлено через 50 сек. -----

Сообщение от Кулик Алексей aka kpblc Код: [Выделить все] (defun brackets (symbol) (if (or (= symbol "(") (= symbol ")")) t nil ) ) можно написать короче: Код: [Выделить все] (defun brackets (symbol) (or (= symbol "(") (= symbol ")")) ) ----- добавлено через 29 сек. ----- Дальше разбираться не буду - тупо много работы.

Какая красота.

А код уже рабочий, можете не проверять.

Спасибо

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

Сугубо ИМХО - количество строк кода ни о чем не говорит. Да и отформатировать код можно так, что вся функция будет в одну строчку.

Код:

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

 (defun _kpblc-conv-value-to-bool (value) (cond ((= (type value) 'str) (not (member (strcase value t) '("" "0" "n" "н" "false" "f")))) ((= (type value) 'vl-catch-all-apply-error) nil) (t (not (member value '(0 nil :vlax-false))))))

----- добавлено через 53 сек. -----
Сейчас, разгребусь тут немного - попробую по шагам разобрать "чтение lsp из каталога"

----- добавлено через ~8 мин. -----
Насчет чтения файлов.
1. Просмотреть каталог на предмет файлов с определенным расширением - см. vl-directory-files. Если понадобится учитывать еще и подкаталоги, то поищи по форуму (по-моему, даже в "Готовых программах" что-то было)
2. Дальше в цикле - открыть файл на чтение, получить количество его строк, загнать результат как точечную пару в результирующий список.
3. Используй vl-sort для сортировки

[gnuvse]

Сообщение от Кулик Алексей aka kpblc Сугубо ИМХО - количество строк кода ни о чем не говорит. Да и отформатировать код можно так, что вся функция будет в одну строчку. Код: [Выделить все] (defun _kpblc-conv-value-to-bool (value) (cond ((= (type value) 'str) (not (member (strcase value t) '("" "0" "n" "н" "false" "f")))) ((= (type value) 'vl-catch-all-apply-error) nil) (t (not (member value '(0 nil :vlax-false)))))) ----- добавлено через 53 сек. ----- Сейчас, разгребусь тут немного - попробую по шагам разобрать "чтение lsp из каталога"

А мне не важно, я все равно посимвольно читаю строку(хоть в строку будет, хоть с форматированием).

----- добавлено через ~2 мин. -----

Сообщение от Кулик Алексей aka kpblc Насчет чтения файлов. 1. Просмотреть каталог на предмет файлов с определенным расширением - см. vl-directory-files. Если понадобится учитывать еще и подкаталоги, то поищи по форуму (по-моему, даже в "Готовых программах" что-то было) 2. Дальше в цикле - открыть файл на чтение, получить количество его строк, загнать результат как точечную пару в результирующий список. 3. Используй vl-sort для сортировки

Спасибо большое за пояснения.

Но я хочу по возможности сам писать.
В первую очередь я учусь и хочу понимать.

А дальше можно использовать готовые функции.

А еще лучше и так и так сделать.

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

Я про то, что при чтении такой функции что получим в результате?

[gnuvse]

Сообщение от Кулик Алексей aka kpblc Я про то, что при чтении такой функции что получим в результате?

Количество слов в исходнике.
Оно не изменится от того записано ли оно в одну строку или же с форматированием.

Вывод будет такой

1. foo.lsp -> 30 words
2. bar.lsp -> 55 words

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

Сообщение от gnuvse Количество слов в исходнике.

Да лааааадно! Я 95% кода буду рассуждать о том, "как прекрасен этот мир" - и что, у нас все это тоже пойдет в результат? А если у меня пойдет многострочный комментарий? Внутри которого будет показываться гарантированно неработающий код?

[gnuvse]

Сообщение от Кулик Алексей aka kpblc Да лааааадно! Я 95% кода буду рассуждать о том, "как прекрасен этот мир" - и что, у нас все это тоже пойдет в результат? А если у меня пойдет многострочный комментарий? Внутри которого будет показываться гарантированно неработающий код?

Комментарии конечно тоже обрабатываются. Их просто не считаем, а переходим к чтению следующей строки

Я 95% кода буду рассуждать о том

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

Алексей, расскажите.
Есть ли в автолиспе такие замечательные вещи как continue и break или их аналоги?

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

Это из C#? Впрямую их нет, но можно же имитировать.

----- добавлено через ~7 мин. -----
Для каких целей требуется continue и break?
Во, кстати, задачка на понимание:

Код:

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

 (setq b '((0 1 2) (3 4 5) (6 7 8)))
(apply 'mapcar (cons 'list b))

https://forum.dwg.ru/showpost.php?p=1420297&postcount=8

[gnuvse]

Сообщение от Кулик Алексей aka kpblc Это из C#? Впрямую их нет, но можно же имитировать. ----- добавлено через ~7 мин. ----- Для каких целей требуется continue и break? Во, кстати, задачка на понимание: Код: [Выделить все] (setq b '((0 1 2) (3 4 5) (6 7 8))) (apply 'mapcar (cons 'list b)) https://forum.dwg.ru/showpost.php?p=1420297&postcount=8

Ну вообще из си-подобных языков.

Задачка интересная.
Надо подумать.

Ответ постараюсь дать вечером.

UPD.
Работает это примерно так.
Поправьте, если не прав.

(setq a ‘((0 1 2) (3 4 5) (6 7 8)))
(apply ‘mapcar (cons ‘list b))


cons (list b) -> ( )
1.mapcar -> 0 3 6 -> list -> (0 3 6) -> cons —> ((0 3 6))
2.mapcar -> 1 4 7 -> list -> (1 4 7) -> cons—> ((0 3 6) (1 4 7))
3.mapcar -> 2 5 8-> list -> (2 5 8)
((0 3 6) (1 4 7) (2 5 8))

[gnuvse]

Подскажите пожалуйста.
Почему после чтения строки из файла она становится такой(см.картинку)


Строка в файле - ("\"s\"" 0)
По идее после (read-line) должно было быть "(\"\"s\"\" 0)", без лишних слешев

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

Каждый спецсимвол экранируется, все верно. В чем вопрос?

[gnuvse]

Сообщение от Кулик Алексей aka kpblc Каждый спецсимвол экранируется, все верно. В чем вопрос?

Алексей, здравствуйте.
Спасибо за ваши ответы.

Я пока занимался своим проектом, понаписал много функции для обработки символов, подскажите пожалуйста, как я их могу выделить в какую-то библиотеку?

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

Кхм... Что значит "в библиотеку"?

[gnuvse]

Сообщение от Кулик Алексей aka kpblc Кхм... Что значит "в библиотеку"?

Файл подключить хотя бы.
А через load это можно сделать?

Чтобы я не таскал описание функций, а просто подставлял файл к своему исходнику.

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

Ну, как один из вариантов: http://autolisp.ru/2018/07/02/some-lsp-to-one/ И потом полученный lsp уже загружать.
Хотя я использую совершенно другой подход, прекрасно описанный в "САПР на базе AutoCAD" (книжка, к сожалению, уже не продается)

[gnuvse]

Сообщение от Кулик Алексей aka kpblc Ну, как один из вариантов: http://autolisp.ru/2018/07/02/some-lsp-to-one/ И потом полученный lsp уже загружать. Хотя я использую совершенно другой подход, прекрасно описанный в "САПР на базе AutoCAD" (книжка, к сожалению, уже не продается)

Исходник изучу, спасибо. А вот такую книгу мне наверно рано еще читать.

[Сергей812]

Сообщение от gnuvse А вот такую книгу мне наверно рано еще читать.

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

[Vladimir_Sergeevich]

Сообщение от gnuvse понаписал много функции для обработки символов, подскажите пожалуйста, как я их могу выделить в какую-то библиотеку?

Возможно я не прав и сейчас полетят камни, но для себя сделал так:
В каждой программе, вернее в каждом lsp файле, одной из первой строк висит (if (null *sad_lib_isLoaded) (load "_sad-fun-lib.lsp"))
И в конце библиотеки висит исполняемая строчка (setq *sad_lib_isLoaded t)
Таким образом, имею проверку, загружен ли файл, и если нет, то он загружается...

[BithSachs]

Мне нужно сохранить текущий чертеж в трех разных типах (2013, 2010, 2007), добавить в конце имени год и вернуться на исходный путь файла, путем его перезаписи

Код:

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

 (defun c:RESERV ( / start-name start-path 1styear 2styear 3styear)
	(setq start-name (getvar "dwgname")) (print start-name)
	(setq start-path (getvar "dwgprefix")) (print start-path)
		(setvar "FILEDIA" 0)
	(setq 1styear "2013" ) (print 1styear)
	(setq 2styear "2010" ) (print 2styear)
	(setq 3styear "2007" ) (print 3styear)	
	;1
	(command "_saveas" 1styear (strcat start-path start-name " " 1styear )  )
	;2
	(command "_saveas" 2styear (strcat start-path start-name " " 2styear )  )
	;3
	(command "_saveas" 3styear (strcat start-path start-name " " 3styear )  )
	;END 
	(command "_saveas" 1styear (strcat start-path start-name ) "Д")

		(setvar "FILEDIA" 1)
)

На первый заход все хорошо, но на следующие, когда файлы уже перезаписываются, возникают проблемы: функция прерывается из-за диалога о перезаписи, и все сбрасывается (Добавить везде в конце "Д" не помогает).
Походу нужно добавить условие, но как его запихнуть в command функцию я не знаю

[Сергей812]

Сначала делаете три копии файла, а потом открываете и пересохраняете под нужной версией. А перед этим проверяете - есть ли уже данный файл и удаляете при необходимости. Это будет более надежно, имхо. Например, в .Net это все проще делается - просто делается временная копия БД и сохраняется под нужным именем и версией

Код:

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

using (Database lTempdb = db.Wblock())
{
lTempdb.SaveAs(%Имя файла%, %Версия файла%);
}

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

[koMon]

Сообщение от Сергей812 если есть vla-SaveAs

есть

Код:

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

 
(defun c:RESERV ()
    (setq acad_object (vlax-get-acad-object))
    (setq document_object (vla-get-ActiveDocument acad_object))
    (setq dwg_name (vla-get-name document_object))
    (setq dwg_path (vla-get-path document_object))	  
    (vla-SaveAs document_object (strcat dwg_path "\\" dwg_name " 2007") ac2007_dwg)
    (vla-SaveAs document_object (strcat dwg_path "\\" dwg_name " 2010") ac2010_dwg)
    (vla-SaveAs document_object (strcat dwg_path "\\" dwg_name " 2013") ac2013_dwg)
)

[Сергей812]

а вернуться обратно:

Сообщение от BithSachs вернуться на исходный путь файла, путем его перезаписи

но мне не нравится - что к файлу последней версии путь идет через пересохранение "древнего" 2007 формата.

[koMon]

Сообщение от Сергей812 а вернуться обратно:

Код:

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

 (defun c:RESERV ()
    (setq acad_object (vlax-get-acad-object))
    (setq document_object (vla-get-ActiveDocument acad_object))
    (setq dwg_name (vla-get-name document_object))
    (setq dwg_path (vla-get-path document_object))	  
    (vla-SaveAs document_object (strcat dwg_path "\\" dwg_name " 2007") ac2007_dwg)
    (vla-SaveAs document_object (strcat dwg_path "\\" dwg_name " 2010") ac2010_dwg)
    (vla-SaveAs document_object (strcat dwg_path "\\" dwg_name " 2013") ac2013_dwg)
    (vla-SaveAs document_object (strcat dwg_path "\\" dwg_name) ac2013_dwg)
)

[Сергей812]

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

если глянуть справку:

The full path and file name, or valid URL address, for the file. The active document takes on the new name.

Если получает новое имя, но и ту версию файла - под которым сохранялось. Иначе совсем нелогично - имя файла новое, а версия "старая".

[koMon]

не успел) но был не прав

[Сергей812]

т.е. получается так:
1. Формируются полные имена файлов для более младших версий.
2. Пробуются удалить с помощью vl-file-delete. Если произошла ошибка удаления - то работа лиспа прекращается. Но тут возникает вопрос - как различить успешное удаление существующего файла, отсутствие файла и отсутствие доступа к файлу (т.е. кто-то успел его открыть в акаде, например). В справке вопрос отсутствующего файла проигнорирован - что возвращает в этом случае)
3. Если файлы младших версий успешно удалены, то сохраняет в текущей версии и далее по нисходящей.
4. Открывается снова исходный файл, подавляя диалоговые окна при необходимости. И после этого закрывается файл самой младшей версии. А тут тоже новый вопрос - лисп работает ведь в контексте документа и при открытии нового чертежа прервется выполнение?

[T.Bagdat]

Создаю описание блока. В конце функции нужно его удалить. Подскажите, пожалуйста, как на лиспе проще всего реализовать удаление неиспользованного блока. Аналог PURGE, только не массовый, а штучный.

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

(vla-erase <vla-указатель на описание блока>)
Ну или
(entdel <ename-указатель на описание блока>)

Попробуй...

[T.Bagdat]

(entdel <ename-указатель на описание блока>) возвращает nil, и описание остаётся в базе.
Это я пробовал первым делом.
А по поводу (vla-erase <vla-указатель на описание блока>) в книге Полещука несколько запутано. Написано, что этот метод работает для графических примитивов включённых в набор. И приведён пример с некоторыми предварительными действиями:

(setq obj (vla-get-ActiveSelectionSet actdoc)) ;;; #<VLA-OBJECT IAcadSelectionSet 0bef85e4> (vla-Clear obj) (vla-SelectOnScreen obj) (vla-Erase obj)

А как можно включить блок в набор, если это описание, а не вхождение?

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

Тьфу, не vla-erase, а vla-delete!

[T.Bagdat]

Ну вот как-то так получается:

Команда: (vla-delete (vlax-ename->vla-object (tblobjname "block" "proba"))) ; ошибка: Ошибка Automation. Не может быть стерто тем, кто вызвал

----- добавлено через ~17 мин. -----
А, всё, нашёл решение. Спасибо за наводку.

(vla-delete (vla-item (vla-get-blocks (vla-get-ActiveDocument (vlax-get-acad-object))) "proba"))

http://www.cad.dp.ua/sovets/lisp-functions/purger.php

[Red Nova]

Доброго.

Как разрешить ввод либо реального числа либо точки ? То есть совместить getpoint и getreal в одном?
Пока смог только с промежуточным использованием клавиши enter, а хочется по человечески.

Код:

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

 (setq pt2
	 (cond
	   ((getpoint "\nThe Radius Point (or Enter for Diameter):"))
	   ((getreal "\nEnter Diameter in inches:"))
	   )
	)

[Maksim7enov]

Сообщение от Red Nova Как разрешить ввод либо реального числа либо точки ?

Может getkword и в initget прописать ключи для выбора

[koMon]

Сообщение от Red Nova Как разрешить ввод либо реального числа либо точки ? То есть совместить getpoint и getreal в одном?

а в чём цель? построить окружность? если это, то (getdist) может быть полезен, но по ходу только с радиусом и без точек

[Red Nova]

Maksim7enov
getkword и разрешить ввод точки с экрана? Это как?

koMon
getdist то что нужно Спасибо.

Код:

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

 (setq pt2 (getdist pt1 "\nThe Radius Point (or Enter Diameter in inches):"))

[Maksim7enov]

Сообщение от Red Nova getkword и разрешить ввод точки с экрана? Это как?

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

[Titli-pytli]

Скажите пожалуйста, почему вот это -

Код:

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

   (vlax-for x (vla-get-blocks
		 (vla-get-activedocument (vlax-get-acad-object))
	       )
    (VL-CATCH-ALL-APPLY 'vla-delete (list x))
  )

удаляет ни только не использующиеся блоки, но и листы (вкладки листов)? Вроде бы "vla-get-blocks" только блоки должна брать? Нет? И как это поправить.

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

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

Код:

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

 (vlax-for x (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))
  (if (equal (vla-get-islayout x) :vlax-false)
    (vl-catch-all-apply 'vla-delete (list x))
    ) ;_ end of if
  ) ;_ end of vlax-for

[Vladimir_Sergeevich]

Сообщение от Кулик Алексей aka kpblc У листов есть свои блоки. Которые прямого вхождения не имеют, грубо говоря.

Я это понял так, что любое рабочее пространство в акаде - это пространство блока, и отличаются они в первую очередь флагом IsLayout. Список свойств для модели/листа/блока одинаков.

[Сергей812]

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

[megabeton]

Добрый день! Делаю совсем первые шаги в лиспе. Подскажите следующее:
Ввожу

Команда: (setq x (getvar "CLAYER")) "0" Команда: (+ x 10) ; ошибка: неверный тип аргумента: numberp: "0"

Как "0" превратить в 0, что бы (+ x 10) выдавал результат 10

[Сергей812]

думаю - чтобы выдавал результат, надо что в "x" был не nil - т.е. инициализировать х сначала

----- добавлено через ~4 мин. -----
хотя и

Код:

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

 (+ (getvar "CLAYER") 10)

тоже работать не будет - строковую величину и число сложить пытаетесь)

----- добавлено через ~10 мин. -----
А что вы хотите сделать, должно выглядеть примерно так:

Код:

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

 (strcat (getvar "CLAYER") (itoa 10))

к имени любого текущего слоя добавит 10 в конце.

[megabeton]

Суть в том, что я умышленно назвал слой "числом" (у меня еще есть слои "1", "3.14", и пр.), и теперь пытаюсь это число извлечь, чтобы потом проделать с этим числом арифметические операции.
Это вообще возможно?

[Сергей812]

можно - просто полученное имя слоя через atof преобразовать в число:

Код:

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

 (+ (atof(getvar "CLAYER")) 10)

но это потенциальный источник ошибок - если текущий слой не будет числом, то ошибку получите.

[koMon]

Сообщение от megabeton Команда: (setq x (getvar "CLAYER"))

(setq x (atof (getvar "CLAYER")))

[megabeton]

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

[koMon]

Сообщение от megabeton Подскажите, а как извлечь описание слоя

(vla-get-description (vlax-ename->vla-object (tblobjname "layer" (getvar 'clayer))))

[Vladimir_Sergeevich]

Сообщение от megabeton Подскажите, а как извлечь описание слоя (в диспетчере слоев есть такой пункт после имени, цвета, типа линий, веса и пр.). Т.е. имена слоев оставим текстовыми, а цифровую часть загоним в описание (слой "Стены кирпичные", а в описании "2.800")

Найди книгу Полещука "Автолисп и вижуаллисп в среде автокад" и изучай структуру документа. Раз уже стоит задача работы со слоями, посмотри в чем разница между (tblsearch "LAYER" (getvar "CLAYER")), (tblobjname "LAYER" (getvar "CLAYER")) и (entget (tblobjname "LAYER" (getvar "CLAYER"))) и разберись со значениями дхф-кодов... или сразу изучай ActivX

[Сергей812]

Полещук "AutoLISP и Visual LISP в среде AutoCAD" 2006г. - только в печатном виде разве что с рук можно купить сейчас, наверно.

[Nike]

Вот на Авито продается, за копейки - https://www.avito.ru/ekaterinburg/kn...ocad_811022774

[megabeton]

Сообщение от koMon (vla-get-description (vlax-ename->vla-object (tblobjname "layer" (getvar 'clayer))))

А как извлечь описание не для текущего слоя, а для слоя выделенного объекта?

[koMon]

Сообщение от megabeton А как извлечь описание не для текущего слоя, а для слоя выделенного объекта?

(vla-get-description (vlax-ename->vla-object (tblobjname "layer" (cdr (assoc 8 (entget (car (entsel))))))))

[megabeton]

Создал набор объектов
(ssget '((0 . "text")))
Объекты в разных слоях.
Хочу поочередно с каждым слоем в наборе проделать различные операции.
Какой функцией это описать?

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

Проходишь по всем элементам набора и делаешь что хочется. В чем собственно вопрос?

[koMon]

Сообщение от megabeton Создал набор объектов

лучше наверное работать с коллекцией слоёв

Код:

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

 
;функция для обработки объекта слоя, на котором есть текстовые примитивы
(defun do_layer_function (layer_object /)
	(if (/= "" (vla-get-description layer_object)) 
		(princ (strcat "\nУ слоя \"" (vla-get-name layer_object) "\" опмсание \"" (vla-get-description layer_object) "\""))
	  	(princ (strcat "\nУ слоя \"" (vla-get-name layer_object) "\" нет описания"))
	)	
)
;*********************************************************************************************************************************
(setq dwg_Layers_collection (vla-get-Layers (vla-get-ActiveDocument (vlax-get-acad-object))))
(vlax-for layer_item dwg_Layers_collection
	(if (apply 'ssget (list "_X" (list (cons -4 "<AND") (cons 0 "TEXT") (cons 8 (vla-get-name layer_item)) (cons -4 "AND>"))))
	  	(do_layer_function layer_item) ; вызов функции для обработки объекта слоя, на котором есть текстовые примитивы
	) 
) 

[megabeton]

Подскажите, как добраться до геометрических свойств полилинии (конкретно к площади).
Просто

Код:

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

 (entget (car (entsel)))

такую информацию напрямую не содержит.
Может возможно быстро добраться до этой информации через Свойства ActiveX
Что то наподобие такого

Код:

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

 (vla-get-____???_____ (vlax-ename->vla-object (__???___ (entget (car (entsel))))))))

[Fedorino]

Добрый день!
Вызвался помочь знакомому студенту в написании лисп программы.
На первый взгляд задание простое.
Отрисовать букву "З" заданной высоты.
Нарисовал букву. Задал точки. Нашел координаты.
Командными методами отрисовал графику.
Но вот условие задать уклон, выбило меня из колеи.
В каком направлении двигаться? Переопределять точки в зависимости от угла?
Вроде сделал, но при отрисовке ерунда получается какая-то.
Подскажите, что делать?

Код:

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

 (defun c:letter_z ( / osm pt1 pt2 pt3 pt4 pt5 pt6 pt7 pt8 pt9 hg ang pt$9 pt$6)

	(setq osm (getvar "osmode")) ; запоминаем какие привязки были включены на момент запуска программы

	(initget 7) ; запрещен пустой ввод, ввод 0, ввод отрицательных чисел
	(setq hg (getreal "\nВысота буквы h:"))
	(initget 5) ; запрещен пустой ввод, ввод отрицательных чисел
	(setq ang (getreal "\nЗадайте угол наклона:"))
	(initget 1) ; запрещен пустой ввод
	(setq pt1 (getpoint "\nУкажите точку вставки: "))

	;(if (not (eq ang 0)) (setq pt1 (mapcar '+ pt1 (list ang 0 0))))
	; точки
	(setq pt2 (polar pt1 (/ (* (- 180 ang) pi) 180) (/ hg 5))) ; определяем точку pt2
	(setq pt3 (polar pt1 (/ (* (- 270 ang) pi) 180) (/ hg 10))) ; определяем точку pt3
	(setq pt4 (polar pt2 (/ (* (- 180 ang) pi) 180) (/ hg 10))) ; определяем точку pt4
	(setq pt5 (polar pt3 (/ (* (- 270 ang) pi) 180) (/ hg 5))) ; определяем точку pt5
	(setq pt6 (polar pt5 (/ (* (- 270 ang) pi) 180) (/ hg 10))) ; определяем точку pt6
	(setq pt7 (polar pt6 (/ (* (- 180 ang) pi) 180) (/ hg 5))) ; определяем точку pt7
	(setq pt8 (polar pt7 (/ (* (- 180 ang) pi) 180) (/ hg 10))) ; определяем точку pt11
	(setq pt$9 (polar pt1 (/ (* (- 270 ang) pi) 180) (/ (distance pt1 pt6) 2)))
	(setq pt9 (polar pt$9 (/ (* (- 360 ang) pi) 180) (sqrt (- (expt (distance pt1 pt4) 2) (expt (distance pt1 pt$9) 2))))) ; определяем точку pt9

	(defun tg (angl / val)
		(setq val (/ (sin angl) (cos angl)))
		val
	)
	(if (not (eq ang 0)) 
		(progn
			(setq pt$6 (polar pt6 (/ (* 270 pi) 180) (distance pt6 pt3))) ; находим нижнюю точку от нее будем считать
			(setq pt6a (polar pt6 (/ (* 360 pi) 180) (* (distance pt6 pt3) (tg ang))))
			(setq pt7a (polar pt7 (/ (* 360 pi) 180) (* (distance pt6 pt3) (tg ang))))
			(setq pt8a (polar pt8 (/ (* 360 pi) 180) (* (distance pt6 pt3) (tg ang))))
			(setq pt5a (polar pt5 (/ (* 360 pi) 180) (* (distance pt$6 pt5) (tg ang))))
			(setq pt9a (polar pt9 (/ (* 360 pi) 180) (* (distance pt$6 pt9) (tg ang))))
			(setq pt3a (polar pt3 (/ (* 360 pi) 180) (* (distance pt$6 pt3) (tg ang))))
			(setq pt1a (polar pt1 (/ (* 360 pi) 180) (* (distance pt$6 pt1) (tg ang))))
			(setq pt2a (polar pt2 (/ (* 360 pi) 180) (* (distance pt$6 pt1) (tg ang))))
			(setq pt4a (polar pt4 (/ (* 360 pi) 180) (* (distance pt$6 pt1) (tg ang))))
			
						; все точки определены, чертим эллипсы
			(setvar "osmode" 0) ; выключаем все привязки
			(command "_.ellipse" "_a" "_c" pt1a pt2a pt3a pt3a pt2a)
			(command "_.ellipse" "_a" "_c" pt1a pt4a pt9a pt9a pt4a)
			(command "_.ellipse" "_a" "_c" pt6a pt5a pt7a pt7a pt5a)
			(command "_.ellipse" "_a" "_c" pt6a pt8a pt9a pt8a pt9a)
				; чертим 3 линии
			(command "_.PLINE" pt4a pt2a "")
			(command "_.PLINE" pt3a pt5a "")
			(command "_.PLINE" pt7a pt8a "")
			
		)
		(progn
			; все точки определены, чертим эллипсы
			(setvar "osmode" 0) ; выключаем все привязки
			(command "_.ellipse" "_a" "_c" pt1 pt2 pt3 pt3 pt2)
			(command "_.ellipse" "_a" "_c" pt1 pt4 pt9 pt9 pt4)
			(command "_.ellipse" "_a" "_c" pt6 pt5 pt7 pt7 pt5)
			(command "_.ellipse" "_a" "_c" pt6 pt8 pt9 pt8 pt9)
			
				; чертим 3 линии
			(command "_.PLINE" pt4 pt2 "")
			(command "_.PLINE" pt3 pt5 "")
			(command "_.PLINE" pt7 pt8 "")
		)
	)

	; поворот буквы
	;(if (not (eq ang 0)) (command "_.rotate" "_c" (polar pt1 (/ (* 160 pi) 180) (/ hg 1)) (polar pt6 (/ (* 340 pi) 180) (/ hg 1)) "" pt1 (- 360 ang)))
	(setvar "osmode" osm) ; включаем привязки
	(princ)
)

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

Сообщение от megabeton как добраться до геометрических свойств полилинии (конкретно к площади).

(vla-get-area (vlax-ename->vla-object (car (entsel))))

----- добавлено через 43 сек. -----

Сообщение от Fedorino Но вот условие задать уклон, выбило меня из колеи.

То есть "уклон"? Трехмерное тело надо, что ли, создать?

[Fedorino]

нет, у шрифта есть уклон, т.е. надо создать курсив

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

Тогда пересчитывай точки.

[Fedorino]

Сообщение от Кулик Алексей aka kpblc Тогда пересчитывай точки.

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

[megabeton]

Как создать набор замкнутых полилиний?
(ssget '((0 . "LWPOLYLINE")) ??????)

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

См. DXF 70, если не ошибаюсь.

[Vladimir_Sergeevich]

Сообщение от megabeton Что то наподобие такого Код: 1 (vla-get-____???_____ (vlax-ename->vla-object (__???___ (entget (car (entsel))))))))

есть универсальный совет.
Сначала выполнить (vlax-dump-object (vlax-ename->vla-object (car (entsel))) t)
Изучить полученный список свойств и методов.

Сообщение от megabeton Как создать набор замкнутых полилиний? (ssget '((0 . "LWPOLYLINE")) ??????)

видимо простого ответа не будет...

dxf code 70 Polyline flag (bit-coded; default = 0): 1 = This is a closed polyline (or a polygon mesh closed in the M direction) 2 = Curve-fit vertices have been added 4 = Spline-fit vertices have been added 8 = This is a 3D polyline 16 = This is a 3D polygon mesh 32 = The polygon mesh is closed in the N direction 64 = The polyline is a polyface mesh 128 = The linetype pattern is generated continuously around the vertices of this polyline

вероятно по деревянному (ssget '((0 . "LWPOLYLINE") (70 . 1))) может обработать не все варианты...

з.ы. может так? (ssget '((0 . "LWPOLYLINE") (-4 . "<OR") (70 . 1) (70 . 129) (-4 . "OR>")) )
вероятно остальные флаги не сильно актуальны...

[megabeton]

DXF 70 – то, что надо. По крайней мере мои задачи выполняет, выбирает все что надо.
Но тут сразу логичный вопрос наклевывается:
Откуда вы знаете все эти DXF коды?
Где найти полный список DXF кодов с разблюдовкой по каждому примитиву?

[Vladimir_Sergeevich]

Сообщение от megabeton Но тут сразу логичный вопрос наклевывается: Откуда вы знаете все эти DXF коды? Где найти полный список DXF кодов с разблюдовкой по каждому примитиву?

F1 справка.

[koMon]

Сообщение от megabeton Где найти полный список DXF кодов с разблюдовкой по каждому примитиву?

https://yandex.ru/yandsearch?text=do...67&clid=124526

[megabeton]

Как извлечь имя примитива (полилинии к примеру), которая находится внутри простого нединамического блока?
Полилиния (примитив) - единственный объект в блоке

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

Получи указатель на описание блока и проходи по описанию.

[megabeton]

Сообщение от Кулик Алексей aka kpblc Получи указатель на описание блока и проходи по описанию.

Подсмотрел/докрутил такую конструкцию

Код:

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

 (vlax-vla-object->ename (car (vl-remove-if-not (function (lambda (x) (= (vla-get-objectname x) "AcDbPolyline"))) ((lambda  (/ res) (vlax-for sub (vla-item (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))) (vla-get-effectivename (vlax-ename->vla-object (car (entsel))))) (setq res (cons sub res))) (reverse res))))))

А без ActiveX это возможно? Что типа взорвать блок, выбрать, взять имя, обратно собрать.

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

Взрывать не надо. Насколько я помню (ACAD запускать лениво) - см нечто типа

Код:

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

 (tblobjename "block" <ИмяБлока>)

[megabeton]

Не совсем понял, Offtop: или совсем не понял

Код:

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

 (tblobjname "block" (cdr (assoc 2 (entget (car (entsel))))))

Имя блока я получил, а дальше то как до вложенного в него примитива добраться (без ActiveX и не взрывая) ?

[skkkk]

Сообщение от megabeton Как извлечь имя примитива (полилинии к примеру), которая находится внутри простого нединамического блока? Полилиния (примитив) - единственный объект в блоке

Согласен с Алексеем:

Сообщение от Кулик Алексей aka kpblc Получи указатель на описание блока и проходи по описанию.

В подтверждение его слов приведу его же код:
Как получить vla-объект, который находится в блоке...
Правда, этот вариант без взрыва - да, а вот без ActiveX - нет. Вопрос: чем не устраивает ActiveX?

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

Сообщение от megabeton а дальше то как до вложенного в него примитива добраться (без ActiveX и не взрывая) ?

Насколько я помню, надо получить через entget начало блока и проходить по БД чертежа, пока не увидишь нечто типа ENDBLOCK.

Сообщение от skkkk Вопрос: чем не устраивает ActiveX?

Может, пишется под какой-нибудь клон, где ActiveX просто не реализован.

[megabeton]

Сообщение от Кулик Алексей aka kpblc Может, пишется под какой-нибудь клон, где ActiveX просто не реализован.

Да нет, исключительно спортивный интерес, учусь только.

Подскажите (или ссылку на страницу этой темы, уверен, что обсуждалось на одной из 185 страниц),
как редактировать примитивы внутри блоков.
Интересует вариант с взрыванием и без.

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

Взрывать точно не надо. А так - в готовых программах "Работа с подосновой", в библиотеке функций - "Нормализация блоков"

[Zirra]

Здравствуйте! О лиспе и программировании только слышала, поэтому мой вопрос задаю здесь.

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

Вопрос у меня такой: как сделать задание для выполнения расчета на php? Точнее, как вычленить данные для задания из программы, написанной на лиспе? Вообще технически это реально сделать, если я в этом не в зуб ногой?

[Сергей812]

Сообщение от Zirra Хотелось бы иметь то же самое, только в php. Есть человек, готовый сделать в php, но абсолютно не знакомый с лиспом.

насколько знаю, PHP работает с COM-объектами - поэтому можно попытаться получать данные из акада напрямую, не трогая лисп.

Сообщение от Zirra Точнее, как вычленить данные для задания из программы, написанной на лиспе?

Если программа не скомпилирована, то исходный код открыт. Только зачем - PHP и лисп даже по синтаксису разные. Дайте человеку набор исходных данных, методику расчета и форму выходных отчетов.

[Zirra]

Спасибо!

[40in]

Во всех учебниках написано что функция (ssget< точка >) формирует набор из всех примитивов проходящих через точку.
Вот простенький код:

(command "_pline" '(10 10) '(-10 -10) "")
(command "_pline" '(-10 10) '(10 -10) "")
(setq obj (ssget '(0.0 0.0)))
(setq b (sslength obj))

На выходе я получаю b=1.
Что я не так делаю? Почему выбирается только один примитив, а не два?

[koMon]

Сообщение от 40in формирует набор из всех примитивов

скорее из последнего примитива

[40in]

Вот собственно цитата из Полищука.....
https://ibb.co/vPV05jd

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

[40in]

Извините, но я опять заблудился в трех соснах)))
Вот простенький код:
(setq z (cdr (assoc 11 (entget (car (entsel "ВЫБОР : \n"))))))
(if (= z '(0.0 0.0 0.0))
(setq k "да")
(setq k "нет")
)
Делается выбор текста. На выходе К всегда НЕТ.
Вот картинка:
https://ibb.co/r33s2Pv
Что у меня не так?

[Сергей812]

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

[Maksim7enov]

Сообщение от 40in Что у меня не так?

вроде "=" не работает с списком

Код:

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

 
(setq z (cdr (assoc 11 (entget (car (entsel "ВЫБОР : \n"))))))
(if (equal z '(0.0 0.0 0.0))
(setq k "да")
(setq k "нет")
)

[baaba]

Самому стыдно, не знаю базовых вещей, хоть и умудрился что то написать/адаптировать для своих скромных нужнд. Может быть просто давно не занимался автолиспом. Разбираю вот такой кусок кода:

Код:

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

 (defun IsInTriangle (pt p1 p2 p3)
  ((lambda (n1 n2 n3)
     (or
       (and (equal n1 n2 1e-9) (equal n2 n3 1e-9))
       (null n1)
       (null n2)
       (null n3)
     )
   )
    (Normal3points pt p1 p2)
    (Normal3points pt p2 p3)
    (Normal3points pt p3 p1)
  )
)

Как правильно передать функции pt, pt1, pt2, ... ?
Я пытался так:

Код:

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

 (IsInTriangle (getpoint) (getpoint) (getpoint) (getpoint))

Или так:

Код:

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

 (IsInTriangle (cdr (getpoint)) (getpoint) (getpoint) (getpoint))

[mkung]

Попросили помочь определить через Лисп функцию, созданную на VBA. Не получается.
Если просто запустить - работает.

Код:

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

 (command "_vbarun" "E:\\_РАБОТА\\АСО\\Румянцев\\vba_run\\VBA\\InsertBeamCenter.dvb!InsertBeamCenter")

Если пытаюсь определить функцию:

Код:

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

 (defun c:ibc()
(command "_vbarun" "E:\\_РАБОТА\\АСО\\Румянцев\\vba_run\\VBA\\InsertBeamCenter.dvb!InsertBeamCenter")
)

После загрузки Лиспа вылетает ошибка и функция не определена:
Команда: _appload Name2.lsp успешно загружено.
Команда: ; ошибка: считан неверный символ (восьмеричный): 0
В чем тут дело?

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

baaba, а что за код у Normal3points ?
mkung, попробуй через vla-runmacro: https://knowledge.autodesk.com/searc...2C707-htm.html

[Vladimir_Sergeevich]

Сообщение от baaba Самому стыдно, не знаю базовых вещей...

поди выдает ; ошибка: no function definition: NORMAL3POINTS ??
В таком виде никто код не проверит, потому что отсутствует описание функции Normal3points используемой в твоей IsInTriangle
теоретически правильно первый вариант:

Сообщение от baaba Я пытался так: Код: [Выделить все] (IsInTriangle (getpoint) (getpoint) (getpoint) (getpoint))

[baaba]

Сообщение от Vladimir_Sergeevich поди выдает ; ошибка: no function definition: NORMAL3POINTS ?? В таком виде никто код не проверит, потому что отсутствует описание функции Normal3points используемой в твоей IsInTriangle теоретически правильно первый вариант:

Выдаёт такое:

Код:

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

 Command: (IsInTriangle (cdr (getpoint)) (getpoint) (getpoint) (getpoint))
; error: bad argument type: numberp: nil

[baaba]

Сообщение от Кулик Алексей aka kpblc baaba, а что за код у Normal3points ?[/url]

Код:

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

 (defun Normal3points (p0 p1 p2)
  (Normalize (CrossProduct (mapcar '- p1 p0) (mapcar '- p2 p0)))
)

Код:

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

 (defun CrossProduct (v1 v2)
  (list	(- (* (cadr v1) (caddr v2)) (* (caddr v1) (cadr v2)))
	(- (* (caddr v1) (car v2)) (* (car v1) (caddr v2)))
	(- (* (car v1) (cadr v2)) (* (cadr v1) (car v2)))
  )
)

Код:

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

 (defun Normalize (v)
  ((lambda (l)
     (if (/= 0 l)
       (mapcar (function (lambda (x) (/ x l))) v)
     )
   )
    (distance '(0 0 0) v)
  )
)

[mkung]

Сообщение от Кулик Алексей aka kpblc mkung, попробуй через vla-runmacro: https://knowledge.autodesk.com/searc...2C707-htm.html

Попробовал - то же самое: код по отдельности работает, при назначении функции та же ошибка.

Код:

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

 (vl-load-com)
(defun c:ibc()
	(setq acadObj (vlax-get-acad-object))
	(setq fileName (findfile "E:\\_РАБОТА\\АСО\\Румянцев\\vba_run\\VBA\\InsertBeamCenter.dvb"))
	(vla-LoadDVB acadObj fileName)
	(vla-RunMacro acadObj "InsertBeamCenter")
	(vla-UnloadDVB acadObj fileName)
)

Без DEFUN, кстати, тоже ошибка.
То есть если я в командную строку ввожу выражения - работает.
Если записываю их в Лисп-файл и загружаю - ошибка.

[Vladimir_Sergeevich]

Сообщение от baaba Код: [Выделить все] (defun Normal3points (p0 p1 p2) (Normalize (CrossProduct (mapcar '- p1 p0) (mapcar '- p2 p0))) ) Код: [Выделить все] (defun CrossProduct (v1 v2) (list (- (* (cadr v1) (caddr v2)) (* (caddr v1) (cadr v2))) (- (* (caddr v1) (car v2)) (* (car v1) (caddr v2))) (- (* (car v1) (cadr v2)) (* (cadr v1) (car v2))) ) ) Код: [Выделить все] (defun Normalize (v) ((lambda (l) (if (/= 0 l) (mapcar (function (lambda (x) (/ x l))) v) ) ) (distance '(0 0 0) v) ) )

Когда все функции загружены, нормально возвращает t/nil в зависимости попадает точка в треугольник или нет...

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

mkung, я не работаю с VBA внутри ACAD (и никому не советую). VBA-Enabler у меня не установлен уже неизвестно сколько времени. Так что проверить не могу и вряд ли когда-нибудь смогу.
По сообщению непонятно, в каком месте вообще ошибка - может, в загрузке, может, в вызове. Кстати: https://www.afralisp.net/archive/met...cro_method.htm

----- добавлено через 40 сек. -----
И туда же, из официальной справки: после загрузки почему-то вызывается не просто имя процедуры:

Код:

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

 (vla-RunMacro acadObj "Module1.Drawline")

[nik120927]

День добрый
как можно автоматический менять свойства точек цивела COGO а именно видимость метки
необходимо закрыть видимость

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

Дампить объект, смотреть его свойства и методы - и работать с ними.

[40in]

Есть полилиния. Через getpoint ввожу 2 точки и через inters получаю точку пересечения с полилинией. В мировой системе координат все работает замечательно, но если я поменяю систему координат на пользовательскую то точки пересечения нет. Прога не работает.
Даже не представляю в каком направлении копать. Подскажите...

[Сергей812]

Сообщение от 40in Даже не представляю в каком направлении копать. Подскажите...

копать в сторону хэлпа:

Return Values: A 3D point, expressed in terms of the current UCS.

пока работали в МСК, то ПСК (она же UCS) совпадала с МСК. Далее читайте про преобразования координат.

[gnuvse]

Здравствуйте.

Я хочу написать игру - тетрис, но я понимаю, что в лоб я ее не напишу, потому что многого не знаю.

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


Спасибо за ваши ответы и время.

[Сергей812]

Сообщение от gnuvse Я хочу написать игру - тетрис

Именно на лиспе в акаде?)
grread - считывание клавиш управления "на ходу в цикле" в цикле.

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

[Massaraksh]

Сообщение от Сергей812 А рабочее поле - вспомните китайские электронные игрушки-96 игр в одной: рабочее поле состоит из квадратиков - 20 шт в высоту и 10шт в ширину. Соответственно, делаете из тех же блоков такое поле (не забыв цвет блоков выставить - по блоку). И далее перекрашиваете блоки под цвет фона, если надо скрыть. И под рабочий цвет - чтобы показать.

Можно и по-другому: перемещать падающие блоки на 1 пиксель вниз с задержкой, скажем, 50 мс, тогда получится "плавный" тетрис.
А вообще, сначала ТС должен сам себе ответить на вопрос: "а как это вообще сделать?", не привязываясь к конкретному языку и системе.

Сообщение от Сергей812 И временную задержку еще откуда взять в цикле - в лиспе ее вроде нет в явном виде.

Есть системная переменная "Millisecs"

----- добавлено через ~3 ч. -----
Хотя, не знаю, а вообще можно ли обновлять экран во время работы скрипта? У меня не получилось.

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

Сообщение от Massaraksh можно ли обновлять экран во время работы скрипта?

redraw или vla-regen - по вкусу.

[gnuvse]

Сообщение от Massaraksh Можно и по-другому: перемещать падающие блоки на 1 пиксель вниз с задержкой, скажем, 50 мс, тогда получится "плавный" тетрис. А вообще, сначала ТС должен сам себе ответить на вопрос: "а как это вообще сделать?", не привязываясь к конкретному языку и системе. Есть системная переменная "Millisecs" ----- добавлено через ~3 ч. ----- Хотя, не знаю, а вообще можно ли обновлять экран во время работы скрипта? У меня не получилось.

Я попробую на бумажке прикинуть, как бы я это сделал.
Но наверняка на бумажке будет проще чем в коде.

Сообщение от Сергей812 Именно на лиспе в акаде?) grread - считывание клавиш управления "на ходу в цикле" в цикле. А рабочее поле - вспомните китайские электронные игрушки-96 игр в одной: рабочее поле состоит из квадратиков - 20 шт в высоту и 10шт в ширину. Соответственно, делаете из тех же блоков такое поле (не забыв цвет блоков выставить - по блоку). И далее перекрашиваете блоки под цвет фона, если надо скрыть. И под рабочий цвет - чтобы показать. Самый трудоемкий - это вопрос алгоритма: пересчет матрицы 20х10 в такт движениям деталек, их смещениям и повороту. И временную задержку еще откуда взять в цикле - в лиспе ее вроде нет в явном виде.

Спасибо за наводку.

[Massaraksh]

Сообщение от Кулик Алексей aka kpblc redraw или vla-regen - по вкусу.

В цикле не работает.
Например:

Код:

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

 (defun C:Tetris ( / )
 (vl-load-com)
 (setq Application (vlax-get-acad-object)
  ActiveDocument (vla-get-ActiveDocument Application)
  ModelSpace (vla-get-ModelSpace ActiveDocument))

  (entmakex '(  (0 . "LWPOLYLINE") (100 . "AcDbEntity") (8 . "0") (100 . "AcDbPolyline") (370 . 0) (90 . 2) (70 . 0) (43 . 10.0000000) (10 100.0000000 100.0000000 0.0) (10 100.0000000 110.0000000 0.0) ))
  (graphscr)
  (setq w 10.0)
  (setq ent (entlast))  
  (vla-ZoomAll Application)
  (setq aaa (getvar "millisecs"))
  (setq bbb (+ aaa 50))      
  (repeat 2000000
  (if (> (getvar "millisecs") bbb)
        (progn
	(setq w (+ w 0.1))
        (setq aaa (getvar "millisecs"))
        (setq bbb (+ aaa 50))
	(setq sss (cons 43 (float w)))
	(entmod (subst sss (assoc 43 (entget ent)) (entget ent)))
	(graphscr)
;	(command "_redraw")
	(vla-regen ActiveDocument 1)
	)  
  )
  
  )
  )

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

Код:

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

 (defun c:tetris (/)
  (vl-load-com)
  (setq application    (vlax-get-acad-object)
        activedocument (vla-get-activedocument application)
        modelspace     (vla-get-modelspace activedocument)
        ) ;_ end of setq
  (entmakex '((0 . "LWPOLYLINE")
              (100 . "AcDbEntity")
              (8 . "0")
              (100 . "AcDbPolyline")
              (370 . 0)
              (90 . 2)
              (70 . 0)
              (43 . 10.)
              (10 100. 100. 0.0)
              (10 100. 110. 0.0)
              )
            ) ;_ end of entmakex
  (graphscr)
  (setq w 10.0)
  (setq ent (entlast))
  (vla-zoomall application)
  (setq aaa (getvar "millisecs"))
  (setq bbb (+ aaa 50))
  (repeat 2000000
    (if (> (getvar "millisecs") bbb)
      (progn (setq w (+ w 0.1))
             (setq aaa (getvar "millisecs"))
             (setq bbb (+ aaa 50))
             (setq sss (cons 43 (float w)))
             (entmod (subst sss (assoc 43 (entget ent)) (entget ent)))
             (graphscr)
             (entupd ent) ; вариант 1
             (redraw) ; вариант 2
             (vla-regen activedocument acactiveviewport) ; вариант 3
             ) ;_ end of progn
      ) ;_ end of if
    ) ;_ end of repeat
  ) ;_ end of defun

Без проверок.

[Massaraksh]

Да, так работает.

Код:

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

 (defun c:tetris (/)
	 (vl-load-com)
	 (setq application    (vlax-get-acad-object)
	       activedocument (vla-get-activedocument application)
	       modelspace     (vla-get-modelspace activedocument)
	       ) ;_ end of setq
	 (entmakex '((0 . "LWPOLYLINE")
	             (100 . "AcDbEntity")
	             (8 . "0")
	             (100 . "AcDbPolyline")
	             (370 . 0)
	             (90 . 2)
	             (70 . 0)
	             (43 . 10.)
	             (10 100. 100. 0.0)
	             (10 100. 110. 0.0)
	             )
	           ) ;_ end of entmakex
	 (graphscr)
	 (setq w 10.0)
	 (setq ent (entlast))
	 (vla-zoomall application)
	 (setq aaa (getvar "millisecs"))
	 (setq bbb (+ aaa 50))
	 (repeat 4000000
	   (if (> (getvar "millisecs") bbb)
	     (progn (setq w (+ w 0.1))
	            (setq aaa (getvar "millisecs"))
	            (setq bbb (+ aaa 50))
	            (setq sss (cons 43 (float w)))
	            (entmod (subst sss (assoc 43 (entget ent)) (entget ent)))
	            (graphscr)
	            (entupd ent) ;
	            (redraw) ;
;	            (vla-regen activedocument activeviewport) ;
	            ) ;_ end of progn
	     ) ;_ end of if
	   ) ;_ end of repeat
	 ) ;_ end of defun

Значит, ТС имеет все возможности добиться успеха.

[Сергей812]

Offtop:

Сообщение от Massaraksh А вообще, сначала ТС должен сам себе ответить на вопрос: "а как это вообще сделать?", не привязываясь к конкретному языку и системе.

как результат этого подхода - запихивать в акад коды лисп на выполнение вместо нормальной работы через COM-интерфейс?)

Сообщение от Сергей812 рабочее поле состоит из квадратиков - 20 шт в высоту и 10шт в ширину.

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

[Massaraksh]

Сообщение от Сергей812 как результат этого подхода

Вообще-то, я озвучил обычный подход:
Сначала надо продумать алгоритм, и только потом заниматься его реализацией на конкретной платформе.

[Сергей812]

Offtop:

Сообщение от Massaraksh Сначала надо продумать алгоритм, и только потом заниматься его реализацией на конкретной платформе.

Платформа накладывает ограничения на реализуемость алгоритма как раз. Абстрактные алгоритмы на идеальной платформе интересны лишь теоретикам)

[vahes911]

Комрады подскажите почему не работает конструкция:

Код:

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

 
(initget 3 ", .")
(setq razd (getkword "\nРазделитель [,/.]: "))

[Сергей812]

Запятая не нравится getkword. Да и лучше так написать, имхо:

Код:

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

 
(initget 1 "Точка Запятая") 
(setq razd (getkword "\nРазделитель [Точка/Запятая]: "))

Вот реально охота разглядывать точку и запятую в комстроке/динвводе?)

p.s. 2-ой бит в initget нет смысла устанавливать, getkword его игнорирует.

[hroost]

Подскажите пожалуйста почему-то в последнее время программа перестала автоматически вставлять таблицу, приходится вставлять через Ctrl+V, кусок кода для вставки таблицы ниже:

Код:

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

 (vla-put-regeneratetablesuppressed vlaTab :vlax-true)
   (vla-put-Height vlaTab(* 1.75(/(length tLst)4)))
   (command "_scale" (entlast) "" '(0 0 0) 250)  ;;11/04/2019
   (princ "\n<<< Вставьте таблицу / >>> ")
   (command "_.copybase"(trans '(0 0 0)0 1)(entlast)"")
   (command "_.erase" (entlast)"")
   (command "_.pasteclip" pause)
   ;(command "_.-insert" pause)
   (setvar "DIMZIN" oZin)
   (setvar "OSMODE" oSnp)
   (setvar "CMDECHO" 1)
   (vla-EndUndoMark actDoc)

[megabeton]

Помогите разобраться с функцией trans

Хочу выделить объекты внутри контура полилинии.
Код ниже работает:

Код:

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

(defun C:вок ( / en pl n ss lst)
	(setq en (car (entsel "\nУкажите полилинию: ")))
	(if 
		(and 
			en 
			(wcmatch (cdr (assoc 0 (entget en))) "*POLYLINE")
		)
		(progn 
			(setq 
				pl	(vlax-ename->vla-object en) 
				n	0
			)
			(while 
				(<= n (vlax-curve-getEndParam pl))
				(setq
					lst (append lst (list (vlax-curve-getPointAtParam pl n)))
					n   (1+ n))
			)
			(lib:Zoom2Lst lst)
			(setq lst (mapcar '(lambda(x)(trans x 0 1)) lst))
			(if 
				(setq ss (ssget "_WP" lst))
				(SSSETFIRST ss ss)
			)
			(setq ss nil)
		)
	)
	(princ)
)

Пытаюсь докрутить код, чтобы выделить объекты внутри полилинии, которая принадлежит блоку

Код:

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

(defun C:вок3 ( / en pl n ss lst)
	(setq en (vlax-vla-object->ename (car (vl-remove-if-not (function (lambda (x) (= (vla-get-objectname x) "AcDbPolyline"))) ((lambda  (/ res) (vlax-for sub (vla-item (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))) (vla-get-effectivename (vlax-ename->vla-object (car (entsel))))) (setq res (cons sub res))) (reverse res)))))))
	(if 
		(and 
			en 
			(wcmatch (cdr (assoc 0 (entget en))) "*POLYLINE")
		)
		(progn 
			(setq 
				pl	(vlax-ename->vla-object en) 
				n	0
			)
			(while 
				(<= n (vlax-curve-getEndParam pl))
				(setq
					lst (append lst (list (vlax-curve-getPointAtParam pl n)))
					n   (1+ n))
			)
			(setq lst (mapcar '(lambda(x)(trans x 0 1)) lst))
			(if 
				(setq ss (ssget "_WP" lst))
				(SSSETFIRST ss ss)
			)
			(setq ss nil)
		)
	)
	(princ)
)

но тут затык.
Имя полилинии из блока вытащил, координаты вершин полилинии получил, но при их преобразовании что то идет не так.
Код работает, объекты выделяет, но только вот область выделения объектов лежит далеко за пределами полилинии / блока

Когда полилинии сама по себе, то преобразование координат из мировой в текущую происходит корректно

Код:

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

(setq lst (mapcar '(lambda(x)(trans x 0 1)) lst))

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

----- добавлено через ~16 мин. -----
Кажется понял, нужно к каждой "местной" координате полилинии прибавить координату базовой точки блока.

[T.Bagdat]

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

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

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

[Boxa]

Сообщение от T.Bagdat Подскажите, можно ли с помощью лиспа подсветить не всю полилинию, а отдельный сегмент, на манер стандартной команды Сопряжение?

не знаю есть ли это на Лисп, но когда мне нужно было реализовать подобное, то я использовал транзитную графику, т.е. просто поверх линии рисовал нужное.

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

Сообщение от Boxa использовал транзитную графику

Читай = NET

[Сергей812]

Можно взять по сути готовый пример .Net, обернуть этот код в аля-лисп и вызывать из кода самого лиспа)

[Boxa]

Сообщение от Сергей812 Можно взять по сути готовый пример .Net

пытался использовать этот код, не понравилось, не наглядно, нет возможности регулировать цвет, жирность или например подсветить не всю линию, а отступив по 100 от узлов...
Переписал именно на транзитную графику.

[T.Bagdat]

Сергей812, спасибо. А можно окончательно разжевать, для совсем не понимающих английский, что именно нужно сделать с этим кодом, чтобы он превратился в аля-лисп ?

Например, на сайте сказано, загрузить код в автокад и выполнить команду

Код:

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

(displayfullname "First" "Last")

Я попробовал сохранить код в формате .lsp и загрузить в автокад.

Код:

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

 using Autodesk.AutoCAD.Runtime;
using Autodesk.AutoCAD.ApplicationServices;
 
[LispFunction("DisplayFullName")]
public static void DisplayFullName(ResultBuffer rbArgs)
{
  if (rbArgs != null)
  {
      string strVal1 = "";
      string strVal2 = "";
 
      int nCnt = 0;
      foreach (TypedValue rb in rbArgs)
      {
          if (rb.TypeCode == (int)Autodesk.AutoCAD.Runtime.LispDataType.Text)
          {
              switch(nCnt)
              {
                  case 0:
                      strVal1 = rb.Value.ToString();
                      break;
                  case 1:
                      strVal2 = rb.Value.ToString();
                      break;
              }
 
              nCnt = nCnt + 1;
          }
      }
 
      Application.DocumentManager.MdiActiveDocument.Editor.
         WriteMessage("\nName: " + strVal1 + " " + strVal2);
  }
}

На что автокад мне выдал:

Код:

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

Команда: _appload DisplayFullName.lsp успешно загружено.


Команда:
nil
nil
nil
nil
nil ; ошибка: no function definition: DISPLAYFULLNAME

Как правильно обернуть такой код в лисп?

Или вот ещё, в этом примере код начинается [LispFunction("DisplayFullName")], а тот код, который нужен мне для подсветки сегментов начинается [CommandMethod("HighlightPolySeg")]. Это влияет на технологию подгрузки?

----- добавлено через ~5 мин. -----

Сообщение от Boxa не знаю есть ли это на Лисп, но когда мне нужно было реализовать подобное, то я использовал транзитную графику, т.е. просто поверх линии рисовал нужное.

Я писал, что пытался рисовать отрезки поверх сегментов:

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

Я не знаю, что такое транзитная графика, но если это что-то более изящное, объясните, пожалуйста, о чём речь.

[Сергей812]

Там не все надо копировать из первой ссылки. Это имя команды для вызова из комстроки, вообще не нужны эти строки. Что на входе в аля-лисп функцию будет - указан примитив (полилиния) и индекс сегмента для выделения или как?

----- добавлено через ~13 мин. -----
и код .Net сначала откомпилировать в сборку *.dll один раз и загружать потом вместе с lsp кодом основным.

[T.Bagdat]

Сообщение от Сергей812 Что на входе в аля-лисп функцию будет - указан примитив (полилиния) и индекс сегмента для выделения или как?

По идее, так, наверное, правильнее всего. Но я себе не очень-то представляю, где взять индекс сегмента. Если для "POLYLINE" можно как-то по вертексам скакать с помощью (entnext), то для обычной "LWPOLYLINE" - это целая часть от параметра, полученного с помощью (vlax-curve-getParamAtPoint) или чего-то наподобие? Или прям есть такое свойство "индекс сегмента"?

А вот после чудесного слова "откомпилировать" мне прям совсем интересно стало

[Сергей812]

Ну примерно так:

Код:

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

// Windows
using System;

// AutoCAD
using Autodesk.AutoCAD.ApplicationServices;
using Autodesk.AutoCAD.DatabaseServices;
using Autodesk.AutoCAD.Runtime;


namespace HighlightSegmentPolyline
{
    public class HighlightSegPolyline
    {

        [LispFunction("HighlightPolySeg")]
        public static void HighlightPolySeg(ResultBuffer aArgs)
        {
            // Получаем текущий документ
            Document lAcadDoc = Application.DocumentManager.MdiActiveDocument;
            if (lAcadDoc == null) return;
            // Получаем БД текущего документа
            Database lAcadDb = lAcadDoc.Database;
            // Если были переданы два параметра
            if ((aArgs != null) && (aArgs.AsArray().Length == 2))
            {
                // Получаем массив аргументов
                Array lArgs = aArgs.AsArray();
                // Получаем Id полилинии
                ObjectId lId = (ObjectId)((TypedValue)lArgs.GetValue(0)).Value;
                // Получаем индекс сегмента
                int lIndexSeg = (Int16)((TypedValue)lArgs.GetValue(1)).Value;
                // **  Пошел код из первой ссылки -) **
                // Открываем транзакцию
                using (Transaction Tx = lAcadDoc.TransactionManager.StartTransaction())
                {
                    // Получаем полилинию
                    Polyline pline = Tx.GetObject(lId, OpenMode.ForRead) as Polyline;
                    // Если полилиния не замкнута (иначе от чего отсчитывать?)
                    if (!pline.Closed)
                    {
                        // Создаём subentpath для сегмента
                        FullSubentityPath path = new FullSubentityPath(new ObjectId[] { pline.Id },
                            new SubentityId(SubentityType.Edge, new IntPtr(lIndexSeg)));
                        // Подсвечиваем сегмент
                        pline.Highlight(path, true);
                    }
                    // Подтверждаем транзакцию
                    Tx.Commit();
                }
            }
        }

    }
}

Вызов из лисп-программы будет выглядеть (HighlightPolySeg %Примитив-полилиния% %Индекс сегмента для выделения (с единицы)%). Для теста:

Код:

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

 (HighlightPolySeg (car (entsel)) 3)

Выделяет третий сегмент выбранной полилинии. Если укажете не полилинию или невалидный индекс сегмента - это уже проблемы вашего кода, проверку соответствия типов не делал в коде. И добро пожаловать в .NETAPI. Расширяйте возможности привычного лиспа за счет вставок .Net кода)

[T.Bagdat]

С проверкой на валидность я справлюсь
А по поводу компиляции и подгрузки хотелось бы сразу уточнить. По ссылке, что вы привели, предлагают загрузить и установить некий ObjectARX. Если это необходимо для того, чтобы код у меня заработал, значит - это не мой случай. На работе нас правами на установку сторонних приложений не балуют. А если это всего лишь среда с базой дополнительных DLL, открывающих новые возможности для того же LISP, а ваш код будет работать и без неё, то подскажите, как и в чём его скомпилировать, и как подгрузить. Попробую скомпилировать его дома, и сбросить на рабочий комп.

В любом случае спасибо, что откликнулись, и нашли время на написание кода

[Сергей812]

Сообщение от T.Bagdat По ссылке, что вы привели, предлагают загрузить и установить некий ObjectARX.

Не обязательно - берете одноименные *.dll из корневой папки акада (где лежит Acad.exe). Только компилировать нужно под ту версию и разрядность, которую в дальнейшем собираетесь использовать. NetApi менее капризнее, чем ObjectARX - поэтому откомпилированные сборки работают обычно на нескольких версиях акада подряд (с одним программным "ядром"), но пока разбираетесь - компилируйте под тот акад, который на рабочем месте. Можно просто библиотеки домой скопировать и там подключить и скомпилировать - если на работе не договоритесь поставить любую бесплатную студию)

----- добавлено через ~11 мин. -----
ну или вообще без студии - с помощью встроенного в сам .Net фреймворк компилятора командной строки csc.exe. Но проще все-таки студию поставить)

----- добавлено через ~20 мин. -----
а чтобы сборка загрузилась вместе с основной лисп-программой - можно тыц.

[T.Bagdat]

Сергей812, Покорнейше благодарю

[superkot007]

Подскажите, как разделить строку?
Строка типа "12x34-AB-56-CD лист 5", необходимо отбросить левую часть, оставив только "лист 5".

[Сергей812]

Сообщение от superkot007 Строка типа "12x34-AB-56-CD лист 5", необходимо отбросить левую часть, оставив только "лист 5".

Код:

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

 (substr "12x34-AB-56-CD лист 5" (1+ (vl-string-search "лист" "12x34-AB-56-CD лист 5")))

[superkot007]

Сообщение от Сергей812 Код: [Выделить все] (substr "12x34-AB-56-CD лист 5" (1+ (vl-string-search "лист" "12x34-AB-56-CD лист 5")))

Все настолько просто?!
Подойдет для лиспа, спасибо!
Offtop: Я через vl-string->list, car, cdr, vl-list->string городить огороды начал...

[Сергей812]

И у лиспа есть функции работы со строками )

[superkot007]

Сергей812, спасибо!
Есть в наличии http://www.private.peterlink.ru/pole.../Alisp2006.htm
Сейчас возникла необходимость написания лиспа - листаю, разбираюсь...

Еще вопрос - если не затруднит: как в лиспе сделать быстрый выбор всех полилиний (адаптирую polyline_coord под свои задачи).
Быстрый выбор ssget я понял. Не понятно, как потом "поштучно" из полученного набора вытаскивать по одному элементу на обработку.

[Сергей812]

Сообщение от superkot007 Не понятно, как потом "поштучно" из полученного набора вытаскивать по одному элементу на обработку.

так откройте эту великолепную книжку) Метод ssname, например

[superkot007]

Сообщение от Сергей812 так откройте эту великолепную книжку) Метод ssname, например

Так листаю ж, пишу))
Решил вопрос, оказалось, модификация не такая сложная.

Остался последний вопрос - как в лиспе получить имя и путь к файлу чертежа, из которого он запустился?
Необходимо сохранять файл извлечений с тем же именем, что и файл чертежа, и в ту же папку.

Можно, конечно, сделать "по классике":

Код:

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

 (open (getfiled "Select Text File" "C:\\" "txt" 1) "a")

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

[skkkk]

Сообщение от superkot007 Остался последний вопрос - как в лиспе получить имя и путь к файлу чертежа, из которого он запустился?

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

Код:

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

(getvar "DWGNAME")
(getvar "DWGPREFIX")

[superkot007]

skkkk, благодарю!

Код:

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

 (open (getfiled "Выбрать файл для сохранения данных" (strcat (getvar "DWGPREFIX")(vl-filename-base (getvar "DWGNAME"))) "txt" 1) "a")

В такой конструкции не будет проблем?
Технически, в составе лиспа, работает корректно.

[skkkk]

Сообщение от superkot007 В такой конструкции не будет проблем?

Не должно быть, вроде.

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

Ну, не будет - если только в ответ на getfiled не нажать Esc

[Сет]

Подскажите, как программно изменить высоту рамки и установить выравнивание мультитекста?

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

Выравнивание: либо менять свойство AttachmentPoint, либо менять 71 группу в DXF. А что за "высота рамки"? Если блок - то соответствующие масштабы.

[Сет]

Сообщение от Кулик Алексей aka kpblc А что за "высота рамки"?

Мультитекст же вписывается в рамку. Мне нужно программно задать ее ширину, высоту и выравнивание. С шириной все просто, с выравниванием ты подсказал, а с высотой пока вопрос.

[Сергей812]

Сообщение от Сет а с высотой пока вопрос.

вроде 45 группа задает отступ рамки от границы самого текста. А сама рамка никак не настраивается - видима, она рассматривается как контейнер для мультитекста, а не как отдельный элемент.

[Сет]

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

Код:

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

 
(vl-load-com)
(setq acad_application (vlax-get-acad-object))
(setq active_document (vla-get-ActiveDocument acad_application))
(setq model_space (vla-get-ModelSpace active_document))

(defun c:my_mtext (/) 
(setq width (atoi (getstring T "Введите ширину текста:")))
(setq height (atoi (getstring T "Введите высоту текста:"))) 
(setq text (atoi (getstring T "Введите текст:")))
(setq mtext (vla-AddMText model_space (vlax-3D-point (getpoint "\nУкажите точку вставки:")) width text))
) 

[jeka_me]

Добрый день.
Прошу написать команду, к примеру "deltemp", при вызове которой, удалялось бы все с конкретного слоя "Temp". И пояснить используемые команды в программе.
Спасибо.

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

Все просто:
1. Проверить наличие слоя
2. Если слой есть, то разблокировать и разморозить
3. Пройтись по всем блокам (включая модель и пространства листов) и удалить в них примитивы, лежащие на слое

Скорее всего, будут проблемы с атрибутами и описаниями атрибутов, но это уже отдельная песня.

[jeka_me]

Благодарю за быстрый ответ, но есть пару нюансов:
1. Алгоритм действительно не сложный и понятный, но с реализацией у меня проблема, хочу воспользоваться: "Научите лиспу на примере (или как kpblc, VVA и компания пытаются обучить чайника лиспу)".
2. Из блоков и листов удалять не надо.

[skkkk]

Сообщение от Кулик Алексей aka kpblc Все просто

Вспомнился Эйнштейн со своим "Вы думаете, что всё так просто? Все просто, но совсем не так!"
jeka_me, "научите" и "напишите" - это ведь два разных слова с далеким друг от друга смыслом. Ход хитрый, но кажется, его уже раскусили
Знаю, знаю, вместо того, чтобы ворчать тут, предложил бы что-то по делу.
Рекомендую попробовать из готового - тема на форуме "Подготовка подосновы". Там есть команда, которая удаляет слой вместе со всеми объектами на нем.
Правда, судя по описанию задачи, сам слой удалять не нужно. Тогда можно вот так (без проверки на блокировку/заморозку слоя, без удаления в блоках и на листах - удаляет в текущем пространстве, т.е. в данном случае - в модели):

Код:

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

 (defun C:deltemp ( / ss)
	(setq ss (ssget "_X" '((8 . "Temp"))))
	(if ss
		(vl-cmdf "_.ERASE" ss "")
		(princ "/nОбъекты не найдены")
	)
	(princ)
)

Код не проверял, но надеюсь, нигде не напортачил, так как особо и негде тут напортачить. В свете последних новостей не уверен, что будет работать на самых новых автокадах. Хотя должен бы.

[jeka_me]

Всего 8 строк, а моей признательности нет границ)
Все работает именно так как я ожидал.
Хорошая мотивация для саморазвития, еще раз выражаю благодарность.

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

А есть еще команда _.laydel, которая заодно и слой сносит...

[Boxa]

Сообщение от Кулик Алексей aka kpblc А есть еще команда _.laydel, которая заодно и слой сносит...

Вооот и лисп уже не очень то и нужен. Сносим слой со всем содержимым и создаем его заново - макрос.

[superkot007]

Добрый вечер!
Как разбить строку на части, например, по встречающимся "-"?
Исходные строки типа "AA.BBxCC.DD-EE-FF-GG-HH-12345-I-J-6.7 лист 98".

Попробовал следующее:

Код:

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

 ...
(setq PP0 (substr PP_ORIG (1+ (vl-string-search "лист" PP_ORIG))))
(setq PP1 (vl-string-right-trim PP0 PIPELINE_ORIG))
(setq PP2 (substr PP1 (1+ (vl-string-search "-" PP1))))
(setq PP3 (vl-string-right-trim PP2 PP1))
...

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

[Сергей812]

Как написан, так и работает) Есть исходная строка, ввести две локальных переменных - индексы начала (SSG) и конца сегмента (ESG).
Вначале SSG=1, ESG=индекс позиции первого разделителя (через поиск)-1. Получили через substr первый сегмент.
А потом SSG=ESG+1(после разделителя), и если SSG не вышло за пределы строки - ищем ESG как следующую позицию разделителя, при этом SSG-1 является позицией начала поиска для vl-string-search.
И так сдвигаемся по исходной строке, не надо никаких подрезок строк делать - наверняка там где-то и вылезают выкидыши ваши из-за несогласованности индексов позиций.

p.s. Если один символ в разделителе - то лучше vl-string-position использовать, наверно - она должна быстрее работать по идее.

[superkot007]

Сергей812, спасибо за расписанный алгоритм)
Получилось примерно следующее:

Код:

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

 (setq SSG 1); - индекс начала сегмента
(setq ESG (vl-string-search "-" PIPELINE_ORIG); - индекс конца сегмента
(setq PIPELINE_UNIT (substr PIPELINE_ORIG SSG ESG)); - извлекаемая секция
(setq PIPELINE_NEXT (substr PIPELINE_ORIG (+ ESG 2))); - хвост без "-"

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

[Сергей812]

Ну я стараюсь поменьше операций изменений строк делать, так как они самые ресурсоемкие)

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

Один из многих вариантов с https://www.theswamp.org/index.php?topic=55402.new#new :

Код:

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

 (defun _peelstring (string del / str pos lst)
  ;; Tharwat - date: 07.Nov.2015        ;;
  (while (setq pos (vl-string-search del string 0))
    (setq str    (substr string 1 pos)
          string (substr string (+ pos (1+ (strlen del))))
    )
    (and str (/= str "") (setq lst (cons str lst)))
  )
  (and string (/= string "") (setq lst (cons string lst)))
  (reverse lst)
)

[VVA]

Еще функция от Евгения Елпанова str-str-lst
Подробнее здесь http://elpanov.com/index.php?id=14

Код:

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

;;;  * Ф-ция str-str-lst
;;;  * Сервисная ф-ция извлечения из строки данных, разделенных
;;;  * каким либо символом или строкой символов
;;;  * Возвращает список строк
;;;  * Аргументы [Type]:
;;;    str - строка для разбора [STRING]
;;;    pat - разделитель [STRING]
;;;  *  Пример запуска
;;;    (setq str "мы;изучаем;рекурсии" pat ";")
;;;    (setq str "мы — изучаем — рекурсии" pat " — ")
;;;    (str-str-lst str pat)
;;;  * Читать подробнее http://elpanov.com/index.php?id=14
(defun str-str-lst (str pat / i)
  (cond ((= str "") nil)
        ((setq i (vl-string-search pat str))
         (cons (substr str 1 i)
               (str-str-lst (substr str (+ (strlen pat) 1 i)) pat)
         ) ;_  cons
        )
        (t (list str))
  ) ;_  cond
) ;_  defun

[superkot007]

Спасибо всем ответившим!
Новый вопрос - как создать список, добавляя каждый элемент через while?
Суть в следующем: обрабатывается набор примитивов, из каждого нужно получить определенный параметр (строка). Перебор примитивов по while и возрастанию порядкового номера примитива понятен и реализован, а вот создание списка и добавление к нему элемента - нет.

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

cons, append и иже с ними.

[superkot007]

Кулик Алексей aka kpblc, ага, функция CONS подошла, спасибо!

[superkot007]

Доброй субботы, форумчане!
Создавать отдельную тему не рискнул, посчитал пост здесь более уместным. Так что извините, если не прав)

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

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

Есть ли какое-нибудь решение по экспорту подобных таблиц в Excel, которое требовало бы минимальной доработки? Поиском пользовался.
Из наиболее близкого, как мне кажется, является pl_export-to-excel.LSP из https://dwg.ru/dnl/6638.
Если "вручную" прорисовать границы ячеек - отрабатывает великолепно, но прорисовка границ займет много времени...
Дополнительная морока - с однострочными текстами в ячейке. Их нужно объединять, а это доп. время... pl_export-to-excel.LSP подправил, под работу с MTEXT (вместо "TEXT" нужно использовать "*TEXT"), про _txt2mtxt из Express - в курсе.

Если бы можно было как-то программно прорисовать внутренние границы, объединить однострочные тексты ячеек в многострочные - можно было бы пользоваться pl_export-to-excel.LSP.

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

[Сергей812]

Сообщение от superkot007 Есть большое количество таблиц в dwg-формате, которые не имеют границ ячеек, только внешние границы самих таблиц. В качестве границ ячеек используются разное расстояние между строками, по которым таблицами вообще можно пользоваться. Отдельные ячейки могут содержать несколько однострочных текстов, могут быть пустыми, объединенных ячеек - нет. Пример выложить не могу, конфиденциальность и все прочее...

а они точно таблицы акада, а не имитация из палочек и текста?)

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

Сообщение от superkot007 подсказки по решению проблемы

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

[Сергей812]

И чем вот это не подошло?

[superkot007]

Сергей812
Не понял про имитацию, если честно)
Есть файлы dwg, в которые программно (неизвестно из чего и так) выгружены данные - однострочные тексты.
Моя задача - собрать таблицы в Excel и обработать.
В ручном режиме я это могу сделать - прорисовать горизонтальные/вертикальные внутренние границы, объединить строки в одной ячейке в MTEXT, применить pl_export-to-excel.LSP. И получу хорошие таблицы... Через несколько недель-месяцев))
Задача - понять, как это все можно автоматизировать и свести ручные доработки к минимуму.

Кулик Алексей aka kpblc
Я изначально предполагал такой алгоритм:
1) получить набор примитивов, входящих в таблицу (выбор по двум точкам противоположных углов области), это сделал;
2) создать "поднаборы" по колонкам (M штук), с сортировкой по координате вставки однострочного текста, сверху вниз - чтобы определить, какая из колонок состоит из наибольшего количества строк (N в будущем массиве);
4) создать "временный" массив (N строк / M столбцов) однострочных текстов - для пустых ячеек предполагалось создавать однострочные тексты постоянного содержания, чтобы все "поднаборы" имели одинаковое количество примитивов, в нужной последовательности;
5) по перебору элементов массива слева-направо, сверху вниз (или по одинаковым порядковым номерам "поднаборов"?) провести проверку однострочных текстов на необходимость сцепления в итоговую таблицу:
- если текст ниже проверяемого - "постоянный", то строка не меняется, если отличается - произвести сцепление;
- в случае сцепления однострочный текст ниже меняется на "постоянный", если вся строка состоит из таких однострочных текстов - она не обрабатывается;
- результаты обработки/сцепки передавать в "итоговый массив" - таблицу (N1 строк / M столбцов), N1 <= N;
6) после получения массива итоговой таблицы - можно прорисовать горизонтальные и вертикальные отрезки;
7) применить pl_export-to-excel.LSP и последовательным выбором пройтись по всем таблицам со всеми границами.

Может, что-то пропустил, неточно описал... Такой алгоритм возможно реализовать?

----- добавлено через ~6 мин. -----

Сообщение от Сергей812 И чем вот это не подошло?

Попадалось. Но это для полноценных таблиц AutoCAD, а у меня примитивы, однострочный текст.
СПДС-овское "втаблицу" тоже не прокатило - нужны внутренние границы для распознавания ячеек.

[Сергей812]

Сообщение от superkot007 Такой алгоритм возможно реализовать?

так как

Сообщение от superkot007 Пример выложить не могу, конфиденциальность и все прочее...

то фиг знает. А почему не выгрузить в эксель содержимое однострочного текста с координатами и там уже не обрабатывать? Если есть координаты в параметрах извлечения данных, не помню навскидку..

[superkot007]

Сергей812
интересная идея обходного решения, не думал об этом)
Извлечь - можно, координаты и содержимое передаются. Но потом это надо "растаскивать", судя по всему - вручную...
По времени - проще "пробежаться" по ячейкам, объединить нужные строки в многострочные тексты, раскидать отрезки в качестве границ и использовать pl_export-to-excel.LSP

Но это натолкнуло на другой алгоритм:
- разместить все области таблиц друг над другом (1 таблица в одном файле, можно автоматом собирать все в одном, задавая смещение вставки относительно уже вставленных, программка - fast-copy, http://weisskrahe.ru/costenfree/costenfree.html);
- в первой колонке есть номера строк таблицы; над ними на какой-нибудь высоте можно автоматом "раскидать" горизонтальные границы ячеек;
- вертикальные границы можно "раскидать" аналогично, тут даже проще, так как нет объединенных ячеек;
- внутри каждой ячейки объединить строки в MTEXT - (выбор текстов по контурам (через КОНТУР (_BOUNDARY) или КПОЛИ (_BPOLY)) и применение к ним _txt2mtxt ?)
- как будет "сетка", подготовленные тексты в ячейках - можно применять pl_export-to-excel.LSP;
- в Excel останется только повторяющиеся шапки убрать и отформатировать.

[Кондратий Тихонович]

В интернете пишуть, что ЛИСП предназначен (и создавался) ИСКЛЮЧИТЕЛЬНО для разработки систем искусственного разума.
Тогда почему на нём пишут только простенькие скриптики в автокаде и больше нигде не используют?

----- добавлено через 58 сек. -----
Хотел создать тему в "разное".
Но там запрещено создавать темы.
А мне вообще во всех разделах почему-то запрещено создавать темы.

Поэтому спрашиваю тут

----- добавлено через ~3 мин. -----
Где можно почитать про использование ЛИСП конкретно для проектирования систем искуственного разума и где можно ознакомиться с примерами ИИ на Лиспе

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

Сообщение от Кондратий Тихонович почему на нём пишут только простенькие скриптики в автокаде и больше нигде не используют?

Кто сказал? http://www.tmeter.ru/ - первое, что приходит на память.

Сообщение от Кондратий Тихонович Где можно почитать про использование ЛИСП конкретно для проектирования систем искуственного разума и где можно ознакомиться с примерами ИИ на Лиспе

Примерно там же, где объясняется, что такое ИИ.

[superkot007]

По какому критерию можно создать набор из полилиний, замкнутых в контур, у которых из общего - длина/ширина и количество вершин (есть прямоугольники с 5 вершинами (1 и 5 совпадают)?
Можно было бы по постоянной длине, но такого параметра после

Код:

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

 (entget (car (entsel)))

не вижу...

[SetQ]

Сообщение от Кондратий Тихонович В интернете пишуть, что ЛИСП предназначен (и создавался) ИСКЛЮЧИТЕЛЬНО для разработки систем искусственного разума. Тогда почему на нём пишут только простенькие скриптики в автокаде и больше нигде не используют?

ИИ тогда не получился, а сам по себе Лисп иногда удобнее процедурных языков.

Сообщение от Кондратий Тихонович Где можно почитать про использование ЛИСП конкретно для проектирования систем искуственного разума и где можно ознакомиться с примерами ИИ на Лиспе

В одно бумажной книге по Лиспу видел коротенькую программу-психотерапевта, это всё что получилось.

Сообщение от superkot007 По какому критерию можно создать набор из полилиний, замкнутых в контур, у которых из общего - длина/ширина и количество вершин (есть прямоугольники с 5 вершинами (1 и 5 совпадают)?

Как бы не пришлось брать список всех полилиний, а потом строить новый по критерию.

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

Что значит "ширина"? ContantWidth? Ну и ладно, собираем все что даст пользователь, а потом из набора убираем ненужное. ИМХО - самый простой способ.

[SetQ]

Сообщение от Кулик Алексей aka kpblc Что значит "ширина"?

Длины коротких сторон прямоугольника, мне кажется.

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

SetQ, ну кто ж его знает

[superkot007]

del

[Сет]

Как программно в мультивыноске задать разную высоту для верхнего и нижнего текста?

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

Задай вручную и посмотри форматирование аннотации - если это многострочный текст, конечно.

[Сет]

Сообщение от Кулик Алексей aka kpblc Задай вручную и посмотри форматирование аннотации - если это многострочный текст, конечно.

Да, что-то я сразу не подумал. Во вложении (первая картинка) слева выноска с текстом 2.5/2.5, а справа 3.5/2.5. Как видно к числителю добавился множитель 1.4 - это понятно. А вот непонятно почему поменялись "pxa" и "pa".

Другой вопрос родился по мультивыноске. Можно ли программно удлинить полку выноски за текст выноски? Вот как во вложении (картинка 2). Там слева оригинальная мультивыноска и мне не нравится, что единица на самом краю полки. Хотелось бы, чтобы текст был посередине полки, как в варианте справа (это уже не мультивыноска, а просто набор примитивов)..

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

Повторюсь: 90% вопросов снимается после ручной настройки элемента и его дампа.

[Сет]

Сообщение от Кулик Алексей aka kpblc Повторюсь: 90% вопросов снимается после ручной настройки элемента и его дампа.

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

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

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

[Сет]

А где можно посмотреть что означают подчеркнутые элементы в структуре, формирующей мультитекст?

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

https://www.google.com/search?client...rmatting+codes
https://adndevblog.typepad.com/autoc...mat-codes.html

[koMon]

Сообщение от Сет Можно ли программно удлинить полку выноски за текст выноски?

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

[Кондратий Тихонович]

Сообщение от SetQ В одно бумажной книге по Лиспу видел коротенькую программу-психотерапевта, это всё что получилось.

Т.е. оказалось, что ЛИСП не годиться для проектирования систем искусственного разума?

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

Изучай, пиши, публикуй. Никто не сказал, что это невозможно: theswamp.org, и поиск по слову genetic. Вперед, учиться никто не запрещает.

----- добавлено через ~2 мин. -----
http://www.theswamp.org/index.php?topic=30434.0
http://www.theswamp.org/index.php?topic=9042.0
Ну и далее по тексту

[SetQ]

Сообщение от Кондратий Тихонович Т.е. оказалось, что ЛИСП не годиться для проектирования систем искусственного разума?

Годится не более, чем другие языки.

[superkot007]

Добрый вечер!
Каким образом формируется набор рамкой по двум точкам?
Определил pt1, pt2, далее (ssget "_W" pt1 pt2) - безрезультатно...

[Кондратий Тихонович]

Сообщение от Кулик Алексей aka kpblc Изучай, пиши, публикуй. Никто не сказал, что это невозможно: theswamp.org, и поиск по слову genetic. Вперед, учиться никто не запрещает.

Учиться тоже надо с умом. А то можно только зря время потерять пытаясь головой пробить кирпичную стену.
Если за 60 лет, что существует ЛИСП, он так и не стал мейнстримным ЯВУ для разработки систем искусственного разума и используется в основном для написания простеньких скриптов в автокаде (и даже в автокаде его теснят VBA и C#), то значит учить его смысла нет

[skkkk]

superkot007,

Код:

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

 (setq ss (ssget "_W" pt1 pt2))
(sssetfirst nil ss)

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

superkot007, обе точки должны быть на экране в момент выбора. По-моему, только в последних версиях что-то на эту тему поправили.

[Boxa]

Сообщение от Кондратий Тихонович В интернете пишуть, что ЛИСП предназначен (и создавался) ИСКЛЮЧИТЕЛЬНО для разработки систем искусственного разума. Тогда почему на нём пишут только простенькие скриптики в автокаде и больше нигде не используют?

Буквально 2 предложения и столько... неточностей.
1.
Кондратий Тихонович, Вы бы хоть Wiki почитали... https://ru.wikipedia.org/wiki/%D0%9B%D0%B8%D1%81%D0%BF

Вот определение из вики:

Лисп (LISP, от англ. LISt Processing language — «язык обработки списков»; современное написание: Lisp) — семейство языков программирования, программы и данные в которых представляются системами линейных списков символов. Лисп был создан Джоном Маккарти для работ по искусственному интеллекту и до сих пор остаётся одним из основных инструментальных средств в данной области. Применяется он и как средство обычного промышленного программирования, от встроенных скриптов до веб-приложений массового использования, хотя популярным его назвать нельзя.

Пометил жирным важное и собственно где здесь про ИСКЛЮЧИТЕЛЬНО для ИИ? Это риторический вопрос, отвечать на него не нужно.

2.
Я пометил и слово семейство в определение, т.е. это не один язык, а масса диалектов. Удивлен, что за 30 лет программирования на С и С++, Вы не осознали разницу в диалектах компилятора.

3.
Пишут простенькие скрипты для автокада именно потому, что диалекты AutoLISP и Visual LISP предназначены для написания простых скриптов под автокад. С Уважением Ваш Капитан очевидность.

4.
Вы видимо не умеете пользоваться поисковиками, иначе Вы бы обнаружили, что лисп используестя и очень активно, например Clojure , один из диалектов лисп под платформы JVM и CLR или Ruby- один из популярных языков для Web разработки.
К примеру вот в этой статье https://techrocks.ru/2018/04/27/prog...s-rating-2018/ можно увидеть, что Во всем мире программисты, которые используют F#, Ocaml, Clojure и Groovy получают самые высокие зарплаты, медианное значение — выше $70 000 в год.
Да и если бы Вы крутились в прогерской тусовке (за 30 лет то), то не могли бы на заметить рост популярности функциональных языков программирования, таких как Common Lisp, F#, Clojure, Haskell, Erlang, Scheme, Ruby.

ЗЫ.
Пока писал все вспоминалась сцена из Основания А.Азимова, где принц регент разговаривает с Леопольдом и ту самую фразу (по памяти): "Так вот, Ты Дурак, Ваше величество!" Обидеть никого не хочу, но вот вспомнилось что то....

[Сет]

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

С непечатными символами выноска смотрится нормально. Но если несколько ее отдалить, то этот непечатный символ визуализируется. Причем почему-то только справа от текста выноски, хотя эти непечатные символы есть и справа, и слева. Можно ли убрать как-то эту визуализацию? А то немного раздражает)

[superkot007]

Добрый вечер!
Есть ли более адекватная конструкция по подсчету количества символов "-" в строке, чем такая:

Код:

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

 (- (length (vl-string->list NABOR)) (length (vl-remove 45 (vl-string->list NABOR))))

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

_$ (setq str "строка-с-б-о-л-ь-ш-и-м-к-о-л-и-чс-е-с-и-т-в-р-м")
"строка-с-б-о-л-ь-ш-и-м-к-о-л-и-чс-е-с-и-т-в-р-м"
_$ (LENGTH (vl-remove-if-not (function (LAMBDA(x)(= x 45))) (VL-STRING->LIST str)))
20

[koMon]

Сообщение от Сет Можно ли убрать как-то эту визуализацию?

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

Код:

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

 (setq mleader_object (vlax-ename->vla-object (car (entsel))))
	new_text_string (strcat (chr 2) "2" (chr 2))
)
(vla-put-textstring mleader_object new_text_string)   

[superkot007]

Сообщение от Кулик Алексей aka kpblc superkot007, обе точки должны быть на экране в момент выбора. По-моему, только в последних версиях что-то на эту тему поправили.

Похоже, в 2020 не работает

Сообщение от skkkk superkot007, Код: [Выделить все] (setq ss (ssget "_W" pt1 pt2)) (sssetfirst nil ss)

Никаких "подсветов" точек нет. В 2006, по Полещуку, был вроде подсвет, но проверить нет возможности.

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

Проверь длину набора - может, он у тебя пустой получается.

[Сет]

Выражение (atof "1,23") возвращает "1.0", а выражение (atof "1.23") возвращает "1.23". Как правильно конвертировать строку в вещественное число, если в качестве разделителя используется запятая?

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

Заменить "," на ".". Например, через vl-string-translate

[Сет]

Сообщение от Кулик Алексей aka kpblc Заменить "," на ".". Например, через vl-string-translate

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

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

В лиспе разделитель только точка, без вариантов. Потери на преобразование (ИМХО) минимальны.

[Сергей812]

Сообщение от Сет А нет способа попроще преобразовывать вещественные с разделителем в виде запятой? Может быть какая-то глобальная установка, определяющая разделитель целой и дробной части. А так придется контролировать каждую строчку, которую преобразовываю.

Напишите свою функцию преобразования на базе atof с контролем наличие запятой. Зачем однотипный код дублировать

[skkkk]

Сообщение от superkot007 Никаких "подсветов" точек нет. В 2006, по Полещуку, был вроде подсвет, но проверить нет возможности.

Похоже, толкуете о разных вещах: один про Фому, другой - про Ерёму. Алексей имеет в виду, что в момент программного выбора ssget'ом обе точки (pt1 и pt2) должны быть в пределах видимой части экрана. Обычно я в таких случаях делаю зум по двум точкам, выбор, затем возврат предыдущего вида. При несильно загруженном чертеже и "правильном" значении переменной VTENABLE пользователь этого даже не замечает.
Что значит, "подсветов точек" я не понял. Цель - выделить синими ручками (квадратами) точки в рамке, ограниченной точками pt1 и pt2, или же нужно визуальное отображение рамки выбора?
Нужны подробности.

Сообщение от Сет А нет способа попроще преобразовывать вещественные с разделителем в виде запятой? Может быть какая-то глобальная установка, определяющая разделитель целой и дробной части. А так придется контролировать каждую строчку, которую преобразовываю.

Я, помнится, совершенно не контролировал строки на наличие запятой. Просто оборачивал atof в функцию замены символов в строке, и если запятая в строке имелась, она заменялась точкой, если же нет - возвращалась строка без изменений. Правда, не помню, какая это была функция: vl-string-translate или vl-string-subst.

[40in]

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

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

Конкретно здесь сработало:

Код:

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

 (setq lead (car (entsel)))
(mapcar (function cdr) (vl-remove-if-not (function (LAMBDA(x)(and (=(car x)330) (= (cdr(assoc 0 (entget (cdr x)))) "ATTDEF")))) (entget lead)))

Но я далеко не уверен, что это правильно

[40in]

Спасибо! Только подскажите как получить значение атрибута. Я вижу только название атрибута.

(setq lead (car (entsel)))
(setq spis (mapcar (function cdr) (vl-remove-if-not (function (LAMBDA (x) (and (= (car x) 330) (= (cdr (assoc 0 (entget (cdr x)))) "ATTDEF")))) (entget lead))))
(setq att0 (entget (nth 0 spis)))

((-1 . <Имя объекта: -1de948>) (0 . "ATTDEF") (330 . <Имя объекта: -1df060>) (5 . "6948F") (100 . "AcDbEntity") (67 . 0) (8 . "0") (440 . 16777216) (100 . "AcDbText") (10 -0.26929 1.56192 0.0) (40 . 2.5) (1 . "") (50 . 0.0) (41 . 1.0) (51 . 0.0) (7 . "Standard") (71 . 0) (72 . 0) (11 0.0 0.0 0.0) (210 0.0 0.0 1.0) (100 . "AcDbAttributeDefinition") (280 . 0) (3 . "") (2 . "ПРЕПЯТСВИЕ") (70 . 0) (73 . 0) (74 . 0) (280 . 1))

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

Достаточно было немного подробнее посмотреть на результаты entget:

Код:

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

 (defun t1 (lead / elist)
;; (t1 (car (entsel)))
  (setq elist (entget lead))
  (mapcar (function (lambda (x) (cons (cdr (assoc 2 (entget (cdr x)))) (cdr (assoc 302 (member x elist))))))
          (vl-remove-if-not (function (lambda (x) (and (= (car x) 330) (= (cdr (assoc 0 (entget (cdr x)))) "ATTDEF"))))
                            elist
                            ) ;_ end of vl-remove-if-not
          ) ;_ end of mapcar
  ) ;_ end of defun

[40in]

А и правда, все просто! И как это я сам не увидел, простофиля!...
Большое человеческое спасибо!

[superkot007]

Сообщение от skkkk Похоже, толкуете о разных вещах: один про Фому, другой - про Ерёму. Алексей имеет в виду, что в момент программного выбора ssget'ом обе точки (pt1 и pt2) должны быть в пределах видимой части экрана. Обычно я в таких случаях делаю зум по двум точкам, выбор, затем возврат предыдущего вида. При несильно загруженном чертеже и "правильном" значении переменной VTENABLE пользователь этого даже не замечает. Что значит, "подсветов точек" я не понял. Цель - выделить синими ручками (квадратами) точки в рамке, ограниченной точками pt1 и pt2, или же нужно визуальное отображение рамки выбора? Нужны подробности.

Да, по поводу зумирования недопонял, спасибо за разжевывание и одновременное решение по зуму))
В книге об этом не было сказано, там про "подсвечивание пунктиром примитивов из набора".
Тогда проверю в своем коде еще раз.

Если чертеж небольшой - проще, наверное, будет сразу весь его выводить в видимую часть экрана - как это сделать, не подскажите?

[skkkk]

Видимо,

Код:

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

 (vla-ZoomAll (vlax-get-acad-object))

[Red Nova]

Привет други.
Вот вам вопрос.
Имеется Excel файл с ценами на перечень продукции.
Цены периодически меняются, соответственно файл обновляется.
Требуется из лиспа заглянуть в Excel файл, найти строку с именем продукта, и для этой строки получить значения ячейки с ценой.
Нечто похожее на VLOOKUP, только работаем из лиспа.
Это реализуемо?

Добавлено.
Пример Excel файла прикрепляю.
В столбце А наименование продукта.
В столбце B цена.

[Сергей812]

Сообщение от Red Nova Требуется из лиспа заглянуть в Excel файл, найти строку с именем продукта, и для этой строки получить значения ячейки с ценой. Нечто похожее на VLOOKUP, только работаем из лиспа.

Одна цена на одно имя продукта?

[Red Nova]

Сообщение от Сергей812 Одна цена на одно имя продукта?

Все верно.
Обновил исходный пост, добавил пример файла с данными.

[Сергей812]

все равно же будете открывать эксель и загружать в него файл (программно или вручную). Так пускай эксель и ищет: делаете скрытую строку над таблицей (чтобы не смущать заполняющих таблицу). В ячейку А1 заносите имя продукта, в ячейку B1 формулу: через функции ПОИСКПОЗ находите строку с данных продуктом, а затем через функцию ИНДЕКС подтягиваете значение цены. И все сводится к записи в ячейку А1 имени продукта, и забора значения цены из B1 ячейки (или B2 - какая там нужна). Чтение/запись в ячейку листа экселя на лиспе в инете 100% есть)

[skkkk]

Red Nova, вот тут прога от Евгения Елпанова - считывает эксель-файл в список лисп. Выдернуть значение нужной ячейки из списка, думаю, не составит труда. Предполагаю, что с помощью assoc. Правда, код не проверял.

[Сергей812]

или сохранить в экселе в текстовой формат, а потом считать в лиспе.

----- добавлено через ~15 ч. -----
и это проще всего, кстати - сохранить в текстовой файл с разделителями-табуляторами. А при чтении этого файла распарсивать считанную строку rls:

Код:

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

 (setq i1 (vl-string-position 9 rls))
(setq i2 (vl-string-position 9 rls 0 T))
(setq n (substr rls 1 i1))
(setq c1 (atof (substr rls (+ i1 2) (1- (- i2 i1)))))

и создавать список из точечных пар. А далее assoc и cdr по имени продукта.

[Red Nova]

Спасибо за советы
skkkk - Не сумел заставить программы Елпанова работать. Может проблема х64, а может руки крюки...

Сергей812

или сохранить в экселе в текстовой формат, а потом считать в лиспе.

Примерно так и сделал. Сохранил как csv файл, прочитал и выудил assoc-ом.

Код:

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

 ;(GetPartPrice part)
;(setq part "SPS033X3.0-1BX120")

(defun GetPartPrice ( part / tbl price)
  (setq tbl (LM:readcsv "C:\\Users\\abaghdasaryan\\Desktop\\test.csv"))
  (setq price (cadr (assoc "SPS033X3.0-1BX120" tbl)))
  )
  

;; Read CSV  -  Lee Mac
;; Parses a CSV file into a matrix list of cell values.
;; csv - [str] filename of CSV file to read
 
(defun LM:readcsv ( csv / des lst sep str )
    (if (setq des (open csv "r"))
        (progn
            (setq sep (cond ((vl-registry-read "HKEY_CURRENT_USER\\Control Panel\\International" "sList")) (",")))
            (while (setq str (read-line des))
                (setq lst (cons (LM:csv->lst str sep 0) lst))
            )
            (close des)
        )
    )
    (reverse lst)
)

;; CSV -> List  -  Lee Mac
;; Parses a line from a CSV file into a list of cell values.
;; str - [str] string read from CSV file
;; sep - [str] CSV separator token
;; pos - [int] initial position index (always zero)
 
(defun LM:csv->lst ( str sep pos / s )
    (cond
        (   (not (setq pos (vl-string-search sep str pos)))
            (if (wcmatch str "\"*\"")
                (list (LM:csv-replacequotes (substr str 2 (- (strlen str) 2))))
                (list str)
            )
        )
        (   (or (wcmatch (setq s (substr str 1 pos)) "\"*[~\"]")
                (and (wcmatch s "~*[~\"]*") (= 1 (logand 1 pos)))
            )
            (LM:csv->lst str sep (+ pos 2))
        )
        (   (wcmatch s "\"*\"")
            (cons
                (LM:csv-replacequotes (substr str 2 (- pos 2)))
                (LM:csv->lst (substr str (+ pos 2)) sep 0)
            )
        )
        (   (cons s (LM:csv->lst (substr str (+ pos 2)) sep 0)))
    )
)

(defun LM:csv-replacequotes ( str / pos )
    (setq pos 0)
    (while (setq pos (vl-string-search  "\"\"" str pos))
        (setq str (vl-string-subst "\"" "\"\"" str pos)
              pos (1+ pos)
        )
    )
    str
)

[Сергей812]

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

[Сет]

Вопрос, наверное, элементарный, но подскажите, как нарисовать полилинию, имеющую дуговой сегмент? По точкам.

[koMon]

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

[Сет]

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

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

[Сергей812]

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

[Сет]

Сообщение от Сергей812 а если нарисовать отдельно сегменты, а потом команду join применить и выбрать последний примитив?

Да, так можно сделать. Но думал можно как-то "красивее" эту задачу решить.

[Vladimir_Sergeevich]

Red Nova, очень давно на форуме скопипастил, уже не скажу у кого, но всегда работало:

Код:

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

 (defun html-export (path)
  ((lambda (excel)
     (vlax-invoke-method (vlax-get-property excel 'Workbooks) 'Open path)
     ((lambda (ret)
        (vlax-invoke-method excel 'Quit)
        ret)
      (mapcar '(lambda (row) (mapcar 'vlax-variant-value row))
              (vlax-safearray->list
               (vlax-variant-value
                (vlax-get-property
                 (vlax-get-property
                  (vlax-get-property
                   (vlax-get-property excel 'Worksheets) 'Item 1) 'UsedRange) 'Value))))))
   (vlax-create-object "excel.application")))

это чудо благополучно жрало как *.xls, так и *.xlsx
Сет, вычисляй центр кривой и задавайся кривизной

Код:

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

 (defun arc-get-bulge (p1 p2 pc / ang) ;;;* Возвращает кривизну дуги
	(if (< (abs (- (angle pc p2) (angle pc p1) ) ) pi)
		(_dwgru-trigon-tan (/ (- (angle pc p2) (angle pc p1)) 4)) 
		(_dwgru-trigon-tan (/ (- (* 2 pi) (- (angle pc p1) (angle pc p2))) 4))	
	)
)

[koMon]

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

если точки будут вводиться мышью, то можно:
1. по вводимым точкам динамически отрисовывать плинию
2. при этом для конвертации какого-то угла в дугу нужно сделать перехватчик указания на это действие и как-то задавать радиус дугового сегмента. в результате будут пересчитаны конец и начало двух последних сегментов и между ними будет вставлен дуговой сегмент. можно даже сделать динамические изменения для направления дугового сегмента и радиуса.
3. это должно выглядеть красиво
4. но потребует написания нешуточного лиспа.

если генерить плинию по координатам из файла - это много упростит лисп имхо, но считать всё равно придётся.

[Red Nova]

Сообщение от Vladimir_Sergeevich Red Nova, очень давно на форуме скопипастил, уже не скажу у кого, но всегда работало: Код: (defun html-export (path) ((lambda (excel) (vlax-invoke-method (vlax-get-property excel 'Workbooks) 'Open path) ((lambda (ret) (vlax-invoke-method excel 'Quit) ret) (mapcar '(lambda (row) (mapcar 'vlax-variant-value row)) (vlax-safearray->list (vlax-variant-value (vlax-get-property (vlax-get-property (vlax-get-property (vlax-get-property excel 'Worksheets) 'Item 1) 'UsedRange) 'Value)))))) (vlax-create-object "excel.application"))) это чудо благополучно жрало как *.xls, так и *.xlsx

Спасидо Vladimir_Sergeevich, работает

[Vladimir_Sergeevich]

Приветствую, коллеги!
Мастера, гуру, научите плохому!
Два вопроса:
1. Как лучше обрабатывать нажатие ESC при обработке (grread)? а. *error*, b. vl-catch-all-apply
2. Это вообще адекватное решение, перерисовывать выноску с отловом точки через grread?

С подачи koMon написал себе небольшую функцию... скрестив её с одной из своих программок по обработке плана получилось совсем красота, но не до конца...

Код:

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

 (defun sad-parse-ml-line ( mlObj / err temp originPt originDl mlBasePt mlDestPoint pt_variant fl)
	(defun dir2pt (ang / ) (list (cos ang) (sin ang) 0)) 
	(defun pt2dir (pt / ang)
	;;; input - 2d vector
	;;; return - direction in rad
		(setq ang (atan (/ (cadr pt) (car pt)))	)
		(cond 
			((< (car pt) 0) (setq ang (+ ang (* pi 1))))
			((and (>= (car pt) 0) < (cadr pt) 0) (setq ang (+ ang (* pi 2)))) 
		)
		ang
	)
	(defun 2ptVariant (pt1 pt2 /  )
	;;;input - 2 points
	;;;output - vla-variant
		(vlax-make-variant
			(vlax-safearray-fill 
				(vlax-make-safearray 
					vlax-vbDouble 
					'(0 . 5) 
				) 
				(append pt1 pt2)
			) 	
		) 
	)
	(defun dlDir (obj ptBase ptEnd / dlVec txtVec rez alf)
	;;;
	;;;return - vla-variant - DogLeg's vector
		(setq 
			txtVec (vla-get-TextRotation obj) ;; dirction text
			dlVec (angle ptEnd ptBase)
		)
		(if ;;angle betveen vecs
			(> 	(setq alf (abs (- txtVec dlVec) )) pi	) 
			(setq alf (abs (- dlVec txtVec) )) 
		)
		(if (> alf pi) (setq alf (- (* pi 2) alf)))
		(if (< alf (* pi 0.5 ) )
			(setq rez (dir2pt (+ txtVec pi)))
			(setq rez (dir2pt txtVec))
		)
		(vlax-3d-point rez)
	)
	(setq 
		err *error*
		temp (vlax-safearray->list (vlax-variant-value (vla-GetLeaderLineVertices mlObj 0)))
		mlBasePt (list (car temp) (cadr temp) (caddr temp))
		temp (cdr (cdr (cdr temp)))
		originPt (list (car temp) (cadr temp) (caddr temp))
		originDl (vla-GetDoglegDirection mlObj 0)
		fl t
	)
	(defun *error* (msg) 
		(vla-SetDoglegDirection mlObj 0 originDl)
		(vla-SetLeaderLineVertices mlObj 0 (2ptVariant mlBasePt originPt))
		(setq *error* err)
		(princ "*Прервано*")
	)
	(while fl
		(setq temp (grread t 12 0))
		(if (or (= (car temp) 5) (= (car temp) 3)) 
		(progn
			(vla-SetLeaderLineVertices mlObj 0 (2ptVariant mlBasePt (cadr temp))) 
			(vla-SetDoglegDirection mlObj 0 (dlDir mlObj mlBasePt (cadr temp)))
		))
		(if (or (= (car temp) 3) (= (car temp) 25)) (setq fl nil))
	) ;;while
	(if (not (or (/= (car temp) 3) (/= (car temp) 25))) (vla-SetLeaderLineVertices mlObj 0 (2ptVariant mlBasePt originPt)))
	(setq *error* err)
	mlObj
)	

Собственно тут это дело обрабатывается эррором. Если использовать как самодостаточную программу навесив выбор мультивыноски - то наверно совсем норм пойдет (только зачем - не могу придумать). В моем же случае это только завершающий штрих большего дела. Итого: выноска уже построена программой, нажат ESC и все вернулось к базовым точкам исходных объектов... на этом код обрывается.
По идее, после построения выноски исходный объект (раньше был текст, сейчас блок с атрибутом) затирается. Теперь же при отмене и блок на месте и выноска сверху сидит. Как то бы продолжить выполнение кода после обрыва в этой функции...

Offtop: да начнется закидывание помидорами

p.s. версия с vl-catch-all-apply выглядит веселей...

Код:

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

 (defun sad-parse-ml-line ( mlObj / temp originPt originDl mlBasePt mlDestPoint pt_variant fl) ;|двигаем выноску
	*аргумент - vla-object мультивыноски
	*возвращет - vla-object мультивыноски или nil при нажатии esc
	|;
	(defun dir2pt (ang / ) (list (cos ang) (sin ang) 0)) 
	(defun pt2dir (pt / ang)
	;;; input - 2d vector
	;;; return - direction in rad
		(setq ang (atan (/ (cadr pt) (car pt)))	)
		(cond 
			((< (car pt) 0) (setq ang (+ ang (* pi 1))))
			((and (>= (car pt) 0) < (cadr pt) 0) (setq ang (+ ang (* pi 2)))) 
		)
		ang
	)
	(defun 2ptVariant (pt1 pt2 /  )
	;;;input - 2 points
	;;;output - vla-variant
		(vlax-make-variant
			(vlax-safearray-fill 
				(vlax-make-safearray 
					vlax-vbDouble 
					'(0 . 5) 
				) 
				(append pt1 pt2)
			) 	
		) 
	)
	(defun dlDir (obj ptBase ptEnd / dlVec txtVec rez alf)
	;;;
	;;;return - vla-variant - DogLeg's vector
		(setq 
			txtVec (vla-get-TextRotation obj) ;; dirction text
			dlVec (angle ptEnd ptBase)
		)
		(if ;;angle betveen vecs
			(> 	(setq alf (abs (- txtVec dlVec) )) pi	) 
			(setq alf (abs (- dlVec txtVec) )) 
		)
		(if (> alf pi) (setq alf (- (* pi 2) alf)))
		(if (< alf (* pi 0.5 ) )
			(setq rez (dir2pt (+ txtVec pi)))
			(setq rez (dir2pt txtVec))
		)
		(vlax-3d-point rez)
	)
	(setq 
		temp (vlax-safearray->list (vlax-variant-value (vla-GetLeaderLineVertices mlObj 0)))
		mlBasePt (list (car temp) (cadr temp) (caddr temp))
		temp (cdr (cdr (cdr temp)))
		originPt (list (car temp) (cadr temp) (caddr temp))
		originDl (vla-GetDoglegDirection mlObj 0)
		fl t
	)
	(defun *error* (msg) 
		(vla-SetDoglegDirection mlObj 0 originDl)
		(vla-SetLeaderLineVertices mlObj 0 (2ptVariant mlBasePt originPt))
		(setq *error* err)
		(princ "*Прервано*")
	)
	(while fl
		(if (vl-catch-all-error-p (setq temp (vl-catch-all-apply 'grread '(t 12 0))))
			(progn ;;ESC
				(vla-SetDoglegDirection mlObj 0 originDl)
				(vla-SetLeaderLineVertices mlObj 0 (2ptVariant mlBasePt originPt))
				(setq fl nil mlObj nil)
			) 
			(progn 
				(if (or (= (car temp) 5) (= (car temp) 3)) 
					(progn
						(vla-SetLeaderLineVertices mlObj 0 (2ptVariant mlBasePt (cadr temp))) 
						(vla-SetDoglegDirection mlObj 0 (dlDir mlObj mlBasePt (cadr temp)))
				))
				(if (or (= (car temp) 3) (= (car temp) 25)) (setq fl nil))
			)
		)

	) ;;while
	mlObj
)	

p.p.s.
по первому вопросу уже сам отдаю предпочтение vl-catch-all-apply.
Привязал функцию уже ко второму костылю и радуюсь как младенец...
А второй вопрос остается на повестке дня

[koMon]

Offtop: Эммммм...
Ну вот ведь не зря говорят: "Не делай людям добра, вернрётся злом сторицей."

Сообщение от Vladimir_Sergeevich научите плохому!

Vladimir_Sergeevich, при всей моей толерастной индифферентности, звучит так, что ты записал меня в отряд мальчишей-плохишей

Сообщение от Vladimir_Sergeevich 1. Как лучше обрабатывать нажатие ESC

...

Сообщение от Vladimir_Sergeevich 2. Это вообще адекватное решение, перерисовывать выноску с отловом точки через grread?

Не рассматривая технический момент адекватности решения, придумалась вот мне такая притча.
Имеем два персонажа. Утопающий и спасающий на водах. Ключевой момент - утопающий без спасжилета. Ну естественно спасающий спас-таки утопающего. И вот после счастья пш, утопающий озадачивается юридическим, так сказать, вопросом: "Спасающий был без спасжилета, что является грубейшим нарушением текущего законодательства по вопросу нахождения в водном пространстве. А подам-ка я на него в суд и стребую с него компенсацию за какой-то там ущерб!.."

[Vladimir_Sergeevich]

koMon, та я без злого умысла. мне раньше не приходила идея пользовать grread в подобных целях... вот за идею то, я премного благодарен

[ShaggyDoc]

Сообщение от Vladimir_Sergeevich уже сам отдаю предпочтение vl-catch-all-apply. Привязал функцию уже ко второму костылю и радуюсь как младенец...

Вообще-то использовать *error* давным давно (с появления vl-) не стоит.

В этом случае по ESC происходит прерывание всей программы и можно только попытаться восстановить какие-то настройки.

А надо иметь конструкцию наподобие

Код:

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

try
// попытка каких-то действий
except
// действия при ошибке
end;

Это как раз можно сделать с помощью семейства vl-catch. Но если сначала в первой, а потом в сотнях программ начинать их применять "снизу", непременно запутаешься и будут уже сотни ошибок. Лучше сделать библиотечную функцию обертку. Например

Код:

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

 
(defun ru-error-catch  (protected_expression on_error_expression / catch_error_result)
;|
Пример вызова
(ru-error-catch
    (function (lambda ()
                ;;; защищаемое выражение  
                (
                
                )
                ;;; То что вернет - будет результатом
              )
    )
    (function
      (lambda (err_msg)
        ;; если надо - выводим сообщение. err_msg подставит Автокад
        (princ (strcat "\nОШИБКА такой-то функции: " err_msg))
        ;; возвращаем NIL при ошибке
        nil
      ) 
    ) 
  )

|;
  
  (setq catch_error_result
         (vl-catch-all-apply protected_expression)
  ) 
  (if (and (vl-catch-all-error-p catch_error_result)
           on_error_expression
      ) 
    (apply on_error_expression
           (list (vl-catch-all-error-message catch_error_result))
    ) 
    catch_error_result
  ) 
) 

[Browning Zed]

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

Код:

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

(defun c:mblank ( / js n dxf_ent)
	(setq js (ssget '((0 . "MTEXT"))))
	(cond
		(js
			(repeat (setq n (sslength js))
				(setq dxf_ent (entget (ssname js (setq n (1- n)))))
				(entmod (append dxf_ent '((90 . 1) (63 . 8) (45 . 1.1) (441 . 0))))
			)
		)
	)
)

[skkkk]

С использованием функции mip:entsel от VVA (включена в код):

Код:

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

 (defun c:ciclemblank ( / js flag ent n dxf_ent)
	(setq js T)
	(while js
		(if	(setq js (ssget "_I" '((0 . "MTEXT"))))
			(progn 
				(setq flag T)
				(sssetfirst nil nil)
			)
			(progn 
				(setq ent (mip:entsel "\nВыберите объект:" '("MTEXT") nil))
				(if ent (setq js (ssadd) js  (ssadd ent js)))
			)
		)
		(cond
			(js
				(repeat (setq n (sslength js))
					(setq dxf_ent (entget (ssname js (setq n (1- n)))))
					(entmod (append dxf_ent '((90 . 1) (63 . 8) (45 . 1.1) (441 . 0))))
				)
			)
		)
		(if flag (setq js nil))
	)
)


(defun mip:entsel (promt filter entlist / key n newentlist ent_point promt)
;;;Функция mip:entsel
;;;Еденичный выбор объекта, замена функции entsel
;;;Возвращает entity name выбранного примитива или nil, точку указания запоминает в переменной LASTPOINT
;;;Параметры:
;;;promt - предложение выбрать объект (string)
;;;filter - фильтр объектов для выбора вида '("LINE" "LWPOLYLINE")
;;;entlist - список примитивов которые не надо выбирать (либо список entity name, либо PICKSET)
;;;
;;;Примеры:
;;;(mip:entsel "\nВыберите объекты" '("LINE" "LWPOLYLINE") nil)
;;;(mip:entsel "\nВыберите объекты" nil nil)
;;;(setq aa nil) (mip:entsel "\nВыберите объекты" '("LINE" "LWPOLYLINE") (while (setq a (car (entsel))) (setq aa (append aa (list a)))))
;;;(mip:entsel "\nВыберите объекты" '("LINE" "LWPOLYLINE") (ssget))
  (setq key T n 0 newentlist nil)
  (if (eq (type entlist) 'PICKSET)
    (progn
    	(while (setq a (ssname entlist n)) (setq newentlist (append newentlist (list a)) n (1+ n)))
    	(setq entlist newentlist)
    );progn
   );if
    (while key
    	(if (or (setq ent_point (entsel promt)) (= (getvar "ERRNO") 7))
	  	(if (or (eq (type ent_point) 'LIST) (not ent_point))
		  (if ent_point
		    (if (member (setq ent (car ent_point)) entlist)
		      (princ "\nПримитив уже выбран")
		      (if filter
			      (if (not (member (cdr (assoc 0 (entget ent))) filter))
				(progn (setq str "\nНеверный выбор, выберите: ")
				  (princ (substr (setq str (foreach n filter (setq str (strcat str n ", ")))) 1 (- (strlen str) 2)))
				);progn
				(setq key nil)
			      );if
				(setq key nil)
			);if
		    );if
		    (setq key T)
		  );if
	    	(setq key nil)
	    );if
	  (setq key nil)
      	);if
     );while
  (if (eq (type ent_point) 'LIST)
    (progn (setvar "LASTPOINT" (cadr ent_point)) ent)
    ent_point
  );if
);defun

(princ "C:CICLEMBLANK")(princ)

[Browning Zed]

Спасибо большое, все работает. Не подскажете, сложно ли будет связать ваш код с лиспом который преобразует Text в MText, чтобы если был выбран простой текст он сначала конвертировался в MText, а потом сразу же маскировался?

Код:

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

 (defun c:текст2ћтекст (/		nameset	  setlength namtxtrun txtrun
	      p_text	p_kord	  p_sloy    p_styl    p_ugol
	      p_heig	ugol	  deltX	    deltY     n_kord
	      spis_st
	     )
  (setq nameset (ssget "_:L" '((0 . "TEXT"))))
  (setq setlength (sslength nameset))
  (setq i -1)
  (repeat setlength
    (setq i (1+ i))
    (setq namtxtrun (ssname nameset i))
    (setq txtrun (entget namtxtrun))
    (setq p_text (assoc 1 txtrun))
    (setq p_kord (cdr (assoc 10 txtrun)))
    (setq p_sloy (assoc 8 txtrun))
    (setq p_styl (assoc 7 txtrun))
    (setq p_ugol (assoc 50 txtrun))
    (setq p_heig (assoc 40 txtrun))
    (setq ugol (- (* 2 pi) (cdr p_ugol)))
    (setq deltX (* (cdr p_heig) (sin ugol)))
    (setq deltY (* (cdr p_heig) (cos ugol)))
    (setq n_kord (list 10
		       (+ (car p_kord) deltX)
		       (+ (cadr p_kord) deltY)
		       (last p_kord)
		 )
    )
    (setq spis_st (list	'(0 . "MTEXT")	 '(100 . "AcDbEntity")
			p_sloy		 '(100 . "AcDbMText")
			n_kord		 p_heig
			p_text		 p_ugol
			p_styl
		       )
    )
    (entmake spis_st)
    (entdel namtxtrun)
  )
)

[koMon]

Сообщение от Browning Zed текст выбирается путем указания единственной точки и маскируется без подтверждения выбора, команда зацикливается до тех пор пока не будет отменена по эскейпу или ПКМ. Также, если MTEXTы (ТЕКСТы) были выбраны ранее, происходит его их маскировка, и команда завершается.

Код:

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

 
;****************************************************************************************************************************

(vl-load-com)

;****************************************************************************************************************************

(defun text_to_mtext (text_entity / ) 
	(entmakex (subst '(100 . "AcDbMText")
			 		 '(100 . "AcDbText")
			 		  (append '((0 . "MTEXT"))
			 				   (reverse
							   	   (cdr
										(reverse
			 				   				(vl-remove-if-not '(lambda (every_dxf_group)
			 														(member (car every_dxf_group) '(100 10 67 410 8 40 50 1 7))
			 												   )
			 												   (entget text_entity)
			 					 			)
			 			   	   			)
								   )
							   )
							   '((71 . 7))
			 		  )
			  )
	)
)

;****************************************************************************************************************************

(defun pick_entity_function ( pick_prompt group_0_list / entity_not_picked picked_entity)
	(while (null entity_not_picked)
		(setq picked_entity (vl-catch-all-apply 'entsel (list pick_prompt)))
		(cond
			(
				(null picked_entity)
			)
			(
				(vl-catch-all-error-p picked_entity)
					(setq entity_not_picked t)
					nil
			)
			(
				t
					(if (member (cdr (assoc 0 (entget (car picked_entity)))) group_0_list)
						(progn
							(setq entity_not_picked t)
							(car picked_entity)
						)
					)
			)
		)
	)
)

;****************************************************************************************************************************

(defun set_mtext_background_mask (mtext_entity / )
	(entmod (append (entget mtext_entity) '((90 . 1) (63 . 8) (45 . 1.1))))
)
;	441 Transparency of background fill color (not implemented)

;****************************************************************************************************************************

(defun check_entity_selected (entity_selected /)
	(cond
		(
			(= "MTEXT" (cdr (assoc 0 (entget entity_selected))))
				(set_mtext_background_mask entity_selected)
		)
		(
			(= "TEXT" (cdr (assoc 0 (entget entity_selected))))
				(set_mtext_background_mask (text_to_mtext entity_selected))
				(vla-erase (vlax-ename->vla-object entity_selected))
		)
		(
			t
		)
	)
)

;****************************************************************************************************************************


(defun c:add_mtext_bgmask (/ command_not_stopped picked_entity afore_sset)
	(while (null command_not_stopped)
		(cond
			(
				(setq afore_sset (cadr (ssgetfirst)))
					(while (setq picked_entity (ssname afore_sset 0))
						(check_entity_selected picked_entity)
						(ssdel picked_entity afore_sset)
					)
					(sssetfirst)
					(setq command_not_stopped t)
			)
			(
				picked_entity
					(check_entity_selected picked_entity)
					(setq command_not_stopped t)
			)
			(
				(setq picked_entity (pick_entity_function "\nВыберите МТекст/Текст для маскирования: " '("TEXT" "MTEXT")))
					(check_entity_selected picked_entity)
					(setq picked_entity nil)
			)
			(
				t
					(setq command_not_stopped t)
			)
		)
	)
	(princ)
)

;****************************************************************************************************************************

[Browning Zed]

koMon, спасибо, сэнсэй, всё круто!
И, закрывая тему, подскажите плиз, как будет выглядеть подобный алгоритм для обратной операции - демаскировки Мтекста?

[koMon]

Сообщение от Browning Zed как будет выглядеть подобный алгоритм для обратной операции - демаскировки Мтекста?

похоже, что демаскировку нереально сделать просто удалив/заменив dxf группы примитва. видимо самым нелучшим вариантом будет создание копии мтекста без маски с удалением оригинала.

[skkkk]

Код:

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

(vlax-put (vlax-ename->vla-object (car (entsel))) 'BackgroundFill 0)

[koMon]

[Browning Zed]

Есть вот такой, более изощренный код. Но как я не пробовал играться с функцией mip:entsel ничего не выходит, не получается заставить прогу указывать объект точечно-циклично, только рамкой.

Код:

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

 (defun c:bmoff(/ ss mts vl_mts )
	  (setq ss (ssget '((0 . "MTEXT"))));выбор мтекстов в чертеже
	  (setq mts (ssnamex ss))
	  (setq ss nil)
	  (setq mts (mapcar 'cadr mts));выкидывание номеров набора из списка
	  (setq mts (vl-remove-if-not '(lambda (x) (eq (type x) 'ENAME)) mts))   ;выкидывание способов набора из списка
	 
	  (setq vl_mts (mapcar 'vlax-ename->vla-object mts))
	 
	  (mapcar '(lambda (x) (vla-put-BackgroundFill x :vlax-false)) vl_mts)
)

[koMon]

Изощрённость - это хорошо. А если сделать в одном флаконе?

[Browning Zed]

Любой вариант подошел бы. Главный вопрос - как сделать выбор/подтверждение кликом на объекте, чтобы не рамкой выбирать.

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

Код:

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

 (vl-load-com)
(defun c:bmoff1 (/ ent)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (while (= (type (setq ent (vl-catch-all-apply (function (lambda () (ssget "_+.:S:E:L" '((0 . "MTEXT"))))))))
            'pickset
            ) ;_ end of =
    (vla-put-backgroundfill (vlax-ename->vla-object (ssname ent 0)) :vlax-false)
    ) ;_ end of while
  (princ)
  ) ;_ end of defun
(defun c:bmoff2 (/ ent)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (while (= (type
              (setq ent (vl-catch-all-apply (function (lambda () (car (entsel "\nSelect MTEXT <Cancel> : "))))))
              ) ;_ end of type
            'ename
            ) ;_ end of =
    (if (= (cdr (assoc 0 (entget ent))) "MTEXT")
      (vl-catch-all-apply
        (function (lambda () (vla-put-backgroundfill (vlax-ename->vla-object ent) :vlax-false)))
        ) ;_ end of vl-catch-all-apply
      (princ "\nSelected object is not MTEXT")
      ) ;_ end of if
    ) ;_ end of while
  (princ)
  ) ;_ end of defun

[Browning Zed]

Кулик Алексей aka kpblc, спасибо, работает. Но теперь пропала возможность снятия маски со всех ранее выбранных Мтекстов.
Цель была такая: если до выполнения команды, Мтексты выбраны не были, запускается алгоритм точечного цикла выбора объектов. Но, если, до выполнения команды, ранее был осуществлен выбор Мтекстов программа снимает с них маскировку и завершается.

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

Browning Zed, да бога ради. Пиши свое ветвление, кто запрещает? Все данные у тебя есть
Смотри ключи ssget, анализируй значение pickfirst, и пиши свой код.

[Vladimir_Sergeevich]

Доброго времени...
Вопрос странноватый: есть жуткое желание редактировать IAcadLWPolyline. Есть замечательный метод AddVertex, но одновременно с ним мне надо пересчитать смежные точки... тут только в лоб ковырять свойство Coordinates, которое еще и и хранится как вариант, и править список как мне надо и назад в вариант паковать?
Али есть более элегантное решение?

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

Ты еще забыл про кривизну и возможные переназначения ширины. Так-то создаешь vlax-variant из Double и устанавливаешь свойство Coordinates. А вот с остальным придется ковыряться.
А на фига вообще такое надо?

[Vladimir_Sergeevich]

Сообщение от Кулик Алексей aka kpblc Ты еще забыл про кривизну и возможные переназначения ширины.

Не забыл, в моей задаче такого нет

Сообщение от Кулик Алексей aka kpblc А на фига вообще такое надо?

Все как всегда, свести тыканье мышкой к минимуму. Уже затыкался (создать/сместить два раза/еще раз создать/ снова сместить/ полученное сопряч / лишее зачистить)

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

Так есть же уже "Набор утилит для работы с полилиниями" от VVA - не подходит?

[Vladimir_Sergeevich]

Сообщение от Кулик Алексей aka kpblc Так есть же уже "Набор утилит для работы с полилиниями" от VVA - не подходит?

это который pl-tools?
Если про него речь, то мне тяжеловато его анализировать, что бы выцеплять нужное, а в чистом виде неприменимо.

p.s.
сделал пока так и в общем получается то что хочется

Код:

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

 (defun sad-change-lwPlinePoint (obj par pt / ptLst) ;| редактирование заданной точки в полилинии
args
	* obj - vla-object
	* par - number of Vertex
	* pt - new point (three real)
rez
	* obj - vla-object
|;
	(setq 
		ptLst (vlax-safearray->list (vlax-variant-value (vla-get-Coordinates obj)))
		ptLst (subst (car pt) (nth (fix (* 2 par)) ptLst) ptLst)
		ptLst (subst (cadr pt) (nth (fix (1+ (* 2 par))) ptLst) ptLst)
		ptLst (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length ptLst)))) ptLst))
	)
	(vla-put-Coordinates obj ptLst)
	obj
)

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

[Browning Zed]

Привет. Составил простенький код, который меняет цвет определенных слоев, а также меняет ширину и сглаживание полилиний на этих слоях. И вроде все хорошо, программа работает, но ровно до того момента, как в названии слоя не появляется кириллица. И, если, в названии встретится хотя бы один кириллический символ - код ломается. Что можно придумать в данной ситуации?
UPD. Разобрался, в файле lsp была установлена не та кодировка.

[koMon]

Сообщение от Browning Zed Любой вариант подошел бы.

компилированный вариант aio.

[Browning Zed]

Сообщение от koMon компилированный вариант aio.

Спасибо! Круто придумал.
А нельзя ли еще сделать вариант, где по умолчанию в параметрах будет выставлена маска в цвет экрана, и в выпадающем окошке (где выбираем маскировать или демаскировать текст) добавить опцию "Выход"?

[koMon]

Сообщение от Browning Zed А нельзя ли

можно -> #3876

[Browning Zed]

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

[hroost]

Подскажите плз можно ли простым методом (в одну строку без разбивки на атомы и циклов) вычислить min/max из списка точечных пар вида (X1 Y1 Z1) (X2 Y2 Z2)… (Xn Yn Zn)
Конструкции вида (ниже) не работают
(setq ptLst1_min (apply 'min (ptLst1)));минимальная высота отметок
(setq ptLst1_min (mapcar 'min (ptLst1)));минимальная высота отметок

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

Код:

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

 (setq a '((1 2) (3 5) (6 7) (3 4))
      b '((5 6))
      c '((-5 -7 -15) (20 10 0))
      ) ;_ end of setq

(apply (function mapcar) (cons (function min) (append a b c)))
(apply (function mapcar) (cons (function max) (append a b c)))

----- добавлено через 36 сек. -----
так?

[koMon]

Код:

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

 
(caddar (vl-sort '(( 1 1 3) (2 2 4) (3 3 5)) '(lambda (m1 m2) (< (caddr m1) (caddr m2)))))
(caddar(vl-sort '(( 1 1 3) (2 2 4) (3 3 5)) '(lambda (m1 m2) (> (caddr m1) (caddr m2)))))

[hroost]

Сообщение от Кулик Алексей aka kpblc Код: [Выделить все] (setq a '((1 2) (3 5) (6 7) (3 4)) b '((5 6)) c '((-5 -7 -15) (20 10 0)) ) ;_ end of setq (apply (function mapcar) (cons (function min) (append a b c))) (apply (function mapcar) (cons (function max) (append a b c))) ----- добавлено через 36 сек. ----- так?

Эх, что-то не сработало,

Код:

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

 (setq ptLst1_min(apply (function mapcar) (cons (function min) (append ptLst1))))

Сообщение от koMon Код: [Выделить все] (caddar (vl-sort '(( 1 1 3) (2 2 4) (3 3 5)) '(lambda (m1 m2) (< (caddr m1) (caddr m2))))) (caddar(vl-sort '(( 1 1 3) (2 2 4) (3 3 5)) '(lambda (m1 m2) (> (caddr m1) (caddr m2)))))

А вот здесь есть какой-то результат, но похоже не то.
(setq ptLst1_min (caddar (vl-sort ptLst1 '(lambda (m1 m2) (< (caddr m1) (caddr m2)))))).

Я похоже в своем запросе неверно выразился, min/max это либо минимум/максимум среди всех Х (Х1, Х2...Хn) или У (У1, У2...Уn) или Z (Z1, Z2...Zn) в общем случае. Список точечных пар (ptLst1) содержит координаты полилинии, т.е. цель вычислить min/max точку

[koMon]

min X

Код:

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

 
(apply 'min (mapcar 'car '(( 1 1 3) (2 2 4) (3 3 5) (4 4 10))))

min Y

Код:

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

 
(apply 'min (mapcar 'cadr '(( 1 1 3) (2 2 4) (3 3 5) (4 4 10))))

min Z

Код:

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

 
(apply 'min (mapcar 'caddr '(( 1 1 3) (2 2 4) (3 3 5) (4 4 10))))

точка с мин X

Код:

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

 (car (vl-sort '(( 1 1 3) (2 2 4) (3 3 5)) '(lambda (m1 m2) (< (car m1) (car m2)))))

точка с мин Y

Код:

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

 (car (vl-sort '(( 1 1 3) (2 2 4) (3 3 5)) '(lambda (m1 m2) (< (cadr m1) (cadr m2)))))

точка с мин Z

Код:

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

 (car (vl-sort '(( 1 1 3) (2 2 4) (3 3 5)) '(lambda (m1 m2) (< (caddr m1) (caddr m2)))))

[hroost]

Большое спасибо! Сработало

Код:

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

 (setq ptLst1_Y_min (apply 'min (mapcar 'cadr ptLst1)))

[koMon]

см. выше

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

Сообщение от Кулик Алексей aka kpblc Код: [Выделить все] (setq a '((1 2) (3 5) (6 7) (3 4)) b '((5 6)) c '((-5 -7 -15) (20 10 0)) ) ;_ end of setq (apply (function mapcar) (cons (function min) (append a b c))) (apply (function mapcar) (cons (function max) (append a b c))) ----- добавлено через 36 сек. ----- так?

Код:

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

 (setq lst_mi (apply (function mapcar) (cons (function min) (append a b c)))
         lst_ma (apply (function mapcar) (cons (function max) (append a b c))))
(car lst_mi) ; min X
(cadr lst_mi) ; min Y
(caddr lst_mi) ; min Z

Аналогично с маскимальными значениями.

[mindchamber]

Лисп AreaText. Подскажите что нужно подредактировать чтобы сделать точность до 2х знаков после запятой?
edit: и как можно добавить приписку "м2"?

Код:

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

 ;;; AreaText.LSP ver 3.0
;;; Command name is AT
;;; Select a polyline and where to place the text
;;; Sample result: 2888.89 SQ. FT.
;;; As this is a FIELD it is updated based on the FIELDEVAL
;;; or the settings found in the OPTIONS dialog box

;;; By Jimmy Bergmark
;;; Copyright (C) 2007-2010 JTB World, All Rights Reserved
;;; Website: www.jtbworld.com
;;; E-mail: [email protected]
;;; 2007-09-05 - First release
;;; 2009-08-02 - Updated to work in both modelspace and paperspace
;;; 2010-10-29 - Updated to work also on 64-bit AutoCAD

;;; Uses TEXTSIZE for the text height

(defun Get-ObjectIDx64 (obj / util)
  (setq util (vla-get-Utility (vla-get-activedocument (vlax-get-acad-object))))
  (if (= (type obj) 'ENAME)(setq obj (vlax-ename->vla-object obj)))
  (if (= (type obj) 'VLA-OBJECT)
    (if (> (vl-string-search "x64" (getvar "platform")) 0)
      (vlax-invoke-method util "GetObjectIdString" obj :vlax-False)
      (rtos (vla-get-objectid obj) 2 0)
    )
  )
)

(defun c:AT (/ entObject entObjectID InsertionPoint ad)
  (vl-load-com)
  (setq entObject (vlax-ename->vla-object(car (entsel)))
        entObjectID (Get-ObjectIDx64 entObject)
        InsertionPoint (vlax-3D-Point (getpoint "Select point: "))
        ad (vla-get-ActiveDocument (vlax-get-acad-object))
  )
  (vla-addMText (if (= 1 (vla-get-activespace ad))
    (vla-get-modelspace ad)
    (if (= (vla-get-mspace ad) :vlax-true)
      (vla-get-modelspace ad)
      (vla-get-paperspace ad)
    )
  )
  InsertionPoint 0.0 (strcat
  "%<\\AcObjProp Object(%<\\_ObjId "
  entObjectID
  ">%).Area \\f \"%lu2\">%"
  ))
)

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

Ну сделай руками, а потом посмотри код поля и форматирование, делов-то:

Код:

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

 ;;; AreaText.LSP ver 3.0
;;; Command name is AT
;;; Select a polyline and where to place the text
;;; Sample result: 2888.89 SQ. FT.
;;; As this is a FIELD it is updated based on the FIELDEVAL
;;; or the settings found in the OPTIONS dialog box

;;; By Jimmy Bergmark
;;; Copyright (C) 2007-2010 JTB World, All Rights Reserved
;;; Website: www.jtbworld.com
;;; E-mail: [email protected]
;;; 2007-09-05 - First release
;;; 2009-08-02 - Updated to work in both modelspace and paperspace
;;; 2010-10-29 - Updated to work also on 64-bit AutoCAD

;;; Uses TEXTSIZE for the text height

(defun get-objectidx64 (obj / util)
  (setq util (vla-get-utility (vla-get-activedocument (vlax-get-acad-object))))
  (if (= (type obj) 'ename)
    (setq obj (vlax-ename->vla-object obj))
    ) ;_ end of if
  (if (= (type obj) 'vla-object)
    (if (> (vl-string-search "x64" (getvar "platform")) 0)
      (vlax-invoke-method util "GetObjectIdString" obj :vlax-false)
      (rtos (vla-get-objectid obj) 2 0)
      ) ;_ end of if
    ) ;_ end of if
  ) ;_ end of defun

(defun c:at (/ entobject entobjectid insertionpoint ad)
  (vl-load-com)
  (setq entobject      (vlax-ename->vla-object (car (entsel)))
        entobjectid    (get-objectidx64 entobject)
        insertionpoint (vlax-3d-point (getpoint "Select point: "))
        ad             (vla-get-activedocument (vlax-get-acad-object))
        ) ;_ end of setq
  (vla-addmtext
    (if (= 1 (vla-get-activespace ad))
      (vla-get-modelspace ad)
      (if (= (vla-get-mspace ad) :vlax-true)
        (vla-get-modelspace ad)
        (vla-get-paperspace ad)
        ) ;_ end of if
      ) ;_ end of if
    insertionpoint
    0.0
    (strcat "%<\\AcObjProp Object(%<\\_ObjId " entobjectid ">%).Area \\f \"%lu2%pr2\">%  м{\\H0.7x;\\S2^;}")
    ) ;_ end of vla-addMText
  ) ;_ end of defun

[Nordek]

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

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

Создаешь набор, а потом в него добавляешь entlast. Потом sssetfirst. Не без недостатков подход, конечно, но как вариант...
Ну или (vl-cmdf "_.select" "_last" "")

[Nordek]

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

----- добавлено через ~2 мин. -----
Т.е. на Лиспе нет стандартного "getlast" какого-нибудь? Может в чем то ином можно реализовать?

[doctorraz]

Сообщение от Nordek Т.е. на Лиспе нет стандартного "getlast" какого-нибудь? Может в чем то ином можно реализовать?

как вариант

[ciril]

Сообщение от Nordek готовый рабочий кусок лисп функции, прямо целиком, который выделяет последний созданный в автокаде элемент, например полилинию, прямо выделяет и подсвечивает все ее вершинки и прочее

Код:

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

 (sssetfirst nil (ssadd (entlast)))

[Nordek]

Спасибо всем! Буду попробовать.

[skkkk]

Сообщение от Nordek По второму варианту, делает не выделение, а подсвечивает хайлайт так называемый

Подстветить:

Код:

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

(redraw (entlast) 3)

или

Код:

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

(vla-Highlight (vlax-ename->vla-object (entlast)) :vlax-true)

Снять подсветку:

Код:

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

(redraw (entlast) 4)

или

Код:

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

(vla-Highlight (vlax-ename->vla-object (entlast)) :vlax-false)

[Nordek]

Ciril, кусок рабочий, спасибо, выручил!!

[skkkk]

Не сразу понял, что значит "по второму варианту", подумал, что это задача такая стоит - подсветить. Ну пусть уж тогда будет, рядом с "выделить".

[mr.frai1992]

перенес вопрос в отдельную тему

[dik-son]

Доброго дня.
Подскажите, пож-та, что надо поправить в коде, чтобы пошел на 2020кад?
Это лиспа для трехмерного поворота текста вокруг своей точки. Надо поправить схемы от расчетчика с усилиями в ферме.
Возможно есть другие решения?

Вопрос снят, нашел рабочий лисп

[Browning Zed]

Всем привет! Подскажите, как можно преобразовать строку, в которой содержится ряд цифр в числовое значение? Например, имеется строка "402". Как из нее получить значение 402, чтобы в дальнейшем с ним можно было работать как с числом (например, вставить в формулу).

[AlexSheep]

atoi

[Browning Zed]

А в чем отличие atoi от read заключается?

[SetQ]

Сообщение от Browning Zed А в чем отличие atoi от read заключается?

Если аргумент содержит только

Сообщение от Browning Zed ряд цифр

, то ничем.

[modest-bp]

Здравствуйте!

Подскажите, пожалуйста, какая структура лучше (наверняка у этих вариантов есть какие-то названия, но я их не знаю, поэтому постараюсь обозначить схематично):

Вариант 1 ("главная" функция оборачивает собой определения всех остальных функций):

Код:

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

 (defun funMain ()
    (defun fun2 ())
    (defun fun3 ())
    (fun2)
    (fun3)
)

Вариант 2 ("главная" функция только вызывает другие функции, а определения их даются вне "главной")

Код:

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

 (defun funMain ()
    (fun2)
    (fun3)
)
(defun fun2 ())
(defun fun3 ())

Вариант 3 (Имеется только одна громоздкая функция, внутри которой вшиты все необходимые процедуры)

Код:

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

 (defun fun ()
  .......
      ........
         ........
      .......
    ........
)

Варианты 1-2 и 2-2 (Частные случаи вариантов 1 и 2, когда функции последовательно ссылаются одна - на другую
Так, вариант 1-2 - "матрёшка": определение каждой последующей функции лежит в теле той, которая её вызывает.
Вариант 2-2 - "лесенка": каждая функция вызывает следующую, но определения функций лежат отдельно.

С точки зрения написания самого кода и ориентирования в нём самым удобным вариантом видится 2-й, а самый жуткий - 3-й.
Интуитивно кажется, что если процедуры внутри функции не повторяются, то 3-й вариант должен быть самым быстрым и жрущим минимум ресурсов.

Но есть ли разница между 1, 2 (и 1-2, 2-2) вариантами с точки зрения их обработки (с точки зрения программирования она понятна)?

Куда во 2-м варианте деваются функции, объявленные вне основной после того, как основная будет выполнена? Выгружаются, или остаются висеть в памяти?

Выгружаются ли функции, объявленные внутри "материнской" после выполнения "материнской"? А после полного завершения работы всех процедур?

Как эти варианты соотносятся с точки зрения скорости обработки?

П.С. Что происходит с объявленными функциями и подгруженными переменными при аварийном выходе (ESC или ошибка)?
П.П.С. Существует ли возможность вычистить память от мусора, не закрывая документ?

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

С точки зрения скорости, по-моему, одинаково. Но у тебя неправильно написано:

Код:

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

 ;; Вариант 1
 (defun funMain (/ fun2 fun3)
    (defun fun2 ())
    (defun fun3 ())
    (fun2)
    (fun3)
)

Только в таком случае он будет отличаться от варианта 2.
Вариант 3 подойдет, если локальные функции будут вызываться только один раз.

[Сергей812]

modest-bp,
Имхо, почитайте книгу "САПР на базе AutoCAD - как это делается" - тут даже на форуме выкладывалась в этом году.

Сообщение от modest-bp Выгружаются ли функции, объявленные внутри "материнской" после выполнения "материнской"? А после полного завершения работы всех процедур?

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

[modest-bp]

Сообщение от Кулик Алексей aka kpblc Но у тебя неправильно написано: ;; Вариант 1 (defun funMain (/ fun2 fun3) (defun fun2 ()) (defun fun3 ()) (fun2) (fun3) )

Что-то у меня лыжи не едут...
Функции объявляются как локальные переменные?
А как же "warning: local variable used as function"?

Вот, даже специально повторил этот пример:


Я, наверное, что-то не так понял в этом примере? Потому как у меня "Варианте 1" внутренние функции не объявлялись в локальных переменных "материнской" функции...

Сообщение от Кулик Алексей aka kpblc С точки зрения скорости, по-моему, одинаково

Так что, выходит, можно смело делать, как удобно? Т.е. объявлять функции вне тела основной - это вполне "чистое" и "правильное" решение? А ведь, главное, оно легко читаемое, с таким кодом проще всего обращаться: сделал много "заготовок" - и в новых программах просто обращаешься к ним, а их - выписываешь внизу под кодом основной функции... Удобно же, когда код длинный с большим количеством условий, циклов и т.п...

----- добавлено через ~5 мин. -----

Сообщение от Сергей812 а может выделяться и оставаться занятой - так называемая утечка памяти

Она происходит только при аварийном завершении процедуры, или "течёт" всегда, поскольку подо все объявленные функции выделяется память, которая потом ими же и остаётся занятой?
Вот просто по логике, мне так кажется, если "вложенные" функции объявляются внутри "материнской" (их вызывающей), то при завершении выполнения всех "материнских" процедур они должны бы освободить место.
А в ситуации, когда функции объявляются вне тела вызывающей их функции, мне так кажется, существует высокая вероятность того, что они будут продолжать занимать память и после того, как "материнская" функция своё отработает... Нет?

[Сергей812]

Сообщение от modest-bp Она происходит только при аварийном завершении процедуры, или "течёт" всегда, поскольку подо все объявленные функции выделяется память, которая потом ими же и остаётся занятой?

аварийное завершение процедуры - это когда она упала вместе с программой нафиг). Утечка памяти - это неправильная спроектированная архитектура программы/процедуры/функции - т.е. кривые руки программиста.

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

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

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

Сообщение от modest-bp warning: local variable used as function

Забей. Но только на это сообщение.

----- добавлено через 45 сек. -----

Сообщение от modest-bp когда код длинный с большим количеством условий, циклов и т.п..

Разделяй и властвуй. Последуй совету Сергей812, он дело говорит.

[modest-bp]

Сообщение от Кулик Алексей aka kpblc Разделяй и властвуй

Коротко и ясно. Понял) Спасибо!

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

Лично я лентяй. И если один и тот же код длиной больше 5-10 строк приходится повторять больше чем 1 раз, я из него делаю функцию (локальную или глобальную - это уже другой вопрос). Может, это неправильно, может - нет, не знаю.

[Browning Zed]

Всем привет!
Есть код который подсчитывает количество определенных блоков в чертеже и отображает информацию в командной строке.

Код:

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

 (defun c:BLCT ( / cnt )
  (setq cnt (itoa (sslength (ssget "x" '((0 . "INSERT")(2 . "Мой_блок"))))))
  (princ cnt)
  (princ)
 )

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

[Сергей812]

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

[skkkk]

Dynamic Block Counter не подойдет?

[gnuvse]

Добрый день.

Пожалуйста подскажите несколько моментов:
1. Как программно задать определенный contents для mleader?
2. Можно ли как-то программно сделать mleader, а то AddLeader не очень

[skkkk]

gnuvse, в этом посте есть описание функции draw-mleader. Там и ее содержимое, и ее построение в коде имеется.

[gnuvse]

Здравствуйте.

Пожалуйста накидайте ссылок на хорошие лисп исходники для изучения и понимания
Интересующие темы:
создание таблица и их заполнение
чтение данных из блоков

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

А если в гугле поискать именно по таким словам?

[gnuvse]

Сообщение от Кулик Алексей aka kpblc А если в гугле поискать именно по таким словам?

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

Поэтому, если вам не сложно, то скиньте пару примеров исходников, я думаю мне надолго хватит вникать.

[Сергей812]

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

[DMSskop]

Доброе утро. Есть лисп https://forum.dwg.ru/showpost.php?p=...&postcount=207 нумерует аргументы по зависимостям настроек динамических блоков. Есть аналоги? Или помогите модифицировать для возможности ввода имени атрибута, а то он вшит в лист и приходится копии лиспа делать с разными значениями настроек. Менять название атрибутов в блоках не вариант

[Сергей812]

Сообщение от DMSskop а то он вшит в лист и приходится копии лиспа делать с разными значениями настроек

Введите переменную вместо вшитого значения и задавайте ее значение через GetString. Тем более в коде даже вижу закомментированный кусок нужного кода)

[DMSskop]

Во заработало спасибо

Код:

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

 ;;; Маркировка динамических блоков
;;; Тема Сквозная нумерация динамических блоков
;;; URL http://forum.dwg.ru/showthread.php?t=13666&page=9
;;; Post #207, #163
;;; Натройки программы проихводятся парой строчек ниже СМ
;;;================================================
;;;======== НАСТРОЙКИ ПРОГРАММЫ ===================
;;;================================================
;;;  (setq bname "*") ;_Имя блока 
;;;  (setq dynProp1 "Высота(H) кассеты") ;_Имя динамического свойства1
;;;  (setq dynProp2 "Ширина(B) кассеты") ;_Имя динамического свойства1
;;;  (setq attTo "POS") ;_Имя аттрибута куда вбивать

(defun c:NDB (/       adoc    ss      name    bname   lst     lstLen
              poz     attTo   *error* dynProp1        dynProp2
              dp1     dp2     i dimz
             )
;;; Маркировка динамических блоков
;;; Тема Сквозная нумерация динамических блоков
;;; URL http://forum.dwg.ru/showthread.php?t=13666&page=9
;;; Post #163
  
;;;================================================
;;;======== НАСТРОЙКИ ПРОГРАММЫ ===================
;;;================================================
  (princ "\nNDB - Маркировка динамических блоков. сборка от 2011-12-08")
  (vl-load-com)
;;;  (setq bname "*") ;_Имя блока 
;;;  (setq dynProp1 "Высота(H) кассеты") ;_Имя динамического свойства1
;;;  (setq dynProp2 "Ширина(B) кассеты") ;_Имя динамического свойства1
;;;  (setq bname ( GETSTRING T "\nИмя блока:" ))===Сделай пожалуйста, если не трудно, для набора ЛК несколько разных блоков===
  (setq bname
       ((lambda( / obj name flg str)
          (while (not flg)
            (initget "Имя Удалить")
            (if name
              (setq str (VL-PRINC-TO-STRING name))
              ;;;(setq str (strcat (car name)(apply 'strcat (mapcar '(lambda(x)(strcat "," x))(cdr name)))))
              (setq str "")
              )
            (setq obj (entsel(strcat "\n" str " Выберите блок [Имя/Удалить]<готово>: ")))
            (cond ((and obj (eq obj "Имя"))(setq name (cons (getstring T "\nИмя блока: " ) name)))
                  ((and obj (eq obj "Удалить"))(if (null name)(princ " ** Все удалено **")(setq name (cdr name))))
                  ((and obj (eq (cdr(assoc 0 (entget(setq obj(car obj))))) "INSERT"))
                   (if (not(member(vla-get-EffectiveName(setq obj(vlax-ename->vla-object obj))) name))
                     (setq name (cons (vla-get-EffectiveName obj) name))
                     )
                   )
                  ((and (null obj)(= (getvar "ERRNO") 52))(setq flg t))
                  (t (princ " ** Неверно ** "))
                  )
            )
         (apply 'strcat(mapcar '(lambda(x)(strcat x ",")) name))
          )
         )
      )
  (setq dynProp1 ( GETSTRING T "\nИмя динамического свойства 1:"))
  (setq dynProp2 ( GETSTRING T "\nИмя динамического свойства 2:"))
  (setq attTo ( GETSTRING T "\nИмя Атрибута:"));_Имя аттрибута куда вбивать
  (or (numberp *STARTPOZ*)(setq *STARTPOZ* 1)) ;;; Стартовая нумерация
  
;;; ===================== LOCAL FUNCTION ==========================================
(defun *error* (msg) (princ msg)(setvar "DIMZIN" dimz)(vla-endundomark adoc))
(defun RemoveDuplicateStrings (stringlist / newlist)
  (foreach var stringlist 
    (if (not (vl-position var newlist))
      (setq newlist (cons var newlist))
    )
  )
  (reverse newlist)
)
  (defun mip-conv-to-str (dat)
  (cond ((= (type dat) 'INT) (setq dat (itoa dat)))
        ((= (type dat) 'REAL) (setq dat (rtos dat 2 12)))
        ((null dat) (setq dat ""))
        (t (setq dat (vl-princ-to-string dat)))
  ) ;_ end of cond
) ;_ end of defun
(defun GetDynamicBlockPropertyList (obj)
 (mapcar
    (function
      (lambda ( prop )
        (list (vla-get-propertyname prop) (vlax-get prop 'Value) prop)
      )
    )
    (vlax-invoke obj 'GetDynamicBlockProperties)
  )
)
(defun GetDynamicBlockPropertyNameValue ( obj PropertyName / Plist)
  (and
  (setq PropertyName (strcase PropertyName))
  (setq Plist (GetDynamicBlockPropertyList obj))
  (setq Plist (car(vl-remove-if-not '(lambda (x)
                                   (= (strcase (car x)) PropertyName))
                Plist
                ))
        )
  )
   (cadr Plist)
  )
(defun mip-block-setattr-bylist (obj att_list / txt lst)
  (if (= (type obj) 'ENAME)
    (setq obj (vlax-ename->vla-object obj))
  ) ;_ end of if
  (setq att_list (mapcar '(lambda (x)
                            (cons (strcase (mip-conv-to-str (car x)))
                                  (mip-conv-to-str (cdr x))
                            ) ;_ end of cons
                          ) ;_ end of lambda
                         att_list
                 ) ;_ end of mapcar
  ) ;_ end of setq
  (if (and obj
           (not (vlax-erased-p obj))
           (= (vla-get-objectname obj) "AcDbBlockReference")
           (eq :vlax-true (vla-get-hasattributes obj))
           (vlax-property-available-p obj 'Hasattributes)
           (vlax-write-enabled-p obj)
      ) ;_ end of and
    (vl-catch-all-apply
      (function
        (lambda ()
          (foreach at (vlax-invoke obj 'Getattributes)
            (if (setq
                  lst (assoc (strcase (vla-get-tagstring at)) att_list)
                ) ;_ end of setq
              (vla-put-textstring at (cdr lst))
            ) ;_ end of if
          ) ;_ end of foreach
        ) ;_ end of lambda
      ) ;_ end of function
    ) ;_ end of vl-catch-all-apply
  ) ;_ end of if
) ;_ end of defun
(defun round (value to)
;;; Doug Broad
;;; additional credits Joe Burke, Peter Toby
  (setq to (abs to))
  (* to
     (fix (/ ((if (minusp value)
                -
                +
              ) ;_ end of if
               value
               (* to 0.5)
             )
             to
          ) ;_ end of /
     ) ;_ end of fix
  ) ;_ end of *
) ;_ end of defun  
(defun get-all-atts (obj)
  (if (and obj
           (eq :vlax-true (vla-get-hasattributes obj))
           (vlax-property-available-p obj 'Hasattributes)

      ) ;_ end of and
    (vl-catch-all-apply
      (function
        (lambda ()
          (mapcar (function (lambda (x)
                              (cons (vla-get-tagstring x)
                                    (vla-get-textstring x)
                              ) ;_ end of cons
                            ) ;_ end of lambda
                  ) ;_ end of function
                  (append (vlax-invoke obj 'Getattributes)
                          (vlax-invoke obj 'Getconstantattributes)
                  ) ;_ end of append
          ) ;_ end of mapcar
        ) ;_ end of lambda
      ) ;_ end of function
    ) ;_ end of vl-catch-all-apply
  ) ;_ end of if
) ;_ end of defun  
(defun SortStringWithNumberAsNumber (ListOfString IgnoreCase / NorStrs count)
;;;Function Normalize (add 0 befor number) number in string
;;; Count normalize symbols set in variable count
;;; CAB added count as an argument
  ;;;http://www.theswamp.org/index.php?topic=16564.msg207439;topicseen#msg207439
  ;;; http://www.theswamp.org/index.php?topic=6474.0
  (defun NormalizeNumberInString (str count / ch i pat ret buf)
    (setq i   0
          pat '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9")
          ret ""
    ) ;_ end of setq
    (while (/= (setq ch (substr str (setq i (1+ i)) 1)) "")
      (if (vl-position ch pat)
        (progn
          (setq buf ch) ;_ end of setq
          (while
            (vl-position (setq ch (substr str (setq i (1+ i)) 1)) pat)
             (setq buf (strcat buf ch))
          ) ;_ end of while
          (while (< (strlen buf) count) (setq buf (strcat "0" buf)))
          (setq ret (strcat ret buf))
        ) ;_ end of progn
      ) ;_ end of if
      (setq ret (strcat ret ch))
    ) ;_ end of while
    ret
  ) ;_ end of defun
  ;;-------------------------------------------------
  ;;  function to Count the longest number in string 
  ;;  CAB added to get the correct COUNT
  (defun getcount (lst / count pat)
    (setq count 0)
    (setq pat '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))
    (mapcar
      '(lambda (str / i maxlen ch)
         (setq i 0 maxlen 0)
         (while (/= (setq ch (substr str (setq i (1+ i)) 1)) "")
           (if (vl-position ch pat) ; number
             (setq maxlen (1+ maxlen))
             (setq count  (max count maxlen) maxlen 0)
           )
         )
	 (setq count  (max count maxlen)) ;_<<< ADD 21.06.2007 by 
       )
      Lst
    )
    count
  )
  ;;===============================================
  (setq count   (GetCount ListOfString)
        NorStrs (mapcar '(lambda (x) (NormalizeNumberInString x count))
                        ListOfString)
  )
  (and IgnoreCase (setq NorStrs (mapcar 'strcase NorStrs)))
  (mapcar '(lambda (x) (nth x ListOfString)) (vl-sort-i NorStrs '<))
)
  ;;; ===================== LOCAL FUNCTION ==========================================

  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
;;;============================================================= 
;;;====================== MAIN PART ============================ 
;;;============================================================= 
  (vla-startundomark adoc)
  (setq dimz (getvar "DIMZIN"))
  (setvar "DIMZIN" 0)
  (setq *PREF* (mip-conv-to-str *PREF*))
  (setq *SUFF* (mip-conv-to-str *SUFF*))
  (princ "\nВведите префикс или Пробел - нет <")
  (princ *PREF*)(princ ">: ")(setq poz (getstring t))
  (if (/= poz "")(setq *PREF* poz))
  (if (= poz " ")(setq *PREF* ""))
  (princ "\nВведите суффикс или Пробел - нет <")
  (princ *SUFF*)(princ ">: ")(setq poz (getstring t))
  (if (/= poz "")(setq *SUFF* poz))
  (if (= *SUFF* " ")(setq *SUFF* ""))
  (princ "\nКратность (5 - кратно 5; 0.5 - кратно 0.5) или 0 - нет <")
  (if (numberp *ROUND*)(princ *ROUND*)(princ "НЕТ"))
  (princ ">: ")(initget 4)
  (if (null (setq poz (getdist)))
    (setq poz (if (numberp *ROUND*) *ROUND*  0))
  ) ;_ end of if
  (if (zerop poz)(setq *ROUND* nil)(setq *ROUND* poz)) ;_ end of if
  (princ "\nНачальный номер <")(princ *STARTPOZ*)(princ ">: ")
  (if (null(setq i (getint)))(setq i *STARTPOZ*)(setq *STARTPOZ* i))
  (if (and (setq ss (ssget '((0 . "INSERT") (66 . 1))))
           (princ "\nЭтап 1. Построение списка блоков.")
           (setq lstLen (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
      ) ;_ end of and
    (progn
      (princ "\nЭтап 2. Анализ блоков.")
      (setq i      0
            lstLen (mapcar 'vlax-ename->vla-object lstlen)
      ) ;_ end of setq
      (foreach blk lstLen
        (setq name (cond
                     ((and (vlax-property-available-p blk 'isdynamicblock)
                           (= (vla-get-isdynamicblock blk) :vlax-true)
                      ) ;_ end of and 
                      (vla-get-effectivename blk)
                     )
                     (t (vla-get-name blk))
                   ) ;_ end of cond
              i    (1+ i)
        ) ;_ end of setq 
        (if
          (and (wcmatch (strcase name) (strcase bname))
               (setq dp1 (GetDynamicBlockPropertyNameValue blk dynProp1))
               (setq dp2 (GetDynamicBlockPropertyNameValue blk dynProp2))
          ) ;_ end of and
           (progn
             (if (numberp *ROUND*)
                 (setq dp1 (round dp1 *ROUND*)
                       dp2 (round dp2 *ROUND*)
                       )
             ) ;_ end of if
             (setq lst
                    (cons (strcat (rtos dp1 2 9) ":" (rtos dp2 2 9)) lst)
             ) ;_ end of setq
           ) ;_ end of progn
        ) ;_ end of if
 ;_ end of if 
      ) ;_ end of foreach
      (princ "... Обработано ")(princ i)(princ " блоков")
      (princ "\nЭтап 3. Построение списка из уникальных значений.")
      (setq lst (SORTSTRINGWITHNUMBERASNUMBER (RemoveDuplicateStrings lst) nil))
      (princ "\nЭтап 4. Обновление атрибутов блоков.")
      (setq i 0)
      (foreach blk lstLen
        (setq name (cond
                     ((and (vlax-property-available-p blk 'isdynamicblock)
                           (= (vla-get-isdynamicblock blk) :vlax-true)
                      ) ;_ end of and 
                      (vla-get-effectivename blk)
                     )
                     (t (vla-get-name blk))
                   ) ;_ end of cond
              i    (1+ i)
        ) ;_ end of setq 
        (if
          (and (wcmatch (strcase name) (strcase bname))
               (setq dp1 (GetDynamicBlockPropertyNameValue blk dynProp1))
               (setq dp2 (GetDynamicBlockPropertyNameValue blk dynProp2))
               (if (numberp *ROUND*)
                 (setq dp1 (round dp1 *ROUND*)
                       dp2 (round dp2 *ROUND*)
                 ) ;_ end of setq
                 t
               ) ;_ end of if
               (setq poz (vl-position
                           (strcat (rtos dp1 2 9) ":" (rtos dp2 2 9))
                           lst
                         ) ;_ end of vl-position
               ) ;_ end of setq
          ) ;_ end of and
           (progn
             (mip-block-setattr-bylist
               blk
               (list (cons (strcase attTo)
                           (strcat *PREF* (itoa (+ *STARTPOZ* poz)) *SUFF*)
                     ) ;_ end of cons
               ) ;_ end of list
             ) ;_ end of mip-block-setattr-bylist
           ) ;_ end of progn
        ) ;_ end of if
 ;_ end of if 
      ) ;_ end of foreach
      (setq *STARTPOZ* (+ *STARTPOZ* (length lst)))
      (princ "... Обновлено ")(princ i)(princ " атрибутов в блоках \n")
      (vla-regen adoc acactiveviewport)
    ) ;_ end of progn 
  ) ;_ end of if
  (setvar "DIMZIN" dimz)
  (vla-endundomark adoc)(princ)
) ;_ end of defun

[gnuvse]

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

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

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

[Сергей812]

Сообщение от gnuvse Если у вас есть примеры любого документированного кода или вы знаете ссылки на него - поделитесь пожалуйста.

на лиспе не пишу, а когда выкладывал примеры на .Net - комментариев у меня там было прилично) Есть официальный сайт разработчиков Аутодеска, есть сайт Алексея, есть справка от разработчика, есть сайт от Lee Mac и т.д.

Сообщение от gnuvse Перелопачивать информацию я готов, просто хочу перелопачивать сразу верное решение, таким образом эффект от обучения будет выше. А написать плохо всегда можно.

эффект от обучения как раз - когда на грабли наступаешь. Только потом не бросаешься на них снова и снова, пытаясь подобрать работающий кусок кода вслепую - а начинаешь читать справку и форумы.

[megabeton]

Как сформировать набор всех примитивов чертежа, включая примитивы, входящие в блоки?

[skkkk]

А точно именно набор нужен (selection set)? Или список entity_name'ов? Или список vla-объктов?

[megabeton]

Мне через (ssget ???) как нибудь надо.
Просто (ssget "_A") включает все примитивы, но без внутренностей блока, только сами блоки.

----- добавлено через ~2 мин. -----
Или это надо сначала список всех блоков получить, потом из каждого блока вытащить примитивы?

----- добавлено через ~4 мин. -----
именно набор нужен (selection set)

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

Проходишь по коллекции всех блоков и забираешь все примитивы. При необходимости можно исключать внешние ссылки - или наоборот, забирать и оттуда все.

[megabeton]

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

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

Штатной функции я не знаю. А решение я тебе уже подсказал. Реализация за тобой

[megabeton]

Где ошибка, подскажите
Хочу набор примитивов из внутренностей блоков создать
"; ошибка: ActiveX Server возвратил ошибку: неизвестное имя: EffectiveName"

Код:

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

   (setq ssb (ssget))
	(setq index -1)
	(repeat 
		(sslength ssb)
		(setq	index	(1+ index) 
				ento		(ssname ssb index))
		(setq ent (vlax-ename->vla-object ento))
		;;; Получить vla-указатель на описание блока
		(setq block_def	(vla-item (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))) (vla-get-effectivename ent))
		)
		;;; Получить список всех примитивов, входящих в блок
		(setq block_cont	(
								(lambda	(/ res)
										(vlax-for sub block_def (setq res (cons sub res)))
										(reverse res)
								)
							)
		)
	)

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

[Сергей812]

действительно, зачем проверять наличие данного свойства)

Код:

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

 vlax-property-available-p blk 'effectivename

[megabeton]

Ну хорошо, вместо

Код:

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

 (setq	index	(1+ index) 
				ento		(ssname ssb index))
		(setq ent (vlax-ename->vla-object ento))

сделал

Код:

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

 (setq	index	(1+ index) 
				ento		(ssname ssb index))
		(setq ent (vlax-ename->vla-object (cadar ento)))

Теперь говорит
; ошибка: неверный тип аргумента: <Имя объекта: 7ff4119e6da0>

Т.е. ssname возвращает <Имя объекта: 7ff4119e6da0>
Для vlax-ename->vla-object тоже даю <Имя объекта: 7ff4119e6da0> при помощи (cadar ento)

Теперь где ошибаюсь?

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

Без проверок (виртуалку с ACAD'ом запускать долго):

Код:

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

 (defun _kpblc-get-ent-name (ent /)
                           ;|
*    Получение свойства name указанного примитива
*    Параметры вызова:
  ent  указатель на обрабатываемый примитив
    допускаются значения
    ename
    vla-object
|;
  (cond ((= (type ent) 'str) ent)
	      ((= (type ent) 'ename) (_kpblc-get-ent-name (vlax-ename->vla-object ent)))
	      ((vlax-property-available ent 'effectivename)
				(vla-get-effectivename ent)
				)
				((vlax-property-available ent 'name)
				(vla-get-name ent)
				)
        ((_kpblc-property-get ent 'effectivename))
        ((_kpblc-property-get ent 'name))
        ) ;_ end of cond
  ) ;_ end of defun

[koMon]

Сообщение от megabeton будьте людьми, научите извлекать примитивы из блоков без ActiveX

Код:

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

 (setq block_inspected (vlax-ename->vla-object (car (entsel "\nВыберите блок:"))))
(setq starting_entity (tblobjname "block" (vla-get-effectivename block_inspected))
      block_entities_list '()
)
(while (setq next_entity (entnext starting_entity))
	(setq block_entities_list (cons next_entity block_entities_list)
	      starting_entity next_entity
    )
)
(foreach block_entity block_entities_list (print (entget block_entity)))

[megabeton]

Как создать примитив внутри блока?
* без (command "_bedit" nameblk)

[koMon]

add* методы добавляют примитивы в блоки и пространства

[megabeton]

эмм...)) Без ActiveX возможно ?

Хотя наверно ладно, проще эту главу все же изучить

[koMon]

без activex вряд ли(

[megabeton]

Тогда сразу вопрос - а как указать на пространство блока?
??? vla-get-ModelBLOCK ??? (vla-get-ModelSpace (vla-get-activedocument (vlax-get-acad-object)))
Совсем чайник пока в Активексе, дайте наводку.

[koMon]

это просто указатель на не/именованный блок из коллекции блоков

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

http://www.cad.dp.ua/stats/vla_doc.php

[megabeton]

Добавить точку (линию, текст и пр.) в пространство модели - просто.
(vla-addPOINT (vla-get-ModelSpace (vla-get-activedocument (vlax-get-acad-object))) (vlax-3D-point '(0. 0. 0.)))
Применяем метод и передаем соответствующие аргументы.

Добавить точку в блок пока не получается.
(vla-addPOINT (vla-get-Blocks (vla-get-activedocument (vlax-get-acad-object)) (vlax-ename->vla-object (car (entsel)))) (vlax-3D-point '(0. 0. 0.)))
ошибка: Слишком много фактических параметров

По логике дилетанта рассуждаю следующим образом.
Использую метод vla-addPOINT, указываю на блок (делаю запрос свойства vla-get-Blocks с аргументом объект, т.е. конкретный блок) в пространстве модели/документа/объекта и передаю аргумент "координаты точки". Где ошибка?

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

Код:

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

 (vla-addpoint (vla-item (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))
                        (vla-get-effectivename (vlax-ename->vla-object (car (entsel))))
              ) ;_ end of vla-item
              (vlax-3d-point '(0. 0. 0.))
) ;_ end of vla-addpoint

[proel]

... прошу удалить мой вопрос как уже не актуальный.

[Browning Zed]

Господа, подскажите, как из ssget получить набор, к которому можно обращаться через vla-функции? Например, получаем набор выбора:

Код:

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

 (setq ss   (ssget '((0 . "LWPOLYLINE"))))

Далее, преобразуем его, и записываем в переменную X, чтобы после появилась возможность изменять свойства объектов:

Код:

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

 (vla-put-color X 1)
 (vla-put-linetype X "Continuous")

и т.д.

[skkkk]

Код:

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

 (setq ss (ssget '((0 . "LWPOLYLINE"))))
(if ss
	(repeat (setq i (sslength ss))
		(setq X (vlax-ename->vla-object (ssname ss (setq i (1- i)))))
		(vla-put-color X 1)
		(vla-put-linetype X "Continuous")
	)
)

[Browning Zed]

Спасибо.

----- добавлено через ~11 ч. -----
Как присвоить объектам RGB цвет через vla?

Код:

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

 (setq ss (ssget '((0 . "LWPOLYLINE"))))
(if ss
	(repeat (setq i (sslength ss))
		(setq X (vlax-ename->vla-object (ssname ss (setq i (1- i)))))
		(vla-put-truecolor X (list '(255 255 255))); белый цвет
	)
)

Вместо (list '(255 255 255)), насколько я понимаю, нужно сослаться на какой-то объект, имеющий соответствующий цвет. Но как это сделать?

[Сет]

Подскажите, как нарисовать простую полилинию по двум вершинам?
Пробую вот такой код:

Код:

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

 
(setq pt1 (list 1 1))
(setq pt2 (list 2 2))
(vla-AddPolyline model_space (vlax-safearray-fill 
    (vlax-make-safearray vlax-vbDouble '(0 . 1))
    (append pt1 pt2)))

Здесь model_space - указатель на пространство модели.
В итоге получаю ошибку:

сбой функции vlax-safearray-fill. Неверный список инициализации. #<safearray...>

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

Код:

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

 (setq *model* (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
(setq p1 (list 1. 1.))
(setq p2 (list 2. 2.))
(vla-addlightweightpolyline *model*
                            (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbdouble '(0 . 3)) (append p1 p2))
                            ) ;_ end of vlax-make-variant
) ;_ end of vla-AddLightWeightPolyline

[Сет]

Кулик Алексей aka kpblc, а почему в функции vlax-make-safearray указана точечная пара (0 . 3), а не (0 . 1), как у меня? Я так понимаю, это значения индексов первого и последнего элементов массива. Если всего этих элементов два (две точки-вершины полилинии), то зачем мне массив на 4 элемента, который создается с помощью точечной пары (0 . 3)? Или координаты двухмерной точки в массиве занимают две позиции?

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

Потому что вершин 2, у каждой по 2 координаты. Итого 4 элемента. От 0 до 3.

----- добавлено через 13 сек. -----
И не забудь преобразовать savearray в variant.

[koMon]

Сообщение от Кулик Алексей aka kpblc И не забудь преобразовать savearray в variant.

это точно будет лишнее.

----- добавлено через ~4 мин. -----

Сообщение от Сет а почему в функции vlax-make-safearray указана точечная пара (0 . 3), а не (0 . 1), как у меня?

определяется одномерный массив на 4 члена (первый член будет иметь индекс в массиве 0, последний 3), в который затем загоняются поочерёдно координаты X, Y вершин полилинии. 2 вершины 4 члена, 3 - 6, ....

----- добавлено через ~10 мин. -----

Сообщение от Browning Zed Как присвоить объектам RGB цвет через vla?

если назначать цвет, использую ActiveX, то и выбор объектов лучше имхо делать на нём же и быстрее работать будет и проще к объектам выборки обращаться. например назначить всем выбранным полилиниям цвет R255G255B255 можно так.

Код:

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

 
(setq filter_list '((0 . "LWPOLYLINE"))
	  group_code_array (vlax-make-safearray vlax-vbinteger (cons 0 (1- (length filter_list))))
	  group_value_array (vlax-make-safearray vlax-vbvariant (cons 0 (1- (length filter_list))))
	  array_index 0
	  color_object (vlax-create-object (strcat "AutoCAD.AcCmColor." (substr (getvar "ACADVER") 1 2)))
)
(vla-setrgb color_object 255 255 255)		;устанавлbваем RGB цвет для назначения его выбранным полилиниям
(if (null (vl-catch-all-error-p (vl-catch-all-apply 'vla-item (list (vla-get-selectionsets (vla-get-activedocument (vlax-get-acad-object))) "Pline_Collection"))))
		(vla-delete (vla-item (vla-get-selectionsets (vla-get-activedocument (vlax-get-acad-object))) "Pline_Collection"))
)
(repeat (length filter_list)
	(vlax-safearray-put-element group_code_array array_index (car (nth array_index filter_list)))
	(vlax-safearray-put-element group_value_array array_index (cdr (nth array_index filter_list)))
	(setq array_index (1+ array_index))
)
(setq pline_collection (vla-add (vla-get-selectionsets (vla-get-activedocument (vlax-get-acad-object))) "Pline_Collection"))
(vla-selectonscreen pline_collection group_code_array group_value_array)
(vlax-for every_pline pline_collection
	(vla-put-colormethod (vla-get-truecolor every_pline) acColorMethodByRGB)
	(vla-put-truecolor every_pline color_object)
)
(vla-delete (vla-item (vla-get-selectionsets (vla-get-activedocument (vlax-get-acad-object))) "Pline_Collection"))
(princ)

[Сет]

Есть такая задача. Пользователь последовательно указывает три точки. При этом две первые точки задают прямую, а третья точка чаще всего не лежит на ней. Задача состоит в том, чтобы найти координаты точки p3', которая будет находиться на прямой, заданной точками p1 и p2 и максимально близко от точки p3. Есть простой, но трудоемкий способ через лобовые геометрические вычисления. Но может быть у лиспа есть функционал, который позволяет решить эту задачу проще? Или может кто-то для себя писал такую функцию под свои нужды?

[Browning Zed]

----- добавлено через 44 сек. -----

Сообщение от koMon цвет R255G255B255 можно так

Спасибо большое! В очередной раз выручил, сенсей.

[koMon]

Сообщение от Сет Есть такая задача.

если построить, например, вспомогательный отрезок, то искомая точка может быть найдена при помощи функции (VLAX-CURVE-GETCLOSESTPOINTTO).
хотя можно и используя (inters)

Код:

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

 (setq pt1 (getpoint "\n1-я точка: ")
	  pt2 (getpoint "\n2-я точка: ")
	  pt3 (getpoint "\n3-я точка: ")
	  pt3_12 (print (inters pt1 pt2 pt3 (polar pt3 (+ (* 0.5 pi) (angle pt1 pt2)) 5.0) nil))
)

[Сет]

Сообщение от koMon если построить, например, вспомогательный отрезок, то искомая точка может быть найдена при помощи функции (VLAX-CURVE-GETCLOSESTPOINTTO). хотя можно и используя (inters)

А можно ли в моем примере получить еще две точки, лежащий на прямой p1-p2, на определенном расстоянии от точек p1 и p2 снаружи отрезка p1-p2? На картинке точки помечены красным. При этом нужно учитывать, что пользователь может задать точки в обратном порядке, то есть задать направление сверху вниз влево, а не снизу вверх вправо, как у меня на картинке.

[Сет]

Сообщение от Сет А можно ли в моем примере получить еще две точки, лежащий на прямой p1-p2, на определенном расстоянии от точек p1 и p2 снаружи отрезка p1-p2?

Разобрался. С помощью функции polar.

[Browning Zed]

Как можно присвоить свойства полилинии, сразу после ее создания (оба действия в одной команде)? Пробовал такой вариант, но он не рабочий:

Код:

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

 (defun c:test ()
	(command "_PLINE" pause)
	(vla-put-linetypescale (vlax-ename->vla-object (entlast)) 0.5)
)

[Сергей812]

добавьте princ в конце

Код:

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

 (defun c:test () 
     (command "_PLINE" pause) 
     (vla-put-linetypescale (vlax-ename->vla-object (entlast)) 0.5)
     (princ "Упсс")
 ) 

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

[Browning Zed]

Сообщение от Сергей812 добавьте princ в конце Код: [Выделить все] (defun c:test () (command "_PLINE" pause) (vla-put-linetypescale (vlax-ename->vla-object (entlast)) 0.5) (princ "Упсс") ) и увидите, что пытаетесь применить свойства к еще не созданной окончательно полилинии - издержки командных методов. Насколько помню, в свое время это решил на реакторах - отлавливаете начало команды рисования полилинии, если команда была успешно завершена - делаете с ней (полилинией) что надо. Либо эмулируйте рисование полилинии)

Спасибо, уже разобрался. Все оказалось проще. После ввода команды, требующей пользовательского ввода, нужно добавить цикл:

Код:

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

 (while (> (getvar 'cmdactive) 0) (command pause))

Тогда работает как нужно.

[Сергей812]

тоже вариант, только cmdactive битовый флаг

Код:

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

 (while (= (logand (getvar 'cmdactive) 1) 1) (command pause))

[Browning Zed]

Господа, подскажите как вставить извлеченный элемент одного списка в другой список.

Код:

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

 (defun c:list ( / L1 L2 )
	(setq L1 '(B C))
	(setq L2 '(A (car L1)(cadr L1) D))
	(princ L2)
)

Команда list вернет
(A (CAR L1) (CADR L1) D)
Что сделать чтобы получить вместо этого:
(A B C D)

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

(setq l2 (list a (car l1) (cadr l1) d))

----- добавлено через 28 сек. -----
Между прочим, команда _.list - штатная команда AutoCAD. Советую выбрать другое название

[Browning Zed]

Спасибо, Алексей! Не подскажете еще как вставить один список в другой в качестве sublist?
Например, имеем два списка:
'(A B)
'(C D)
что нужно сделать, чтобы получить:
'(A B (C D))
или
'((C D) A B)

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

Советую поэкспериментировать с cons / append. Ну и list туда же.
Хотя зачем получать слабоструктурированный или вообще неструктурированный список - для меня тайна.

----- добавлено через ~4 мин. -----

Код:

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

 (setq a    1
      b    2
      c    3
      d    4
      lst1 (list a b)
      lst2 (list c d)
) ;_ end of setq
(cons lst1 lst2) ; '((1 2) 3 4)
(append lst1 (list lst2)) ; '(1 2 (3 4))

[Сет]

Подскажите, как в LISP обрабатываются ошибки? Например есть такой код:

Код:

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

 (setq file (open "C:\\test.txt" "r"))
; какие-то действия
(close file)

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

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

Код:

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

  (setq file (open "C:\\test.txt" "r"))
(vl-catch-all-apply (function (lambda()
; какие-то действия
)))
(close file)

----- добавлено через 24 сек. -----
А вообще говоря, проще сначала прочитать файл, закрыть - и только потом выполнять какие-либо действия с полученными данными.

[Сет]

Кулик Алексей aka kpblc, а где в этой конструкции вписывается инструкция по закрытию файла при ошибке?

----- добавлено через ~32 мин. -----
А, похоже понял vl-catch-all-apply ловит ошибку, программа при этом продолжает работу и доходит до функции close?

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

Сообщение от Сет А, похоже понял vl-catch-all-apply ловит ошибку, программа при этом продолжает работу и доходит до функции close?

Именно.

[Сет]

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

Вот как работал лисп. В чертеже есть набор блоков с атрибутами, которые (блоки) в своем имени содержат текст "спецстр" (есть два варианта блоков с именами "спецстр" и "спецстризд") и каждый блок содержит атрибуты "КОЛ" и "МАССА". Активируя лисп я выбирал нужные мне экземпляры блоков (по сути это строки спецификации) и программа автоматически перемножала по каждой строке значения в атрибутах "КОЛ" и "МАССА", выдавая в итоге сумму по всем строкам.

Сейчас я изменил структуру блоков, представляющих собой строки спецификации, но в них по прежнему остались атрибуты "КОЛ" и "МАССА", только теперь они занимают другую относительную позицию в списке атрибутов блока. Если раньше у них были позиции 4 и 5, то теперь 7 и 8. Я смотрю сам лисп и не вижу, чтобы их относительная позиция в перечне атрибутов как-то учитывалась. Как я понимаю лисп находил нужные данные по имени атрибута. Или все ж нет? Вот исходный лисп:

Код:

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

 (defun c:calculate_weight (/ ss res)
 (if (= (type (setq ss (vl-catch-all-apply (function (lambda () (ssget '((2 . "спецстр*") (66 . 1))))))))
        'pickset
        ) ;_ end of =
   (progn (setq
            res (apply (function +)
                       (vl-remove nil
                                  (mapcar (function
                                            (lambda (x)
                                              (if (and (setq x (vlax-ename->vla-object x))
                                                       (setq x (vlax-safearray->list (vlax-variant-value (vla-getattributes x))))
                                                       (setq x (mapcar (function (lambda (a) (cons (vla-get-tagstring a) (vla-get-textstring a)))) x))
                                                       (setq x (apply (function *)
                                                                      (mapcar (function (lambda (a)
                                                                                          (cond ((setq a (cdr (assoc a x))) (atof (vl-string-translate "," "." a)))
                                                                                                (t 0)
                                                                                                ) ;_ end of cond
                                                                                          ) ;_ end of lambda
                                                                                        ) ;_ end of function
                                                                              '("КОЛ" "МАССА")
                                                                              ) ;_ end of mapcar
                                                                      ) ;_ end of apply
                                                             ) ;_ end of setq
                                                       ) ;_ end of and
                                                x
                                                ) ;_ end of if
                                              ) ;_ end of lambda
                                            ) ;_ end of function
                                          ((lambda (/ tab item)
                                             (repeat (setq tab  nil
                                                           item (sslength ss)
                                                           ) ;_ end setq
                                               (setq tab (cons (ssname ss (setq item (1- item))) tab))
                                               ) ;_ end of repeat
                                             ) ;_ end of lambda
                                           )
                                          ) ;_ end of mapcar
                                  ) ;_ end of vl-remove
                       ) ;_ end of apply
            ) ;_ end of setq
          (princ (strcat "Общая масса: " (rtos res 2)))
          (alert (strcat "Общая масса: " (rtos res 2)))
          (princ)
          ) ;_ end of progn
   ) ;_ end of if
 ) ;_ end of defun

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

Блоки случайно не стали динамическими?

[Сет]

Сообщение от Кулик Алексей aka kpblc Блоки случайно не стали динамическими?

Нет, в блоках раньше было порядка 20 атрибутов, после переделки их чуть больше стало, кое-каким атрибутам дал новые имена, изменил их порядок, но остались два атрибута "КОЛ" и "МАССА". Результат работы лиспа - сообщение "Общая масса: 0,00".

[Сет]

Во вложении файл с блоками "СпецСтр2" и "СпецСтрИзд2", а также с двумя экземплярами блока "СпецСтр2" - вот по ним общую массу лисп выдает 0,00.

[kacugu]

Сообщение от Сет но в них по прежнему остались атрибуты "КОЛ" и "МАССА"

Не "КОЛ" и "МАССА", а "6-КОЛ" и "7-МАССА". Если в строке 20 заменить

Код:

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

  '("КОЛ" "МАССА") 

на

Код:

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

 '("6-КОЛ" "7-МАССА")

то лисп работает нормально.

[Сет]

Сообщение от kacugu Не "КОЛ" и "МАССА", а "6-КОЛ" и "7-МАССА".

Точно! Вот я невнимательный

[rusv]

Принимайте в свои ряды.
Только познаю азы LISPa

А может разбирали похожий пример.
Нужно выбрать объекты (текст) в чертеже, в тексте найти цифры, а далее выполнить конвертацию этих цифр с округлением. Например, имею текст "Высота 1000м", а хочу результат "Высота 1000м/3381' ". Таких объектов может быть несколько в чертеже с разными словами. Думал сделать чтобы сразу с группой можно было работать, т.е в начале эти объекты "натыкать". Заранее спасибо всем откликнувшимся.

[skkkk]

rusv, я ничего не понял. Почему 3381? Что значит "конвертацию цифр с округлением"? Как понять это "сразу с группой работать" и " в начале "натыкать"?
Нужно бы файл с примером приложить, где будет видно, что есть и как надо.

[kacugu]

Offtop:

Сообщение от skkkk Почему 3381?

В римские футы, судя по всему...

[Vladimir_Sergeevich]

Сообщение от rusv Принимайте в свои ряды. Только познаю азы LISPa А может разбирали похожий пример. Нужно выбрать объекты (текст) в чертеже, в тексте найти цифры, а далее выполнить конвертацию этих цифр с округлением. Например, имею текст "Высота 1000м", а хочу результат "Высота 1000м/3381' ". Таких объектов может быть несколько в чертеже с разными словами. Думал сделать чтобы сразу с группой можно было работать, т.е в начале эти объекты "натыкать". Заранее спасибо всем откликнувшимся.

Задача поставлена эпическая.
поделюсь опытом:

Код:

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

 (defun c:round-i-len ( / )
	(defun round-in-str (s) (rtos (atof (vl-string-subst "." "," s)) 2 0 )) ;;return string
	(vla-startUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
	(vlax-for txt (sad-get-ss '((0 "TEXT") ))
		(if (wcmatch (vla-get-TextString txt) "*+*")
			(vla-put-TextString 
				txt 
				((lambda (str)
					(setq str (_dwgru-string-to-list str "+")
					str (strcat (car str) "+" (round-in-str (cadr str)))	)
				) (vla-get-TextString txt))
			)
			(vla-put-TextString 
				txt
				(round-in-str (vla-get-TextString txt))
			)
		)
	)	
	(vla-endUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
	(princ)	
)
(defun c:round-i-len2 ( / )
	(defun round-in-str (s) (vl-princ-to-string (atof (vl-string-subst "." "," s)))) ;;return string
	(vla-startUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
	(vlax-for txt (sad-get-ss '((0 "TEXT") ))
		(if (wcmatch (vla-get-TextString txt) "*+*")
			(vla-put-TextString 
				txt 
				((lambda (str)
					(setq str (_dwgru-string-to-list str "+")
					str (strcat (car str) "+" (round-in-str (cadr str)))	)
				) (vla-get-TextString txt))
			)
			(vla-put-TextString 
				txt
				(round-in-str (vla-get-TextString txt))
			)
		)
	)	
	(vla-endUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
	(princ)	
)
(princ) ;;silent load

Программы совсем одинаковые, хочу только обратить внимание что в этих двух программках есть локальная функция round-in-str которая реализуется по разному: в первом случае rtos, во втором vl-princ-to-string - поведение у них различное.

Поясню по эпичности: надо будет продумать алгоритм расчленения строк на куски, определение какие из этих кусков числа и их обрабатывать, склейку обратно всего этого добра в строку и при этом предусмотреть все возможные варианты обрабатываемых строк.
з.ы. Проблем добавляет тот факт, что atof всеяден и ошибки не выдаст... но может просто потерять часть символов в строке если их предварительно не срезать:
Команда: (atof "123.21")
123.21
Команда: (atof "asd123.21")
0.0
Команда: (atof "123.21asd")
123.21

[rusv]

Сообщение от skkkk rusv, я ничего не понял. Почему 3381? Что значит "конвертацию цифр с округлением"? Как понять это "сразу с группой работать" и " в начале "натыкать"? Нужно бы файл с примером приложить, где будет видно, что есть и как надо.

Извиняюсь - обсчитался. 1000м - это 3281 фут (значок футов '). Например, имею несколько текстовых объектов, в них есть числа, вот их надо найти и перевести из метров в футы. Их довольно много на чертеже, поэтому думал для начала сделать набор нужных мне объектов в группу ("натыкать"), а далее, чтобы код работал с каждым объектом по очереди, пока объекты не закончатся в группе (while).

[skkkk]

Vladimir_Sergeevich, можно же проще сделать, если сравнивать коды символов (те, что возвращает функция ascii). Вспоминая одну из тем, где Сергей812 открыл мне глаза на то, что функции < и > могут сравнивать помимо чисел и строки (что было для меня откровением), а также подглядев в справке коды цифр, можем заключить, что цифрами являются символы с кодами от 48 до 57 включительно (от 0 до 9), можем сделать как-то так:

Код:

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

 (setq vl_txtobj (vlax-ename->vla-object (car (entsel))))
(setq str (vla-get-TextString vl_txtobj))
(setq digits
	(vl-list->string
		(vl-remove-if-not
		   '(lambda (x) (and (> x 47) (< x 58)))
			(vl-string->list str)
		)
	)
)
(setq ft (* (atof digits) 3.28084))
(vla-put-TextString vl_txtobj (strcat str "\/" (rtos ft 2 0) "'"))

Чтобы в футах не было нулей после запятой, переменная DIMZIN должна быть равна нулю.

Правда, с текстами в файле-образце выходит, что добавочный текст с футами не влезает в одну строку и переносится. Чтобы было в одну строку, нужно назначить тексту ширину, равную нулю. Почему-то с мтекстами из файла у меня программно не выходит назначить им ширину 0. Создал прям там в файле свои мтексты, установил им ширину в 0 - в них все сработало хорошо. Файл с результатом прилагаю. Однако, очень любопытно, почему код

Код:

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

 (vla-put-Width (vlax-ename->vla-object (car (entsel))) 0)

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

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

[koMon]

skkkk, сравни палитровые свойства текстов

[skkkk]

koMon, ага, спасибо за наводочку, похоже, это - столбцы. Ну ОК, а как их программно убрать?

P.S.: Сравнил дампы entget - тоже разницы не нашел.

[koMon]

Очередное волшебство автокада!?
(cvunit) имхо сподручнее будет для конвертации метров в футы.

[Vladimir_Sergeevich]

skkkk, информация о кодах интересна, но простоты не добавляет. Как быть если надо не дописать, а преобразовать число?
В моей практике были случаи когда надо было на чертеже все отметки поднять (из местной системы высот в балтику, например), а в строках бывали не просто числа, а подписи вида "в.оп. 123,12"
И счастьем было, если везде в этих строках был пробел по которому это добро можно поделить, обработать число, и склеить обратно.

[koMon]

вист

выбираем у *текста то что находится/или не находится между пробелом и "м" (строковое число) и ковертируем его из метров в футы. зачем это нужно отечественному проектировщику?

skkkk, копание дало следующее. если у мтекста есть колонки, то назначить ему ширину ноль не получается. колонки нужно удалить костылями. кстати в руководстве по dxf у мтекста есть групповой код 75, который якобы отвечает за колонки и который не документируется в этом руководстве и не показывается в dxf дампе, но… см. костыли частного случая в коде после (vla-put-textstring…), которые позволяют сначала назначить ширине ноль, а затем переназначить её под текущую длину строки.

Код:

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

 
(defun c:meter_foot (/ text_index ignore_empty_sset text_sset text_object text_entity text_string space_position m_position meter_string)
	(repeat (sslength (setq text_index 0 
							ignore_empty_sset (while (null (setq text_sset (vl-catch-all-apply 'ssget (list '((0 . "*text")))))))
							text_sset (cond
											(
												(vl-catch-all-error-p text_sset)
													(princ "\nОтмена команды")
													(ssadd)
											)
											(
												t
													text_sset
											)
									  )
					  )
			)
		(setq text_object (vlax-ename->vla-object (setq text_entity (ssname text_sset text_index)))
			  text_string (vla-get-textstring text_object)
			  space_position (if (null (setq space_position (vl-string-position (ascii " ") text_string))) 0 space_position)
			  m_position (vl-string-position (ascii "ì") text_string)
		)
		(if (and 
				 m_position
				 (> m_position space_position) 
			)
				(progn
					(setq meter_string (substr text_string
			  								   (1+ space_position)
											   (-
												  m_position
												  space_position
											   )
							   		   )
					)     
				  	(vla-put-textstring text_object
				  			  			(strcat (substr text_string 1 (1+ m_position))
				  								"/"
				  								(rtos (cvunit (atof meter_string) "m" "ft") 2 0)
				  								"'"
				  						)
				  	)
					(entmod (append (entget text_entity) '((75 . 0))))
					(vl-catch-all-apply 'vla-put-width (list text_object 0.0))
					(entmod (append (entget text_entity) '((75 . 0))))
					(vl-catch-all-apply 'vla-put-width 
										(list text_object 
											  (vl-catch-all-apply '* 
													   			   (list 1.01 
																		 (cdr (assoc 42 (entget text_entity)))
																   )
											  )
										)
					)
				)
		)
		(setq text_index (1+ text_index))
	)
	(princ)
)

[Сергей812]

Сообщение от koMon колонки нужно удалить костылями

костыль)

[koMon]

LISP vs .NET

LISP rules!

[Vladimir_Sergeevich]

Сообщение от koMon LISP vs .NET LISP rules!

Завораживающая идея...
написать на шарпе кучу собственных лисп функций, которые разработчики изначально забыли сделать, и продолжать писать костыли на лиспе
хмм... а может обернуть лиспом какой-нибудь System.Xml.Linq?

[rusv]

Сообщение от skkkk Vladimir_Sergeevich, можно же проще сделать, если сравнивать коды символов (те, что возвращает функция ascii). Вспоминая одну из тем, где Сергей812 открыл мне глаза на то, что функции < и > могут сравнивать помимо чисел и строки (что было для меня откровением), а также подглядев в справке коды цифр, можем заключить, что цифрами являются символы с кодами от 48 до 57 включительно (от 0 до 9), можем сделать как-то так: Код: [Выделить все] (setq vl_txtobj (vlax-ename->vla-object (car (entsel)))) (setq str (vla-get-TextString vl_txtobj)) (setq digits (vl-list->string (vl-remove-if-not '(lambda (x) (and (> x 47) (< x 58))) (vl-string->list str) ) ) ) (setq ft (* (atof digits) 3.28084)) (vla-put-TextString vl_txtobj (strcat str "\/" (rtos ft 2 0) "'")) Чтобы в футах не было нулей после запятой, переменная DIMZIN должна быть равна нулю. Правда, с текстами в файле-образце выходит, что добавочный текст с футами не влезает в одну строку и переносится. Чтобы было в одну строку, нужно назначить тексту ширину, равную нулю. Почему-то с мтекстами из файла у меня программно не выходит назначить им ширину 0. Создал прям там в файле свои мтексты, установил им ширину в 0 - в них все сработало хорошо. Файл с результатом прилагаю. Однако, очень любопытно, почему код Код: [Выделить все] (vla-put-Width (vlax-ename->vla-object (car (entsel))) 0) не меняет ширину мтекста в ноль, при этом, даже вручную его нельзя сделать нулевым. Сверял дампы этих текстов - всё совпадает, кроме совсем уж индивидуальных параметров (см. вложение-скрин). Хотелось бы понять: почему так? Нужно также добавить, что данный код, конечно, сработает корректно только для случая, где есть лишь одно число (как в файле-примере). Возможно, для более правильной работы в каком-то случае было бы правильным делать анализ текста на символ "м", и все цифры, что перед ним забирать в качестве числа и обрабатывать их.

Большое спасибо - это практически, то что мне нужно. Программа находит в тексте цифры и их конвертирует. А можно ли сделать, чтобы находились только те цифры рядом с которыми указан символ "м" ? Т.к зачастую Мtext содержит еще числа, которые трогать не нужно.

[Сергей812]

Offtop:

Сообщение от koMon LISP vs .NET LISP rules!

рулит, если к нему приделывать костыли Единственно неоспоримый плюс лиспа, имхо - что он является родным и встроенным, как VBA в офисе - т.е. на него всегда можно рассчитывать при необходимости что-то написать... Если не выпилят лисп в следующих версиях, конечно)

Сообщение от Vladimir_Sergeevich Завораживающая идея... написать на шарпе кучу собственных лисп функций, которые разработчики изначально забыли сделать, и продолжать писать костыли на лиспе хмм... а может обернуть лиспом какой-нибудь System.Xml.Linq?

а потом, написав кучу функций и набив руку в .NetApi - подумать: если все равно придется перекомпилировать .Net сборки под другие версии акада, то зачем эти вставки из лиспа..?!

[koMon]

Offtop:

Сообщение от Сергей812 Если не выпилят лисп в следующих версиях, конечно)

типун…

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

VLIDE уже обозвана "устаревшей" А учитывая ACAD2021, LISPSYS, VS Code & Co - становится немного уныло.

[Vladimir_Sergeevich]

Offtop: Ага, а во FreeCAD вообще командная строка сразу на питоне. Туда все и идем. Хотя в 2021 акаде все лиспы продолжают исправно работать. А VLIDE я открывал только для того, что бы чего нибудь откомпилировать в VLX

Сообщение от rusv А можно ли сделать, чтобы находились только те цифры рядом с которыми указан символ "м" ?

rusv, по моему эту тему проработал koMon в #3989

[rusv]

Сообщение от Vladimir_Sergeevich Offtop: Ага, а во FreeCAD вообще командная строка сразу на питоне. Туда все и идем. Хотя в 2021 акаде все лиспы продолжают исправно работать. А VLIDE я открывал только для того, что бы чего нибудь откомпилировать в VLX rusv, по моему эту тему проработал koMon в #3989

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

[Vladimir_Sergeevich]

Сообщение от rusv Получается из-за того что пробела нет - команда не отрабатывает.

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

з.ы. тема уже поднималась и есть достаточно универсальный инструмент

з.з.ы.

Код:

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

 
(defun c:transform-txt ( / t_lst ft_dim)
	(vla-startUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
	(vlax-for txt (sad-get-ss '((0 "*TEXT") ))
		(if (wcmatch (vla-get-TextString txt) "*'*") nil
			(progn
				(setq t_lst (_dwgru-str->list (vla-get-TextString txt))
					ft_dim nil)
				(foreach it t_lst
					(if (numberp it)
						;;(strcat (vl-princ-to-string it) "\/" (rtos (cvunit it "m" "ft") 2 0) "'")
						(setq t_lst (subst (vl-princ-to-string it) it t_lst)
							ft_dim (rtos (cvunit it "m" "ft") 2 0)
						)
					) 
				)
				(if ft_dim 
					(vla-put-TextString 
						txt
						((lambda (lst add / rez)
							(setq rez "")
							(repeat (length lst)
								(setq rez (strcat rez (car lst))
								lst (cdr lst)
								)
							)
							(strcat rez "\/" add "'"))
						t_lst ft_dim)
					)
				)			
			)
		) 
	)	
	(vla-endUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
	(princ)	
)

 (defun _dwgru-str->list (s)
                 ;|
***************************************************************************************
*
* Программа разделяет строку на список текстовых и цифровых составляющих.
* Запятая между цифрами, зменяется на точечный разделитель дробной части.
* 
**************************************************************************************
*
* Написал Елпанов Евгений       (ElpanovEvgeniy)
*
* дата создания (13/10/2007 a 11:42)
* написано во время конкурса на форуме:
* http://www.cadxp.com/XForum+viewthread-fid-101-tid-16943-page-2.html
***************************************************************************************
* Пример использования и результатов работы:
* (_dwgru-str->list "point.25.4cm.")           => ("point." 25.4 "cm.")
* (_dwgru-str->list "point.25,4cm.")           => ("point." 25.4 "cm.")
* (_dwgru-str->list "point.3/8cm.")            => ("point." 0.375 "cm.")
* (_dwgru-str->list "qvf12qsdf125 5sf 56dfv2") => ("qvf" 12 "qsdf" 125 " " 5 "sf " 56 "dfv" 2)
***************************************************************************************
 |;
 (defun str->list1 (a b f)
  (cond
   ((null b)
    (list (if f
           (cond ((vl-position 46 a) (atof (vl-list->string (reverse a))))
                 ((vl-position 47 a) (distof (vl-list->string (reverse a))))
                 ((vl-position 44 a) (atof (vl-list->string (subst 46 44 (reverse a)))))
                 (t (atoi (vl-list->string (reverse a))))
           ) ;_ cond
           (vl-list->string (reverse a))
          ) ;_ if
    ) ;_ list
   )
   (f
    (if (or (= (car b) 44) (< 45 (car b) 58))
     (str->list1 (cons (car b) a) (cdr b) f)
     (cons (cond ((vl-position 46 a) (atof (vl-list->string (reverse a))))
                 ((vl-position 47 a) (distof (vl-list->string (reverse a))))
                 ((vl-position 44 a) (atof (vl-list->string (subst 46 44 (reverse a)))))
                 (t (atoi (vl-list->string (reverse a))))
           ) ;_ cond
           (str->list1 (list (car b)) (cdr b) nil)
     ) ;_ cons
    ) ;_ if
   )
   (t
    (if (< 47 (car b) 58)
     (cons (vl-list->string (reverse a)) (str->list1 (list (car b)) (cdr b) t))
     (str->list1 (cons (car b) a) (cdr b) nil)
    ) ;_ if
   )
  ) ;_ cond
 ) ;_ defun
 (setq s (vl-string->list s))
 (str->list1 (list (car s))
             (cdr s)
             (if (or (= (car s) 44) (< 45 (car s) 58))
              t
             ) ;_ if
 )
) 


(defun sad-get-ss (filter_lst / temp ss code_lst filter_value_lst) ;|получение набора, возвращает объект IAcadSelectionSet
	(sad-get-ss nil)
	Фильтр вида '((0 "TEXT") (8 "0"))
	возвращает IAcadSelectionSet
	пустой выбор недопустим
	|;
(setq temp t
	ss (vla-get-PickfirstSelectionSet (vla-get-activeDocument (vlax-get-acad-object))) 
	code_lst '()
	filter_value_lst '()
);;#<VLA-OBJECT IAcadSelectionSet 136be084>
(if filter_lst
	(progn
		(foreach f filter_lst ;;sorting
			(setq code_lst (cons (car f) code_lst)
			filter_value_lst (cons (cadr f) filter_value_lst)
			)
		)
		(setq ;;convert to safearray
			code_lst
			(vlax-safearray-fill
				(vlax-make-safearray 
					vlax-vbInteger
					(cons 0 (1- (length filter_lst)))
				)
				code_lst
			)
			filter_value_lst
			(vlax-safearray-fill
				(vlax-make-safearray
					vlax-vbVariant
					(cons 0 (1- (length filter_lst)))
				)
				filter_value_lst
			)
		) 
	)
)
;;(while temp
  (if (= (vla-get-Count ss) 0)
	(vla-SelectOnScreen ss
		code_lst ;;kodes of filters (variant) (list of DXF codes)
		filter_value_lst ;;filters (list of values DXF codes)
	)
	;;(setq temp nil)
  )
;;)
ss
)

[koMon]

эпичная/не эпичная, но решить её универсальным инструментом вряд ли получится. в общем виде алгоритм видится имхо таким.
1. ищем в тексте "м". если литера встречается однажды по условию, то оно и к лучшему)
2. идём "налево" от найденной литеры в поиске цифр до первой не цифры. найденные цифры читаем в число метров. запоминаем индекс начала метров.
3. теперь идём "направо" через "/", через цифры до "'". запоминаем индекс "'", если нашёлся или индекс "м", если не нашёлся.
4. режем строку по найденным индексам и вставляем новую подстроку метры/футы вместо вырезанной.
5. обновляем текст.