[Archeo]

Доброго времени суток! Вопрос к уважаемому собранию. Имеется таблица примерно такого вида (см. приложенный файл). Как сделать так, чтобы:
– во-первых, прямоугольники с заливкой были неотъемлемой частью таблицы (блоком или ещё как?);
– во-вторых, цвет заливки прямоугольника в таблице автоматически менялся бы при изменении цвета того объекта в модели, которому он соответствует (допустим, участка стены);
– в-третьих, менялся бы и индекс цвета (например, RAL 9003 на RAL 8015).
Фасады в модели двумерные.
Заранее благодарен.
PS. Заливать цветом всю ячейку таблицы нежелательно.
PPS. По поводу второго пункта только что пришла в голову такая мысль. А что если в лэйауте с таблицей насоздавать маленьких вьюпортов одинакового размера, расположить их в нужных местах таблицы, и каждый такой вьюпорт открывать в соответствующее место объекта в модели (масштаб ВП должен быть, наверное, достаточно крупным)? То есть всё то же окно из лэйаута в модель, но смотрим мы только на цвет объекта. Вьюпорт, правда, всё равно получится невстроенным в таблицу. Но зато цвет будет меняться, как мне надо. Как вам такое решение? Или оно уж слишком оригинальное?
[ATTACH]1149339910.dwg[/ATTACH]

[Archeo]

Шквал советов... Гуры, где вы? В частности, очень хотелось бы узнать мнение Vova по данному вопросу.
Вьюпорты сделал; работают, естественно, и цвет меняется, как положено. Неужели это единственное решение? И вопрос-то ведь не абстрактный, а на 100% связанный с реальной практикой.

[Лентяй]

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

[Vova]

Сообщение от Archeo Шквал советов... Гуры, где вы? В частности, очень хотелось бы узнать мнение Vova по данному вопросу.

Sorry, сейчас крайне некогда. Отец в больнице.

[asys]

– во-первых, прямоугольники с заливкой были неотъемлемой частью таблицы (блоком или ещё как?);

в ячейку таблицы можно вставить блок. Любой

– во-вторых, цвет заливки прямоугольника в таблице автоматически менялся бы при изменении цвета того объекта в модели, которому он соответствует (допустим, участка стены);

текстовую информацию - можно полями связать, а вот цвет поля не передают, только индекс цвета могут показать. Опять же как текстовую информацию

– в-третьих, менялся бы и индекс цвета (например, RAL 9003 на RAL 8015).

Если тебя интересует индекс как текст - см. выше. Через вставку поля которое читает в совйствах заливки этот индекс.
Получается что идея с vports-ами единственное решение. Попробовал vport в блок положить и в ячейку вставить - vport в блоке не показывает свое содержимое

[Archeo]

>Лентяй, Vova, Asys Спасибо всем!
>Vova Понимаю... Мне не срочно, время терпит.
>Лентяй Выкладываю. Фасады кидаю тоже, мне не жалко. Заодно, может, и по ним какое мнение услышу... Это всё по т. н. Программе возрождения села (агрогородки и т. п., может, слыхали?). Хотят почти бесплатно из ***** конфетку сделать. Хорошо, если их вообще станут красить.
В таблице соответствия - только цвета, использованные в чертеже (из них два - не "чистый" RAL, а разбелы. С этими что делать?). Лишние лэйауты выкинул; если заливка прёт вперёд - draworder.
[ATTACH]1149694906.dwg[/ATTACH]

[Лентяй]

> Archeo
Ну вот, наваял, вроде работает. Обработчика ошибок, правда нет, ибо лениво, да и прочие знатоки щач ринутся на готовенькое улучшать до бесконечности :twisted: . Прога работает небыстро, но да ничего Пользуйтесь на здоровье, да не забывайте сугубо и трегубо благодарить меня, любимого, за то, что я есть.

Код:

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

