Эспликация блоков из выбранного

Эспликация блоков из выбранного · 26.08.2009, 15:58

Опять возникла какая то невероятная идея....

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

В свою очередь в лист (в любые координаты) вставляется список в виде текста (можно конечно и таблицу, но не принципиально), в котором
1-имя блока________2-сам блок (с пустым атрибутом)_______ 3-номера (например 1...5, 12,13)________ 4-количество блоков.

В качестве исходника прикрепляю dwg...

G-RAV · 02.09.2009, 20:12

Попытался сам что-нибудь накалякать, но на выходе совсем не то, что хотелось бы... Пока решил вывод результата делать через promt. У меня получается список всех блоков
1 UZ1 86
2 UZ12 85
3 UZ12 84
4 UZ12 83
5 UZ12 82
6 UZ12 81
, а мне необходимо, для начала, их названия и количество
Например:
UZ1 - 22 шт.
UZ12 - 123 шт.
Ничего не получается

, от функций по работе с примитивами уже мозги кипят

, так что любой помощи буду рад....
Вот, собственно, мое безобразие:

Код:

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

(defun C:EKSPL (/ Nabor N NN old_cmdecho Objekt$Name SelEnt Objekt)
  (setq old_cmdecho (getvar "cmdecho"))
  (setvar "cmdecho" 0)
  (setq Objekt$Name "")
 
  (setq Nabor nil
 N 0
  )
 
  (setq Nabor (ssget))
  (repeat (sslength Nabor)
    (setq SelEnt (ssname Nabor N))
    (setq Objekt (entget SelEnt))
    (setq Objekt$Name (cdr (assoc 2 Objekt)))
    (if (/= Objekt$Name nil)
      (progn
 (setq SelEnt (entnext SelEnt))
 (setq NN (cdr (assoc 1 (entget SelEnt))))
 (setq N (+ N 1))
 (prompt (strcat "\n" (itoa N) "  " Objekt$Name " " NN))
      )
    )
  )
  (setvar "cmdecho" old_cmdecho)
)

Do$ · 03.09.2009, 08:47

Если я правильно понял, тебе надо подсчитать количество блоков каждого типа в выбранном наборе? Так ведь уже есть готовые программы для этого - поиск.
Если сам хочешь написать такую, то я бы предложил следующий алгоритм: создаешь набор->преобразуешь набор в список с именами блоков->ведешь подсчет наименований в списке->выводишь результат в файл/на экран/в таблицу на чертеже
Самое сложное тут - преобразовать набор в список, тут тебе поможет ф-ция (производная от _kpblc-conv-selset-to-ename):

