[Wertgan]

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

Код:

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

 ;----------
(defun dtr (a) (* pi (/ a 180.0)));
(defun rtd (r) (/ (* r 180.0) pi));
;---MNO_MET blok secimi---- 
(defun BL_BUL_room_3 (/ bos bl-ss adet n)
  (prompt "\n Выберите данные для составления списка.")
  (setq bl-ss (ssget (list (cons 2 "room_3")))); выбор и создание списка из блоков
  (setq ob-liste bos)
  (setq adet (sslength bl-ss)); определение количества блоков
  (setq n 0)
  (while (< n adet)
   (setq n-ob (ssname bl-ss n)) ;присваивание им номеров
   (if (listp ob-liste)(setq ob-liste (append ob-liste (list n-ob)))
       (setq ob-liste (list n-ob))
   );if
   (setq n (+ n 1)); цикл добавления номеров
  );while
);defun
;-------------------------
(defun cevir (/ obje-m obje-n liste-ms liste-mo liste-mons liste-mono)
         (setq obje-m (nth (- m 1) ob-liste)); выбор соответствующего блока из списка блоков
         (setq obje-n (nth (- n 1) ob-liste))
         (setq liste-ms (cdr (member obje-m ob-liste)))
         (setq liste-mo (reverse (cdr(member obje-m (reverse ob-liste)))))
	 (setq liste-mons (member obje-n liste-mo))
	 (setq liste-mono (reverse (member obje-n (reverse liste-mo))))
         (setq liste-mono (subst obje-m obje-n liste-mono))
         (setq liste-mo (append liste-mono liste-mons))
         (setq ob-liste (append liste-mo liste-ms))
         (princ ">")

         (princ)
         (setq n (- n 1))
         (setq m adet)
) ;;;defun
;
(defun KKON (kar)
  (setq K "harf" R "rakam")
  (cond ((= kar 0) (setq kson 0)) ; bos
        ((or (< kar 48) (> kar 57)) (setq kson K)) ;karakter
        ((or (> kar 47) (< kar 58)) (setq kson R)) ;rakam (0 1 2 3 4 5 6 7 8 9)
        (T)
  )
)
;----------------
(defun MLIS_room_3 (/ n m adet kts-ad kts n1k n2k n3k n4k m1k m2k m3k m4k n-mn m1 m2 m3 m4 n1 n2 n3 n4)
                 
      (BL_BUL_room_3)
      (setq n 1)
      (setq m 1)
  
      (setq adet (length ob-liste))
  
      (setq kts-ad (* adet adet) kts 1)
      (prompt (strcat (rtos adet 2 0) " Выбор принят. "))
      (prompt " Построение данных завершено. ")

      (princ "+")
      (princ kts)
      (princ)
);defun
;----------------
(defun myaz_room_3 (/ yernok basnok os-mode adet n att1 att2  cevre)
    (setq os-mode (getvar "osmode"))
    ;(setvar "osmode" 0)
    (setq adet (length ob-liste))
  
    (setq mscale (getreal "\n Укажите масштаб чертежа : "));Масштабный коэффициент
    (setq basnok (getpoint '(0.0 0.0) "\n Укажите точку для вставки таблицы (левый верхний угол)."))


    (setvar "osmode" 0)
    (setvar "cecolor" "bylayer" ); 

  (setq yernok basnok)

    (command "layer" "m" "ROOM TABLE" "")
    (command "STYLE" "SIMPLEX" "SIMPLEX" 0 0.7 0 "N" "N" "N")
    (setq n 0)
  
    (while (< n adet)
      (setq att1  (cdr(assoc 1(entget(entnext(nth  n ob-liste  ))))));
      (setq att2  (cdr(assoc 1(entget(entnext(entnext(nth n ob-liste)))))))
      (setq yernok basnok)

      (setq yernok (polar yernok 0 (* 1.5 mscale))) ; Установка начала строки
      (setq yernok (polar yernok -90 (* 2 mscale))) ; Половина высоты строки 

      (command "TEXT" "J" "ML" yernok (* 2.0 mscale) 0 att2);
      (setq yernok (polar yernok 0 (* 11.5 mscale)));

      (command "TEXT" "J" "ML" yernok (* 2.0 mscale) 0 att1);
      (setq yernok (polar yernok 0 (* 60 mscale)));
      
      (setq basnok (polar basnok (dtr 270) (* 4 mscale))); 
      (setq n (+ n 1))
    );while


  (setvar "osmode" 687);
  (setvar "cecolor" "bylayer" ); 
  
);defun
;----------
(defun c:ml3 ()
(mlis_room_3)
(myaz_room_3)
)

[Frigate]

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

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

[Олег (jr.)]

Открой lsp файл в Блокноте и копируй оттуда а не из VLisp-редактора

[VVA]

Wertgan, Если хочешь быстрый ответ, то дай пример списка (списков), которые ты получаешь и пример в каком виде их хочешь получить в итоге.

[Wertgan]

Вот так хотелось бы (это собственно для экспликции помещений) : Нижнее подчеркивания - это вместо пробелов))
______________________________________________
Марка_ Площадь, м2
_______________________________________________
А.02.12.02______ 24
А.02.12.12______ 12
Б.03.02.01______ 23
Б.04.02.12______16
___________________________________________________