(defun FndTbl ( / obj)
  (setq ps (vla-get-paperspace adoc))
  (vlax-for obj ps (if (= (vla-get-ObjectName obj) "AcDbTable") (setq tbl obj)))
);tbl
;
(defun C:ClrTbl ( / adoc lrs ass lts alt ps cpt tbl tln tls HitRes row col ccd)
  (vl-load-com)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (mapcar '(lambda (x y) (set x (vlax-get-property adoc y))) '(lrs ass lts alt)
    '(Layers ActiveSelectionset Layouts ActiveLayout))
  (if (> (vla-get-count ass) 0) (vla-clear ass)) 
  (if (apply 'and (mapcar '(lambda (x)
             (vl-catch-all-error-p (vl-catch-all-apply 'vla-item (list lts x))))
                    '("Passport" "TABLE")));apply
    (progn (alert "Лист(ы) 'Паспорт' и/или 'TABLE' не обнаружен(ы)! \nСоздай Лист(ы) и начни снова!")
      (quit))
    (vla-put-ActiveLayout adoc (vla-item lts "TABLE")));if
  (FndTbl) (setq row 2)
  (while (<= row (vla-get-rows tbl))
    (setq tln (mapcar '(lambda (x) (vla-getText tbl row x)) '(1 0))
          tls (cons tln tls) row (1+ row)));while
  (vla-put-ActiveLayout adoc (vla-item lts "Passport"))
  (setq ps (vla-get-paperspace adoc))
  (FndTbl)
  (vlax-for vp ps (if (= (vla-get-ObjectName vp) "AcDbViewport") (progn
        (setq cpt (vlax-get vp 'center))
        (vla-put-MSpace adoc :vlax-true)
        (if (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-ActivePViewport (list adoc vp))))
          (vla-SelectAtPoint ass (vlax-3d-point (trans cpt 3 2))))         
        (if (= (vla-get-count ass) 1) (setq it (vla-item ass 0)))
        (setq RGB (mapcar '(lambda (x) (vlax-get-property (vla-get-TrueColor
                   (if (= (vla-get-color it) 256) (vla-item lrs (vla-get-layer it)) it)) x))
                    '(Red Green Blue))
              HitRes (vla-HitTest tbl (vlax-3d-point cpt) (vlax-3D-Point '(0.0 0.0 1.0)) 'Row 'Col))
        (while RGB (setq ccd (if (null ccd) (itoa (car RGB)) (strcat ccd "," (itoa (car RGB))))
                         RGB (cdr RGB)))
        (if (= HitRes :vlax-true) (vla-setText tbl row (- col 2) (cadr (assoc ccd tls))))
        (setq ccd nil) (vla-clear ass)));if
    );vlax-for
  (vla-regen adoc acAllViewports)
  (alert "Регенерация закончена")
  (vla-put-MSpace adoc :vlax-false) (vla-put-Activelayout adoc alt)
);end

[asys]

>Лентяй
1. Вызов идет командой CLRTBL ?
2. После ввода команды CLRTBL выдает окно :?
[ATTACH]1149843655.jpg[/ATTACH]

[Лентяй]

Сообщение от Asys >Лентяй 1. Вызов идет командой CLRTBL ?

Именно так.

2. После ввода команды CLRTBL выдает окно :? [ATTACH]1149843655.jpg[/ATTACH]

Ну, и какая же именно строка вам не понятна [sm2100] ?

[asys]

>Лентяй так врет окошко, и листы наделал и table-ы и даже layout с именем "паспорт" сделал - ни фига

[Лентяй]

Сообщение от Asys >Лентяй так врет окошко, и листы наделал и table-ы и даже layout с именем "паспорт" сделал - ни фига

Вот теперь понятнее. Дело в том, что прогу я писал под чертеж, выложенный Archeo, а у него оба листа названы не по-русску, а вовсе даже по бусурмански. А потому - переименуйте свои листы в "Passport" и "TABLE" соот-но и потом доложьте нам о достигнутых успехах.

[asys]

теперь так:

Код:

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

Command: CLRTBL
; error: Automation Error. Key not found

P.s. меня на "ты" пожалуйста

[Archeo]

>Лентяй Спасибо! Вот только есть ещё одна проблемка. Я... э-э-э... как бы это сказать помягче... не вполне представляю себе, а что же делать с этим замечательным кодом, чтобы оценить его по достоинству?
>Всем Просьба не биться, а, если не трудно, потратить ещё кусочек своего времени и рассказать несведущему в этом вопросе. Копируем код, вставляем его в текстовый документ, присваиваем расширение .lsp? Да? Нет? А дальше что? А то человек делал, старался, а я не в курсе, как облечь это в рабочую форму...

[Лентяй]

>Archeo
Нет ничего проще. Открываете АвтоКАД, в меню "Инструменты" (Tools) открываете "Редактор VLISP" (Visual LISP Editor). В этом редакторе открываете новое окно, куда и копирутете код.

Код:

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

(defun FndTbl ( / obj)
  (setq ps (vla-get-paperspace adoc))
  (vlax-for obj ps (if (= (vla-get-ObjectName obj) "AcDbTable") (setq tbl obj)))
);tbl
;
(defun C:ClrTbl ( / adoc lrs ass lts alt ps cpt tbl tln tls HitRes row col ccd)
  (vl-load-com)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (mapcar '(lambda (x y) (set x (vlax-get-property adoc y))) '(lrs ass lts alt)
    '(Layers ActiveSelectionset Layouts ActiveLayout))
  (if (> (vla-get-count ass) 0) (vla-clear ass)) 
  (if (apply 'and (mapcar '(lambda (x)
             (vl-catch-all-error-p (vl-catch-all-apply 'vla-item (list lts x))))
                    '("Passport" "TABLE")));apply
    (progn (alert "Лист(ы) 'Паспорт' и/или 'TABLE' не обнаружен(ы)! \nСоздай Лист(ы) и начни снова!")
      (quit))
    (vla-put-ActiveLayout adoc (vla-item lts "TABLE")));if
  (FndTbl) (setq row 2)
  (while (<= row (vla-get-rows tbl))
    (setq tln (mapcar '(lambda (x) (vla-getText tbl row x)) '(1 0))
          tls (cons tln tls) row (1+ row)));while
  (vla-put-ActiveLayout adoc (vla-item lts "Passport"))
  (setq ps (vla-get-paperspace adoc))
  (FndTbl)
  (vlax-for vp ps (if (= (vla-get-ObjectName vp) "AcDbViewport") (progn
        (setq cpt (vlax-get vp 'center))
        (vla-put-MSpace adoc :vlax-true)
        (if (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-ActivePViewport (list adoc vp))))
          (vla-SelectAtPoint ass (vlax-3d-point (trans cpt 3 2)))          
        (if (= (vla-get-count ass) 1) (progn
          (setq it (vla-item ass 0)
                RGB (mapcar '(lambda (x) (vlax-get-property (vla-get-TrueColor
                   (if (= (vla-get-color it) 256) (vla-item lrs (vla-get-layer it)) it)) x))
                    '(Red Green Blue))
                HitRes (vla-HitTest tbl (vlax-3d-point cpt) (vlax-3D-Point '(0.0 0.0 1.0)) 'Row 'Col))
          (while RGB (setq ccd (if (null ccd) (itoa (car RGB)) (strcat ccd "," (itoa (car RGB))))
                         RGB (cdr RGB)))
          (if (= HitRes :vlax-true) (vla-setText tbl row (- col 2) (cadr (assoc ccd tls))))
        ));if
        (setq ccd nil) (vla-clear ass)));if
    );vlax-for
  (vla-regen adoc acAllViewports)
  (alert "Регенерация закончена")
  (vla-put-MSpace adoc :vlax-false) (vla-put-Activelayout adoc alt)
);end

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


>Asys
Попробуй код выше. Введена проверка на нахождение примитива, потому как не всегда это происходит. Вот почему так - не знаю [sm2100]. МБ, коллектив подскажет. [sm1400]

[asys]

вот

Код:

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

Command: APPLOAD
FndTbl.lsp successfully loaded.

закрываю окно appload-a

Command: ; error: malformed list on input

Command:
Command: ClrTbl
Unknown command "CLRTBL".  Press F1 for help.

Жалко, такой труд пропадает

[Лентяй]

Ну, не зочет оно, сцуко, выбираться в точку, где велено [sm1212] ! Потому я сделал другой вариант. как Archeo предлагал в начале - выбирается штриховка, и в таблице появляется ее цвет с соотв. имененм. Предлагаю на растерзание.

Код:

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

(defun FndTbl ( / obj)
  (setq ps (vla-get-paperspace adoc))
  (vlax-for obj ps (if (= (vla-get-ObjectName obj) "AcDbTable") (setq tbl obj)))
);tbl
;
(defun C:ClrTbl ( / adoc lrs ass lts alt ps clr RGB clrs tbl tln tls kw HitRes row col ccd)
  (vl-load-com)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (mapcar '(lambda (x y) (set x (vlax-get-property adoc y))) '(lrs ass lts alt util)
    '(Layers ActiveSelectionset Layouts ActiveLayout Utility))
  (if (> (vla-get-count ass) 0) (vla-clear ass)) 
  (if (apply 'and (mapcar '(lambda (x)
             (vl-catch-all-error-p (vl-catch-all-apply 'vla-item (list lts x))))
                    '("Passport" "TABLE")));apply
    (progn (alert "Лист(ы) 'Паспорт' и/или 'TABLE' не обнаружен(ы)! \nСоздай Лист(ы) и начни снова!")
      (quit))
    (vla-put-ActiveLayout adoc (vla-item lts "TABLE")));if
  (FndTbl) (setq row 2)
  (while (<= row (vla-get-rows tbl))
    (setq tln (mapcar '(lambda (x) (vla-getText tbl row x)) '(1 0))
          tls (cons tln tls) row (1+ row)));while
  (vla-put-ActiveSpace adoc 1)
  (vla-SelectOnScreen ass (vlax-safearray-fill (vlax-make-safearray vlax-vbinteger '(0 . 0)) '(0)) 
    (vlax-safearray-fill (vlax-make-safearray vlax-vbvariant '(0 . 0)) (list "*Hatch")))
  (if (>= (vla-get-count ass) 1) (vlax-for it ass
      (setq clr (vla-get-TrueColor (if (= (vla-get-color it) 256) (vla-item lrs (vla-get-layer it)) it))
            RGB (mapcar '(lambda (x) (vlax-get-property clr x)) '(Red Green Blue))
            clrs (cons (list clr RGB) clrs))));if
  (vla-put-ActiveLayout adoc (vla-item lts "Passport"))
  (FndTbl)
  (vla-InitializeUserInput util 128 "Да Нет")
  (setq kw (vla-getKeyWord util "Заполнить таблицу [Да/Нет]: ? <Да>"))
  (if (= kw "") (setq kw "Да"))
  (if (= kw "Да") (progn
      (setq HitRes (vla-HitTest tbl (vla-getpoint util nil "\nВыбери начальный ряд: ") (vlax-3D-Point '(0.0 0.0 1.0)) 'row 'col))
      (if (= HitRes :vlax-true) (progn
        (while (and clrs (< row (vla-get-Rows tbl)))
          (vla-setCellBackgroundColorNone tbl row 5 :vlax-false)
          (vla-setCellBackgroundColor tbl row 5 (caar clrs))
          (setq RGB (cadar clrs))
          (while RGB (setq ccd (if (null ccd) (itoa (car RGB)) (strcat ccd "," (itoa (car RGB))))
                           RGB (cdr RGB)))
           (vla-setText tbl row 3 (cadr (assoc ccd tls)))
          (setq clrs (cdr clrs) ccd nil row (1+ row)))
        (if clrs (alert "Недостаточно рядов! \nДополни таблицу!")));progn
    (alert "Точка вне пределов таблицы!"))));if
(vla-clear ass) (vla-put-Activelayout adoc alt)
);end

[asys]

Код отлично работает, но только в файле который Archeo выложил, в произвольном пишет вон ниже. Я таблицу даже скопировал и обозвал layout-ы, все равно не хочет.

Код:

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

 Command: ClrTbl
; error: Automation Error. Key not found

[Лентяй]

Сообщение от Asys Код отлично работает, но только в файле который Archeo выложил,

Ну, ты даешь! [sm1012] Я, по-твоему, под какой файл код писал?

в произвольном пишет вон ниже. Я таблицу даже скопировал и обозвал layout-ы, все равно не хочет. Код: [Выделить все] Command: ClrTbl ; error: Automation Error. Key not found

Ну, клади свой - я посмотрю, в чем разница. К слову, на разных компах последний столбей имеет разные номера - 5 и 6 соот-но.

[asys]

Ну, ты даешь! Я, по-твоему, под какой файл код писал?

я понял что под него но это и накладывает большие ограничения на применение програмки. Мне нравится идея, но точить ее под чей-то стандарт - :? Свой не дам потому что не могу точно сказать как будет называться layout, какой из шаблонов применен и вообще что завтра будет Если никак без привязки к имени ляута и свойствам таблицы, можешь небольшую инструкцию написать какое имя в коде надо заменить и на какое?

p.s. да, еще можно ли сделать чтоб имя цвета заливки вставлялось полем в ячейку?

[Лентяй]

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

Код:

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

(defun FndTbl (name / obj)
  (vla-put-ActiveLayout adoc (vla-item lts name))
  (setq ps (vla-get-paperspace adoc)) 
  (vlax-for obj ps (if (= (vla-get-ObjectName obj) "AcDbTable") (setq tbl obj))) 
);tbl
;
(defun fillit ( / RGB ccd)
  (setq RGB (cadar clrs))
  (while RGB (setq ccd (strcat (if (null ccd) "" (strcat ccd ",")) (itoa (car RGB)))
                   RGB (cdr RGB)))
  (vla-setCellBackgroundColorNone tbl row 5 :vlax-false)
  (vla-setCellBackgroundColor tbl row 5 (caar clrs))
  (vla-setText tbl row 3 (cadr (assoc ccd tls)))
  (setq ccd nil clrs (cdr clrs))
);fillit
;
(defun C:ClrTbl ( / adoc lrs ass lts alt ps cps pts clrs tbl tln tls row col) 
  (vl-load-com) 
  (setq adoc (vla-get-activedocument (vlax-get-acad-object))) 
  (mapcar '(lambda (x y) (set x (vlax-get-property adoc y))) '(lrs ass lts alt util) 
    '(Layers ActiveSelectionset Layouts ActiveLayout Utility)) 
  (if (> (vla-get-count ass) 0) (vla-clear ass)) 
  (if (apply 'and (mapcar '(lambda (x) 
             (vl-catch-all-error-p (vl-catch-all-apply 'vla-item (list lts x)))) 
                    '("Passport" "TABLE")));apply
    (progn (alert "Лист(ы) 'Паспорт' и/или 'TABLE' не обнаружен(ы)! \nСоздай Лист(ы) и начни снова!") 
      (quit)));if
  (FndTbl "TABLE") (setq row 2) 
  (while (<= row (vla-get-rows tbl)) 
    (setq tln (mapcar '(lambda (x) (vla-getText tbl row x)) '(1 0)) 
          tls (cons tln tls) row (1+ row)));while
  (vla-put-ActiveSpace adoc acModelSpace)
  (vla-SelectOnScreen ass (vlax-safearray-fill (vlax-make-safearray vlax-vbinteger '(0 . 0)) '(0))
    (vlax-safearray-fill (vlax-make-safearray vlax-vbvariant '(0 . 0)) (list "*Hatch")))
  (vlax-for it ass
    (setq clr (vla-get-TrueColor (if (= (vla-get-color it) 256) (vla-item lrs (vla-get-layer it)) it))
	  RGB (mapcar '(lambda (x) (vlax-get-property clr x)) '(Red Green Blue))
	  clrs (cons (list clr RGB) clrs)));vlax-for
  (FndTbl "Passport")
  (vla-InitializeUserInput util 128 "Таблица Строка")
  (setq kw (vla-getKeyWord util "Заполнить Таблицу или отдельные Строки [Таблица/Строка]: ? <Таблица>"))
  (if (= kw "") (setq kw "Таблица"))
  (if (= kw "Таблица")
      (if (= (vla-HitTest tbl (vla-getpoint util nil "Выбрать начальную строку: ")
               (vlax-3D-Point '(0.0 0.0 1.0)) 'row 'col) :vlax-true)
        (progn (while (and clrs (< row (vla-get-Rows tbl)))
          (fillit) (setq row (1+ row)));while
          (if clrs (alert "Недостаточно строк! Дополнить таблицу")));progn
        (alert "Точка вне таблицы!"));if
    (progn 
      (while (not (vl-catch-all-error-p (vl-catch-all-apply '(lambda ()
                 (setq pts (cons (vla-getPoint util nil "Выбрать строку: ") pts)))))) pts)
      (foreach pt pts (if clrs
          (if (= (vla-HitTest tbl pt (vlax-3D-Point '(0.0 0.0 1.0)) 'row 'col) :vlax-true)
            (fillit))));foreach
      (if clrs (alert "Недостаточно строк! Дополнить таблицу"))));if
  (vla-clear ass) (vla-put-Activelayout adoc alt) 
);end

Теперь о настройках.
1. ОБЯЗАТЕЛЬНО создай два листа (layouts) "Passport" и "TABLE". Если имена другие, то нужно пeреписать имена листов в команде (FndTbl " "). Впрочем, без листа "TABLE" можно обойтись, если заменить его текстовым файлом, в котором каждая строка - имя и код цвета. Но тогда нужно переписать соотв. кусок программы.
2. Форма таблиц должна быть, как у Archeo. Если это не так, то нужно заменить на "правильные" целые числа в строках, начинающихся с vla-setCell и vla-setText - это номера столбцов в таблицах. Учти, что первый номер - 0.

p.s. да, еще можно ли сделать чтоб имя цвета заливки вставлялось полем в ячейку?

Можно, но за отдельные деньги А если серьезно, то если цвет именованый, то нет проблем, а если он ByLayer - тады ой.