Код:

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

  (defun conv-selset-to-property-list (selset dxf / tab item)
                                     ;|
*    Преобразование набора, полученного через ssget, в список свойств
*    с определенным DXF-кодом
*    Параметры вызова:
	selset	набор примитивов
             dxf        dxf-код свойства
*    Примеры вызова:
(conv-selset-to-property-list (ssget) 0)
*    Ф-ция получена модификацией функции  _kpblc-conv-selset-to-ename,
      взятой отсюда: http://forum.dwg.ru/showpost.php?p=436453&postcount=6
|;

    (cond
      ((not selset) nil)
      ((= (type selset) 'pickset)
       (repeat (setq tab  nil
		     item (sslength selset)
	       ) ;_ end setq
	 (setq tab
		(cons
		  (cdr (assoc dxf
			      (entget (ssname selset (setq item (1- item))))
		       ) ;_ end of assoc
		  ) ;_ end of cdr
		  tab
		) ;_ end of cons
	 ) ;_ end of setq
       ) ;_ end repeat
      )
      ((listp selset) selset)
    ) ;_ end of cond
  ) ;_ end of defun

G-RAV · 03.09.2009, 10:27

Цитата:

Сообщение от Do$

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

Да..Для начала.

Цитата:

Если сам хочешь написать такую, то я бы предложил следующий алгоритм: создаешь набор->преобразуешь набор в список с именами блоков->ведешь подсчет наименований в списке->выводишь результат в файл/на экран/в таблицу на чертеже
Самое сложное тут - преобразовать набор в список, тут тебе поможет ф-ция (производная от _kpblc-conv-selset-to-ename)

Присвоил dxf значение 2 - получил список с именами, даже отсортировал его с помощью acad_strlsort... Теперь не может до меня дойти - как подсчитать наименования в списке...

Makswell · 03.09.2009, 11:01

Цитата:

Сообщение от G-RAV

Присвоил dxf значение 2 - получил список с именами, даже отсортировал его с помощью acad_strlsort... Теперь не может до меня дойти - как подсчитать наименования в списке...

Допустим lst - твой список.
Берёшь первый элемент списка: (setq el (car lst))
Создаёшь новый список без этого элемента (setq new_lst (vl-remove el lst)
Вычисляешь разницу между длинами этих списков - это и будет количество элементов равных первому элементу списка.
На выходе остаётся new_lst - список не содержащий элементы, которые были равны первому элементу. К этому списку применяешь тот же алгоритм.
И так далее, пока new_lst не станет nil.

Как-то так короче.

Do$ · 03.09.2009, 11:12

Можно по такому алгоритму:
Цикл:
Берешь первое наименование списка->проходишь по списку, сравнивая каждое наиенование с выбранным, если одинаково: счетчик увеличиваем на 1, если нет, счетчик без изменений->в результирующий список заносишь наименование и количество->удаляешь из списка выбранное наименование (vl-remove)->берешь первое наименование получившегося списка... и так до тех пор, пока список не опустеет

О... это уже второй вариант...

G-RAV · 03.09.2009, 11:34

УРААА!

Вроде работает!!

Код:

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

(defun conv-selset-to-property-list (selset dxf  / tab item)
                                ;|
*    Преобразование набора, полученного через ssget, в список свойств
*    с определенным DXF-кодом
*    Параметры вызова:
 selset набор примитивов
             dxf        dxf-код свойства
*    Примеры вызова:
(conv-selset-to-property-list (ssget) 0)
*    Ф-ция получена модификацией функции  _kpblc-conv-selset-to-ename,
      взятой отсюда: http://forum.dwg.ru/showpost.php?p=436453&postcount=6
|;
(setq dxf 2)
    (cond
      ((not selset) nil)
      ((= (type selset) 'pickset)
       (repeat (setq tab  nil
       item (sslength selset)
        ) ;_ end setq
  (setq tab
  (acad_strlsort (cons
    (cdr (assoc dxf
         (entget (ssname selset (setq item (1- item))))
         ) ;_ end of assoc
    ) ;_ end of cdr
    tab
  ) ;_ end of cons
    )
  ) ;_ end of setq
       ) ;_ end repeat
      )
      ((listp selset) selset)
    ) ;_ end of cond
(While (/= tab nil)  
(setq el (car tab))
(setq new_lst (vl-remove el tab))
(setq kol (-(length tab) (length new_lst)))
  (prompt (strcat "\n" el "  " (itoa kol) "шт."))
(setq tab new_lst))  
  ) ;_ end of defun

Теперь мне необходимо добавить еще один пункт: у каждого блока по одному отрибуту (номера блоков на чертеже), необходимо, напротив имени и количества, указать еще и номера, в таком виде 1-17,22, 27... Пока не знаю как это сделать, но буду мучить этот же код

.

Сергей Богатов · 03.09.2009, 11:40

это обязательно программно сделать? может dataextraction подойдёт? тем более автоматическое обновление данных

G-RAV · 03.09.2009, 11:42

Да... Эти данные потом пойдут в таблицу... Получится автоматическая экспликация...

Сергей Богатов · 03.09.2009, 11:50

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

G-RAV · 03.09.2009, 11:52

а можно подробнее про dataextraction?...

Сергей Богатов · 03.09.2009, 11:57

из хелпа

Цитата:

You can extract property data from objects in drawings and export the output to a table or to an external file.
Using the Data Extraction wizard, you select objects and their properties from which to extract data and save the parameters in a file. You can also combine the extracted data with information in a Microsoft Excel spreadsheet. Using table styles, you can quickly create a pre-formatted table that has a title and column labels.
When the extracted data is no longer current with the drawing, you can be notified that the table needs to be updated.

проще говоря - то что вам нужно

G-RAV · 03.09.2009, 12:06

Если речь идет об извлечении атрибутов, то не подходит т.к. имеет не тот вид

Цитата:

Количество NN_PR Имя
1 13 UZ1
1 63 UZ2
1 36 UZ7
1 66 UZ2
1 37 UZ7
1 83 UZ12
1 10 UZ1
1 2 UZ1
1 52 UZ6
1 23 UZ2
1 40 UZ7
1 38 UZ7
1 33 UZ4
1 42 UZ7
1 49 UZ1
1 85 UZ12
1 51 UZ6
1 41 UZ7
1 46 UZ7
1 53 UZ6
1 43 UZ7

Do$ · 03.09.2009, 12:09

Цитата:

Сообщение от G-RAV

УРААА!

Вроде работает!!

Код:

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

(defun conv-selset-to-property-list (selset dxf  / tab item)
                                ;|
*    Преобразование набора, полученного через ssget, в список свойств
*    с определенным DXF-кодом
*    Параметры вызова:
 selset набор примитивов
             dxf        dxf-код свойства
*    Примеры вызова:
(conv-selset-to-property-list (ssget) 0)
*    Ф-ция получена модификацией функции  _kpblc-conv-selset-to-ename,
      взятой отсюда: http://forum.dwg.ru/showpost.php?p=436453&postcount=6
|;
(setq dxf 2)
    (cond
      ((not selset) nil)
      ((= (type selset) 'pickset)
       (repeat (setq tab  nil
       item (sslength selset)
        ) ;_ end setq
  (setq tab
  (acad_strlsort (cons
    (cdr (assoc dxf
         (entget (ssname selset (setq item (1- item))))
         ) ;_ end of assoc
    ) ;_ end of cdr
    tab
  ) ;_ end of cons
    )
  ) ;_ end of setq
       ) ;_ end repeat
      )
      ((listp selset) selset)
    ) ;_ end of cond
(While (/= tab nil)  
(setq el (car tab))
(setq new_lst (vl-remove el tab))
(setq kol (-(length tab) (length new_lst)))
  (prompt (strcat "\n" el "  " (itoa kol) "шт."))
(setq tab new_lst))  
  ) ;_ end of defun

Теперь мне необходимо добавить еще один пункт: у каждого блока по одному отрибуту (номера блоков на чертеже), необходимо, напротив имени и количества, указать еще и номера, в таком виде 1-17,22, 27... Пока не знаю как это сделать, но буду мучить этот же код

.

Просьба небольшая - если изменил функцию, смени название...

G-RAV · 03.09.2009, 12:17

Do$, хорошо! Это просто пробный вариант - поиск истины

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

Сергей Богатов · 03.09.2009, 12:44

виноват, не дочитал условия задачи до конца

G-RAV · 03.09.2009, 12:47

прокоментируйте кто-нибудь сл. момент:

Код:

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

(= (type selset) 'pickset)

особенно интересно про 'pickset

Do$ · 03.09.2009, 12:58

Цитата:

Сообщение от G-RAV

прокоментируйте кто-нибудь сл. момент:

Код:

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

(= (type selset) 'pickset)

особенно интересно про 'pickset

Проверка, является ли selset набором

G-RAV · 03.09.2009, 17:17

У меня опять ступор

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

Код:

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

 
(defun C:ESP (/ selset SelEnt tab objekt objektname NN item)
  (setq selset (ssget))
  (cond
    ((not selset) nil)
    ((= (type selset) 'pickset)
     (repeat
       (setq tab  nil
      item (sslength selset)
       ) ;_ end setq
 (setq SelEnt  (ssname selset (setq item (1- item)))
       objekt  (entget SelEnt)
       objektname (cdr (assoc 2 objekt))
       SelEnt  (entnext SelEnt)
       NN  (cdr (assoc 1 (entget SelEnt)))
       tab  (cons (strcat objektname " " NN) tab)
 ) ;_ end of setq

     ) ;_ end repeat
    )
    ((listp selset) selset)
  ) ;_ end of cond
) ;_ end of defun

А вот то, что получается на выходе:

Цитата:

("UZ1 86" "UZ12 85" "UZ12 84" "UZ12 83" "UZ12 82" "UZ12 81" "UZ12 80" "UZ12 79"
"UZ12 78" "UZ12 77" "UZ12 76" "UZ12 75" "UZ12 74" "UZ12 73" "UZ1 72" "UZ2 71"
"UZ2 70" "UZ2 69" "UZ2 68" "UZ2 67" "UZ2 66" "UZ2 65" "UZ2 64" "UZ2 63" "UZ2
62" "UZ2 61" "UZ2 60" "UZ2 59" "UZ6 58" "UZ6 57" "UZ6 56" "UZ6 55" "UZ6 54"
"UZ6 53" "UZ6 52" "UZ6 51" "UZ6 50" "UZ1 49" "UZ7 48" "UZ7 47" "UZ7 46" "UZ7
45" "UZ7 44" "UZ7 43" "UZ7 42" "UZ7 41" "UZ7 40" "UZ7 39" "UZ7 38" "UZ7 37"
"UZ7 36" "UZ4 35" "UZ4 34" "UZ4 33" "UZ4 32" "UZ4 31" "UZ4 30" "UZ4 29" "UZ4
28" "UZ4 27" "UZ2 26" "UZ2 25" "UZ2 24" "UZ2 23" "UZ2 22" "UZ2 21" "UZ2 20"
"UZ2 19" "UZ2 18" "UZ2 17" "UZ2 16" "UZ2 15" "UZ2 14" "UZ1 13" "UZ1 12" "UZ1
11" "UZ1 10" "UZ1 9" "UZ1 8" "UZ1 7" "UZ1 6" "UZ1 5" "UZ1 4" "UZ1 3" "UZ1 2"
"UZ1 1")

Если есть у кого какие-нибудь мысли, поможите

Do$ · 03.09.2009, 19:19

Мысль номер один: зря ты в одну строку сгоняешь наименование и номер
Мысль номер два: на выходе еще надо поставить реверс списка
Мысль номер три:

Код:

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

tab  (cons (strcat objektname " " NN) tab)

замени на

Код:

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

tab  (cons (list objektname NN) tab)

На выходе получишь двухуровненвый список, с ним полегче будет.
Мысль номер четыре: алгоритм подсчета тот же (пост номер 5 и 6), только вместо vl-remove используй vl-remove-if.

VVA · 03.09.2009, 22:10

Может здесь подберешь себе что-нибудь
подсчет динамических блоков
Подсчет количества блоков

G-RAV · 04.09.2009, 13:31

Цитата:

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

Может здесь подберешь себе что-нибудь
подсчет динамических блоков
Подсчет количества блоков

Спасибо... Только вот в целях самообразования хочется самому доделать....

И меня опять проблема, на этот раз с циклом

Код:

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

(defun C:ESP (/ selset SelEnt tab objekt objektname NN item new_lst z n)
  (setq selset (ssget))
  (cond
    ((not selset) nil)
    ((= (type selset) 'pickset)
     (repeat
       (setq tab  nil
      item (sslength selset)
       ) ;_ end setq
 (setq SelEnt  (ssname selset (setq item (1- item)))
       objekt  (entget SelEnt)
       objektname (cdr (assoc 2 objekt))
       SelEnt  (entnext SelEnt)
       NN  (cdr (assoc 1 (entget SelEnt)))
       tab  (reverse(cons (list objektname NN) tab))
 ) ;_ end of setq
 
     ) ;_ end repeat
    )
    ((listp selset) selset)
  ) ;_ end of cond
 
  (while (/= tab nil) ;- цикл, пока список не пуст
(setq n 0) ;- обнуление счетчика на количество
(setq z 0) ;- обнуление счетчика для NTH
   (while (/=(nth z tab) nil)  ;- подцикл, пока есть подсписки
         (if (= (caar tab) (car(nth z tab))) ;- условие, если 1-й элемент подсписка равен z-му
    (setq n (+ n 1) ;- то n+1
      new_lst (vl-remove (nth z tab) tab) ;- то удалить z-й подсписок присвоить списку new_lst 
  tab new_lst )) ;- присвоить tab new_lst, конец if 
  (setq z (+ z 1)));- след. элемент, конец подцикла
 
(prompt (strcat "\n" (caar tab) "  " (itoa n) "шт."));- вывод информации на экран     
(setq new_lst (vl-remove (car tab) tab)) ;- удаляем 1-й элемент tab   
(setq tab new_lst) ;- присвоить tab new_lst      
 
  );- конец цикла
 
) ;_ end of defun

...получается - чёпопало.. причем, если в подцикле убрать setq tab new_lst выходит более менее прилично..

Do$ · 04.09.2009, 13:56

Код:

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

(while (/= tab nil) ;- цикл, пока список не пуст 
; _Вместо (/= tab nil) обычно просто ставят tab
(setq n 0) ;- обнуление счетчика на количество
(setq z 0) ;- обнуление счетчика для NTH
;| _А дальше ты делаешь вот что: проходишь по списку tab при помощи
номера элемента z, но при этом зачем-то удаляешь из списка tab z-й элемент в каждом
цикле - из-за этого и получается чушь. |;
   (while (/= (nth z tab) nil)  ;- подцикл, пока есть подсписки
         (if (= (caar tab) (car(nth z tab))) ;- условие, если 1-й элемент подсписка равен z-му
    (setq n (+ n 1) ;- то n+1
; _есть такая ф-ция (1+), (+ n 1) это то же самое, что (1+ n)
; _аналогичная ф-ция (1-)
      new_lst (vl-remove (nth z tab) tab) ;- то удалить z-й подсписок присвоить списку new_lst 
  tab new_lst )) ;- присвоить tab new_lst, конец if 
  (setq z (+ z 1)));- след. элемент, конец подцикла
 
(prompt (strcat "\n" (caar tab) "  " (itoa n) "шт."));- вывод информации на экран     
(setq new_lst (vl-remove (car tab) tab)) ;- удаляем 1-й элемент tab
; _Удалять первый элемент правильнее и безопаснее с помощью (cdr tab)  
(setq tab new_lst) ;- присвоить tab new_lst      
 
  );- конец цикла
 
) ;_ end of defun

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

G-RAV · 04.09.2009, 14:33

Я к этому уже сегодня приходил.. получается:

Цитата:

UZ12 13шт.
UZ12 12шт.
UZ12 11шт.
UZ12 10шт.
UZ12 9шт.
UZ12 8шт.
UZ12 7шт.
UZ2 26шт.
UZ2 25шт.
UZ2 24шт.
UZ2 23шт.
UZ2 22шт.
UZ2 21шт.
UZ2 20шт.
UZ6 9шт.
UZ6 8шт.
UZ6 7шт.
UZ6 6шт.
.............

В принципе, правильно, но не то, что требуется

Do$ · 04.09.2009, 16:00

Offtop: Может ну его, программирование? Непростое это дело...

G-RAV · 06.09.2009, 17:52

Цитата:

Сообщение от Do$

Offtop: Может ну его, программирование? Непростое это дело...

Может...

Вся проблема была в том, что в условии на совпадение имен нужно было преременной z присвоить ( z-1 )....

Код:

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

(defun C:ESP (/ selset SelEnt tab objekt objektname NN item z n name
       nomer)
  (setq selset (ssget'((0 . "INSERT"))))
  (cond
    ((not selset) nil)
    ((= (type selset) 'pickset)
     (repeat
       (setq tab  nil
      item (sslength selset)
       ) ;_ end setq
 (setq SelEnt  (ssname selset (setq item (1- item)))
       objekt  (entget SelEnt)
       objektname (cdr (assoc 2 objekt))
       SelEnt  (entnext SelEnt)
       NN  (cdr (assoc 1 (entget SelEnt)))
       tab  (reverse (cons (list objektname NN) tab))
 ) ;_ end of setq
 
     ) ;_ end repeat
    )
    ((listp selset) selset)
  ) ;_ end of cond
 
  (while (/= tab nil)
    (setq n 1
   z 1
   nomer nil
    )
    (while (/= (nth z tab) nil)
      (if (= (caar tab) (car (nth z tab)))
 (setq n     (1+ n)
       nomer (cons (cdr (nth z tab)) nomer)
       tab   (vl-remove (nth z tab) tab)
       z     (1- z)
 )
      )
      (setq z (1+ z))
    )
   (setq nomer (append (cdar tab) nomer))
    (print (list (caar tab) nomer n))
    (setq tab (vl-remove (car tab) tab))
 
  )
) ;_ end of defun

Сейчас тот вид, который нужен

Цитата:

(имя_блока (номера) количество)

Осталось только отсортировать номера (почему-то vl-sort не работает)...

Кулик Алексей aka kpblc · 07.09.2009, 00:32

Учитывая, что атрибутов может быть несколько, я бы использовал нечто типа такого (правда, у меня там мои библиотечные функции используются, которые переделывать было лень):

Код:

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

(defun c:esp2 (/                        adoc                     selset                   res
               name                     is                       fun_get-ent-name         _kpblc-conv-vla-to-list
               _kpblc-conv-ent-to-vla   _kpblc-conv-ent-to-ename _kpblc-conv-value-to-string
               _kpblc-conv-list-to-string                        fun_get-attr
               )

  (defun fun_get-ent-name (ent)
    (cond
      ((vlax-property-available-p ent 'effectivename)
       (vla-get-effectivename ent)
       )
      ((vlax-property-available-p ent 'name)
       (vla-get-name ent)
       )
      ) ;_ end of cond
    ) ;_ end of defun

  (defun fun_get-attr (ent)
    (append
      (_kpblc-conv-vla-to-list (vla-getattributes ent))
      (_kpblc-conv-vla-to-list (vla-getconstantattributes ent))
      ) ;_ end of append
    ) ;_ end of defun

  (defun _kpblc-conv-value-to-string (value /)
                                     ;|
*    конвертация значения в строку.
|;
    (cond
      ((= (type value) 'str) value)
      ((= (type value) 'int) (itoa value))
      ((= (type value) 'real) (rtos value 2 14))
      ((not value) "")
      (t (vl-princ-to-string value))
      ) ;_ end of cond
    ) ;_ end of defun

  (defun _kpblc-conv-list-to-string (lst sep)
                                    ;|
*    Преобразование списка в строку
*    Параметры вызова:
	lst	обрабатываемй список
	sep	разделитель. nil -> " "
|;
    (setq lst (mapcar (function _kpblc-conv-value-to-string) lst)
          sep (if sep
                sep
                " "
                ) ;_ end of if
          ) ;_ end of setq
    (strcat (car lst)
            (apply (function strcat)
                   (mapcar
                     (function
                       (lambda (x)
                         (strcat sep x)
                         ) ;_ end of lambda
                       ) ;_ end of function
                     (cdr lst)
                     ) ;_ end of mapcar
                   ) ;_ end of apply
            ) ;_ end of strcat
    ) ;_ end of defun

  (defun _kpblc-conv-ent-to-ename (ent_value /)
                                  ;|
*    Функция преобразования полученного значения в ename
*    Параметры вызова:
*	ent_value	значение, которое надо преобразовать в примитив. Может
*			быть именем примитива, vla-указателем или просто
*			списком.
*			Если не принадлежит ни одному из указанных типов,
*			возвращается nil
*    Примеры вызова:
(_kpblc-conv-ent-to-ename (entlast))
(_kpblc-conv-ent-to-ename (vlax-ename->vla-object (entlast)))
|;
    (cond
      ((= (type ent_value) 'vla-object)
       (vlax-vla-object->ename ent_value)
       )
      ((= (type ent_value) 'ename) ent_value)
      ((= (type ent_value) 'str) (handent ent_value))
      ((= (type ent_value) 'list) (cdr (assoc -1 ent_value)))
      (t nil)
      ) ;_ end of cond
    ) ;_ end of defun

  (defun _kpblc-conv-ent-to-vla (ent_value / res)
                                ;|
*    Функция преобразования полученного значения в vla-указатель.
*    Параметры вызова:
*	ent_value	значение, которое надо преобразовать в указатель. Может
*			быть именем примитива, vla-указателем или просто
*			списком.
*			Если не принадлежит ни одному из указанных типов,
*			возвращается nil
*    Примеры вызова:
(_kpblc-conv-ent-to-vla (entlast))
(_kpblc-conv-ent-to-vla (vlax-ename->vla-object (entlast)))
|;
    (cond
      ((= (type ent_value) 'vla-object) ent_value)
      ((= (type ent_value) 'ename) (vlax-ename->vla-object ent_value))
      ((setq res (_kpblc-conv-ent-to-ename ent_value))
       (vlax-ename->vla-object res)
       )
      ) ;_ end of cond
    ) ;_ end of defun

  (defun _kpblc-conv-vla-to-list (value / res)
                                 ;|
*    Преобразовывает vlax-variant или vlax-safearray в список.
|;
    (cond
      ((listp value)
       (mapcar '_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
       )
      ((and (member (type value) (list 'ename 'str 'vla-object))
            (= (type (_kpblc-conv-ent-to-vla value)) 'vla-object)
            (vlax-property-available-p (_kpblc-conv-ent-to-vla value) 'count)
            ) ;_ end of and
       (vlax-for sub (_kpblc-conv-ent-to-vla value)
         (setq res (cons sub res))
         ) ;_ end of vlax-for
       )
      (t value)
      ) ;_ end of cond
    ) ;_ end of defun

  (vl-load-com)
  (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
  (if (= (type (setq selset (vl-catch-all-apply
                              (function
                                (lambda ()
                                  (ssget '((0 . "INSERT")))
                                  ) ;_ end of lambda
                                ) ;_ end of function
                              ) ;_ end of vl-catch-all-apply
                     ) ;_ end of setq
               ) ;_ end of type
         'pickset
         ) ;_ end of =
    (progn
      (foreach ent (mapcar (function vlax-ename->vla-object)
                           ((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
        (setq res (if (not (setq is (car (member (setq name (fun_get-ent-name ent))
                                                 (mapcar (function
                                                           (lambda (x)
                                                             (cdr (assoc "name" x))
                                                             ) ;_ end of lambda
                                                           ) ;_ end of function
                                                         res
                                                         ) ;_ end of mapcar
                                                 ) ;_ end of member
                                         ) ;_ end of car
                                 ) ;_ end of setq
                           ) ;_ end of not
                    (cons
                      (list
                        (cons "name" name)
                        (cons "ent" ent)
                        (cons "range" 1)
                        ) ;_ end of list
                      res
                      ) ;_ end of cons
                    ((lambda (/ _is)
                       (setq _is (car (vl-remove-if-not
                                        (function
                                          (lambda (x)
                                            (= (cdr (assoc "name" x)) is)
                                            ) ;_ end of LAMBDA
                                          ) ;_ end of function
                                        res
                                        ) ;_ end of vl-remove-if-not
                                      ) ;_ end of car
                             ) ;_ end of setq
                       (subst
                         (subst (cons "range" (1+ (cdr (assoc "range" _is))))
                                (assoc "range" _is)
                                _is
                                ) ;_ end of subst
                         _is
                         res
                         ) ;_ end of subst
                       ) ;_ end of lambda
                     )
                    ) ;_ end of if
              ) ;_ end of setq
        ) ;_ end of foreach
      (princ
        (strcat "\n"
                (_kpblc-conv-list-to-string
                  (mapcar
                    (function
                      (lambda (x / lst)
                        (setq lst (fun_get-attr (cdr (assoc "ent" x))))
                        (strcat (cdr (assoc "name" x))
                                " : "
                                (if lst
                                  (_kpblc-conv-list-to-string
                                    (mapcar (function
                                              (lambda (a)
                                                (strcat (vla-get-tagstring a) "=" (vla-get-textstring a))
                                                ) ;_ end of LAMBDA
                                              ) ;_ end of function
                                            lst
                                            ) ;_ end of mapcar
                                    "; "
                                    ) ;_ end of _kpblc-conv-list-to-string
                                  ""
                                  ) ;_ end of if
                                " : "
                                (itoa (cdr (assoc "range" x)))
                                " шт."
                                ) ;_ end of strcat
                        ) ;_ end of LAMBDA
                      ) ;_ end of function
                    (vl-sort
                      res
                      (function
                        (lambda (a b)
                          (< (cdr (assoc "name" a)) (cdr (assoc "name" b)))
                          ) ;_ end of lambda
                        ) ;_ end of function
                      ) ;_ end of vl-sort
                    ) ;_ end of mapcar
                  "\n"
                  ) ;_ end of _kpblc-conv-list-to-string
                ) ;_ end of strcat
        ) ;_ end of princ
      ) ;_ end of progn
    ) ;_ end of if
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun

G-RAV · 07.09.2009, 06:15

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

Кулик Алексей aka kpblc · 07.09.2009, 08:06

Так оно все в справке описано. Правда, справка написана для VBA, но это не проблема: http://www.cad.dp.ua/stats/vla_doc.php

G-RAV · 07.09.2009, 08:11

Цитата:

Сообщение от Кулик Алексей aka kpblc

Так оно все в справке описано. Правда, справка написана для VBA, но это не проблема: http://www.cad.dp.ua/stats/vla_doc.php

ссылочка не работает

....Попробывал найти пару функций... В справке действительно все есть - это радует...

Кулик Алексей aka kpblc · 07.09.2009, 08:16

Как это "не работает"? Только что оттуда...

G-RAV · 07.09.2009, 08:44

Цитата:

Сообщение от Кулик Алексей aka kpblc

Как это "не работает"? Только что оттуда...

Меня почему-то выбрасывает! Спасибо за activex_4_rules.pdf... Очень полезная информация..

G-RAV · 09.09.2009, 15:00

Вот наконец-то доделал код, никогда не думал, что у самого получится

Правда работает в том случае, когда у блока один атрибут - с ActiveX пока тяжковато

Код:

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

(defun C:ESP (/       selset  SelEnt  tab     objekt  objektname
       NN      item    z       n       nomer   x       N$K
       N$$
      )
  (defun *error* (msg)
    (princ msg)
    (if old_cmdecho
      (setvar "cmdecho" old_cmdecho)
    )
    (if old_osmode
      (setvar "osmode" old_osmode)
    )
  )
  (setq old_cmdecho (getvar "cmdecho"))
  (setq old_osmode (getvar "osmode"))
  (setvar "cmdecho" 0)
  (setq selset (ssget '((0 . "INSERT"))))
  (cond
    ((not selset) nil)
    ((= (type selset) 'pickset)
     (repeat
       (setq tab  nil
      item (sslength selset)
       ) ;_ end setq
 (setq SelEnt  (ssname selset (setq item (1- item)))
       objekt  (entget SelEnt)
       objektname (cdr (assoc 2 objekt))
       SelEnt  (entnext SelEnt)
       NN  (cdr (assoc 1 (entget SelEnt)))
       tab  (reverse (cons (list objektname NN) tab))
 ) ;_ end of setq
 
     ) ;_ end repeat
    )
    ((listp selset) selset)
  ) ;_ end of cond
 
  (while (/= tab nil)
    (setq n 1
   z 1
   nomer nil
    )
    (while (/= (nth z tab) nil)
      (if (= (caar tab) (car (nth z tab)))
 (setq n     (1+ n)
       nomer (cons (atoi (cadr (nth z tab))) nomer)
       tab   (vl-remove (nth z tab) tab)
       z     (1- z)
 )
      )
      (setq z (1+ z))
    )
    (setq nomer (vl-sort (append (list (atoi (cadar tab))) nomer) '<))
    (setq N$$ (itoa (car nomer))
   nomer (vl-remove (car nomer) nomer)
    )
    (while (/= nomer nil)
      (setq N$K (strcat "," (itoa (car nomer))))
      (while (= (1+ (car nomer)) (cadr nomer))
 (setq N$K (strcat "..." (itoa (cadr nomer))))
 (if (and (/= (nth 2 nomer) nil)
   (= (1+ (nth 2 nomer)) (nth 3 nomer))
     )
   (setq N$K (strcat "..."
       (itoa (cadr nomer))
       ","
       (itoa (nth 2 nomer))
      )
   )
 )
 (setq nomer (vl-remove (car nomer) nomer))
      )
 
      (setq N$$ (strcat N$$ N$K))
      (setq nomer (vl-remove (car nomer) nomer))
    )
    (setvar "cmdecho" old_cmdecho)
    (setvar "osmode" old_osmode)
    (print
      (setq spisok (list (caar tab) N$$ (itoa n)))
    )
    (setq tab (vl-remove (car tab) tab))
 
  )
 
) ;_ end of defun

Кулик Алексей aka kpblc · 09.09.2009, 15:23

#27 вообще никак не пригодился?

G-RAV · 09.09.2009, 15:40

Цитата:

Сообщение от Кулик Алексей aka kpblc

#27 вообще никак не пригодился?

Я думаю, что пригодится еще, не успел до конца разобраться, не все пока понятно... Вообще в процессе разобора столько узнал о возможностях ActiveX.. Впечатлило.. Но еще и с лиспом не все понятно... Вот например функции - function, lambda, mapcar - одни из некоторых фукций, которые неподдаются моему пониманию, хотя их описание у меня перед глазами....

Будем работать...

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
LISP. Очистка рисунка от "пустых" блоков	Makswell	Готовые программы	15	26.10.2022 15:24
Обновление атрибутов всех блоков (Attsync для всех блоков)	Vildar	AutoCAD	3	18.05.2022 14:28
VBA: утечка памяти при вставке блоков	Mikha	Программирование	13	03.04.2009 09:18
Изменить параметры у всех объектов внутри блоков	800x600	AutoCAD	5	25.03.2008 14:21
Взрыв блоков	Filcarpenter	Разное	19	28.01.2007 09:57