А делает вот так
Сортировка по марке (это первый атрибут в блоке) отсутствует ((
Б.04.02.12_____ 16
А.02.12.12_____ 12
А.02.12.02_____ 24
Б.03.02.01_____ 23
_____________________________
Собственно программа может выводить в столбики значения атрибутов из блоков с любым именем,( надо только убрать фильтр на ssget) и выводить любые атрибуты. Их порядок извлечения в см. возле переменных att1 и att2
Вот у меня загвоздка с правильной сортировкой по первому столбцу - это att1 - первый атрибут блока

[Олег (jr.)]

В зависимости от вида субсписков - два варианта:

Код:

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

 ;;;Простые списки
 
(setq alst1
       '(("А.02.12.02" 24)
	 ("Б.03.02.01" 23)
	 ("Б.04.02.12" 16)
	 ("А.02.12.12" 12)
	 ))
(setq sorted1
       (vl-sort
	 alst1
	 (function (lambda (a b)
		     (and (<= (ascii (substr (car a) 1 1))
			      (ascii (substr (car b) 1 1)))
			  (< (car a)
			     (car b)))))))

Код:

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

 ;;;Точечные пары

(setq alst2 '(("А.02.12.02" . 24)
	      ("Б.03.02.01" . 23)
	      ("Б.04.02.12" . 16)
	      ("А.02.12.12" . 12)
	      ))
(setq sorted2
       (vl-sort
	 alst2
	 (function (lambda (a b)
		     (and (<= (ascii (substr (car a) 1 1))
			      (ascii (substr (car b) 1 1)))
			  (< (car a)
			     (car b)))))))

[Wertgan]

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

[VVA]

Ну и мой вариант. Я предположил, что имеется 2 списка. lst_att1 - для атрибутов att1 и lst_att2 для атрибутов att2

Код:

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

(setq lst_att1 '("Б.04.02.12" "А.02.12.12" "А.02.12.02" "Б.03.02.01"))
(setq lst_att2 '(16 12 24 23))

(setq lst-idx (SortStringWithNumberAsNumber-i lst_att1 t))
(setq lst_att1 (mapcar '(lambda (x) (nth x lst_att1)) lst-idx))
(setq lst_att2 (mapcar '(lambda (x) (nth x lst_att2)) lst-idx))

Ну и функция

Код:

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

(defun SortStringWithNumberAsNumber-i (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
  (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)))
  (vl-sort-i NorStrs '<)
)

[Wertgan]

Спасибо, )

[kakt00z]

подниму эту тему еще раз, т.к. ничего ближе не нашел
нужно изменить порядок следования аттрибутов в контейнере блока - отсортировать например по алфавиту TagString
пишу такой код (для любого блока с кол-вом аттрибутов > 1 ) :

Код:

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

 (setq obj (vlax-ename->vla-object (car (entsel))))
(setq blk (vla-item (vla-get-blocks #actdoc) (vla-get-EffectiveName obj)))
(setq exd (vla-getExtensionDictionary blk))
(setq sortEnsTable (vla-item exd 0))
(vla-GetFullDrawOrder sortEnsTable 'FDO :vlax-true)
(setq FDO (vlax-safearray->list FDO))

далее смотрю последовательность объектов в контейнере:

Код:

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

   (mapcar
    '(lambda (x / on tag)
       (setq on (vla-get-ObjectName x))
       (if (= "AcDbAttributeDefinition" on)  (setq tag (vla-get-TagString x)) (setq tag ""))
       (list on tag)
       )
    FDO)

далее пробую "переместить" аттрибут

Код:

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

   (setq TagString "NIPPLE")
  (if (= 1 (length (setq att (vl-remove-if-not '(lambda (x) (and (= "AcDbAttributeDefinition" (vla-get-ObjectName x)) (= TagString (vla-get-tagstring x)))) (cont>list blk)))))
    (setq att (car att))
    )

  (setq sa (vlax-make-safearray vlax-vbObject '(0 . 0)))
  ;(vlax-safearray->list sa)
  (vlax-safearray-put-element sa 0 att)
  ;(vlax-safearray->list sa)
  (vla-MoveToTop sortEnsTable sa)

в итоге, если смотреть еще раз последовательность так, как я описал чуть выше - то все ок, меняется, НО в окне "properties" - изменений не происходит
как сделать аналог результата BATTMAN ?

[VVA]

Мне кажется это разные вещи. Ты управляешь порядком прорисовки, как команда ПОРЯДОК
А в окне свойств последовательность отображается в порядке создания блока
Почему бы не пересоздать блок под тем же именем с нужным порядком атрибутов?

[kakt00z]

ну... ситуация такая:
когда меняешь последовательность посредством BATTMAN - поля, которые ссылаются на атрибуты (ID) экземпляра целевого блока - просто {как бы меняются местами} - то есть новых объектов - не создается, а если переопределить блок - естественно - все поля "полетят"
если sortEntsTable - не то, то куда копать?
....
и, было как-то, пробовал таким вот образом поменять последовательность, и потом в определенном порядке "проапдейтить" документ, + вродебы сохранить в dxf и переоткрыть (какой-то такой бубен) и получалось таки в итоге )
такое чувство что что-то упускаю
__________________________________________________________________________
и так, буду отвечать сам себе
проанализировал ситуацию таким вот кодом

Код:

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

 (setq obj (vlax-ename->vla-object (car (entsel))))
(setq blk (vla-item (vla-get-blocks #actdoc) (vla-get-EffectiveName obj)))
(setq eblk (vlax-vla-object->ename blk))
(entget (setq blbegin (cdr (assoc 360 (member '(100 . "AcDbBlockTableRecord") (entget eblk))))))

(setq el '())
(setq tmp blbegin)
(while tmp
  (setq el (cons tmp el))
  (setq tmp (entnext tmp))
  )
(length el)
(setq ael (vl-remove-if-not '(lambda (x) (= "ATTDEF" (cdr (assoc 0 (entget x)))) ) el))
;(entget (car ael))

(mapcar
  '(lambda (x)
     (list
       (cdr (assoc -1 (entget x)))
       (cdr (assoc 5 (entget x)))
       (cdr (assoc 2 (entget x)))
       )
     )
  ael)

сохранил результат, потом battman'ом передвинул пару аттрибутов и выяснилось, что сами объекты "AcDbAttributeDefinition" никак не перетосовываются, их последовательно остается такой же, а меняются просто свойства - tagString и все остальные
вроде бы все просто, но с точки зрения ООП (с инженерной стороны) мне этот факт слегка взорвал мозг

для подтверждения - небольшой тест-код - установка порядка аттрибутов "как на чертеже сверху вниз"

Код:

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

 (defun c:asd ( / obj blk attdefs mtaproplist proplist )
  (setq obj (vlax-ename->vla-object (car (entsel))))
  (setq blk (vla-item (vla-get-blocks #actdoc) (vla-get-EffectiveName obj)))
  (setq attdefs (vl-remove-if-not (function (lambda (x) (= "AcDbAttributeDefinition" (vla-get-objectname x)))) (cont>list blk)))
  ;(do (car attdefs))

  (setq mtaproplist
       '(
	 "MTextAttributeContent"
	 "MTextBoundaryWidth"
	 "MTextDrawingDirection"
	)
)
(setq proplist
       '("MTextAttribute" "Alignment" "Backward" "Constant"
	 "EntityTransparency" "Height" "InsertionPoint"	"Invisible"
	 "Layer" "Linetype" "LinetypeScale" "Lineweight" "LockPosition"
	 "Material" "Mode" "Normal" "ObliqueAngle" ;"PlotStyleName"
	 "Preset" "PromptString" "Rotation" "ScaleFactor" "StyleName"
	 "TagString" "TextAlignmentPoint" ;"TextGenerationFlag"
	 "TextString" "Thickness" "TrueColor" "UpsideDown" "Verify"
	 "Visible"
	 )
      )
  (setq
    propvals
     (mapcar
       '(lambda (attdef)
	  (mapcar
	  '(lambda (p)
	     (list
	       p
	       (eval
		 (list
		   (read (strcat "vla-get-" p))
		   attdef
		   )
		 )
	       )
	     )

	  (if (= (vla-get-MTextAttribute attdef) :vlax-false)
	    proplist
	    (concat proplist mtaproplist)
	    )
	  )
	)
     attdefs
     )
  )
  ;;  определение порядка
  (setq propvals
	 (vl-sort propvals
		  '(lambda (pv1 pv2)
		     (>
		       (cadr (vlax-safearray->list (vlax-variant-value (cadr (assoc "InsertionPoint" pv1)))))
		       (cadr (vlax-safearray->list (vlax-variant-value (cadr (assoc "InsertionPoint" pv2)))))
		       )
		     )
		  ))


(mapcar
  '(lambda (ado pvs)
     (mapcar
       '(lambda (pv)	;(setq pv (car (car propvals)))
	  (eval
	    (list
	      (read (strcat "vla-put-" (car pv)))
	      ado
	      (cadr pv)
	      )
	    )
	  
	  )
       pvs
       )
     )
  attdefs propvals
  )
  );defun