Schöck
Показать сообщение отдельно
 
Непрочитано 27.07.2010, 10:17
#66
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,800
<phrase 1= Отправить сообщение для VVA с помощью Skype™


Цитата:
Сообщение от Павлов Андрей Посмотреть сообщение
можно ли сделать так , чтобы - указал как перемещаться , например по столбцам , ткнул в ячейку таблицы , а примитивы указывать не по одному , а рамкой ?
Можно
Код:
[Выделить все]
;  Команда: MAREATT (Multiple AREA To Table)
;  posted http://dwg.ru/f/showthread.php?t=14528
;  Эта команда позволяет вставлять начиная с указанной ячейки таблицы
;  текст с полем (FIELD), содержащее значение площади выбранного контура.
;  В зависимости от выбора, навигация по таблице идет по строкам или столбцам.
;  Если стороки или столбцы заканчиваются, то они автоматически добавляются.
;  Форматирование ячейки берется как у первой указанной.
;  Точность округления и масштабный коэффициент настраиваются через опцию Установки
;  Так как это поле связано с конкретным объектом, то при изменении
;  объекта поле пересчитывается (необходимо обновление поля)
;  Код можно сохранить в файле mareatt.lsp
;  Возможный макрос для кнопки или пункта меню:
;  ^C^C(if (not C:MAREATT)(load "MAREATT"));MAREATT;

(defun C:MAREATT ( / en obj tblobj row col lst pt rows cols what fld ss)
  (vl-load-com)
  (or *SCALE* (setq *SCALE* 1))
  (or *PREC* (setq *PREC* 2))
  (or *TEXTSIZE* (setq *TEXTSIZE* (getvar "TEXTSIZE")))
  (or *SUFF* (setq *SUFF* ""))(or *PREF* (setq *PREF* ""))
  (setq *SUFF* (vl-princ-to-string *SUFF*))
  (setq *PREF* (vl-princ-to-string *PREF*))
  (princ "\nТекущий масштаб = ")(princ *SCALE*)
  (princ " Текущая точность округления = ")(princ *PREC*)
  (princ " Высота текста = ")(princ *TEXTSIZE*)
  (princ " Префикс= ")(princ *PREF*)(princ " Суффикс= ")(princ *SUFF*)
  (setq  tblobj nil tblobj (ssget "_X" (list '(0 . "ACAD_TABLE")(cons 410 (getvar "CTAB")))))
  (setq lst (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex tblobj)))))
  (setq  tblobj nil)
  (cond
   ((and lst
         (or (initget "Row Col Setting стРоки сТолбцы Установки _Row Col Setting Row Col Setting") t)
         (or (while (=(setq what (getkword "\nПеремещаться [по стРокам/по сТолбцам/Установки] <по сТолбцам>: "))
                      "Setting")
                     (princ "\nНовый масштабный коэффициент <")(princ *SCALE*)(princ "> : ")
      (initget 6)
      (if (setq en (getdist))(setq *SCALE* en))
      (princ "\nТочность округления <")(princ *PREC*)(princ "> : ")
      (initget 4)
      (if (setq en (getint))(setq *PREC* en))
      (princ "\nВысота текста <")(princ *TEXTSIZE*)(princ "> : ")
      (initget 6)
      (if (setq en (getdist))(setq *TEXTSIZE* en))
      (princ "\nПрефикс (пробел - очистить) <")(princ *PREF*)(princ "> : ")
      (if (= (setq en (getstring t)) " ")(setq en ""))
      (if (= (substr (vl-string-left-trim "\/" en) 1 2) "U+")
      (setq en (strcat "\\" (vl-string-left-trim "\/" en))))(setq *PREF* en)
      (princ "\nСуффикс (пробел - очистить) <")(princ *SUFF*)(princ "> : ")
      (if (= (setq en (getstring t)) " ")(setq en ""))
      (if (= (substr (vl-string-left-trim "\/" en) 1 2) "U+")
      (setq en (strcat "\\" (vl-string-left-trim "\/" en))))(setq *SUFF* en)
               (initget "Row Col Setting стРоки сТолбцы Установки _Row Col Setting Row Col Setting")
               )
             t
             )
         (or what (setq what "Col"))
         (or
        (while (null  tblobj)
          (initget 1)
          (setq pt (getpoint "\nУкажите ячейку таблицы:"))
          (mapcar '(lambda (x)
           (or tblobj
               (and
                 (= :vlax-true (vla-HitTest x
                               (vlax-3d-point (trans pt 1 0))
                               (vlax-3d-point (trans (getvar "VIEWDIR") 1 0))
                               'row 'col))
                 (setq tblobj x)
                 )
               )
           )
        lst)
          (if (null  tblobj)(princ " ** мимо **"))
          )
        t)
         (or
           (vlax-write-enabled-p tblobj)
           (and
             (princ "\nТаблица на заблокированном слое!")
             nil
             )
           )
         (setq pt (vla-GetCellAlignment tblobj row col))
         )
    (setq rows (vla-get-rows tblobj))
    (setq cols (vla-get-columns tblobj))
    (princ "\nВыберите примитивы для вставки их площади в таблицу (ENTER — завершение): ")
    (setq ss (ssget))
    (while (and ss (> (sslength ss) 0) (setq en (ssname ss 0)))
      (cond
       ((vlax-property-available-p (setq en (vlax-ename->vla-object en)) 'Area)
          (setq fld (strcat "%<\\AcObjProp Object(%<\\_ObjId "
             (vl-princ-to-string(Get-ObjectID-x86-x64 en))
                ">%).Area \\f \"%lu2%ps["*PREF* "," *SUFF*
                "]%pr"(itoa *PREC*) "%ct8["(vl-princ-to-string *SCALE*)"]\">%"
                ) ;_ strcat
          )
        (cond
          ((= col cols)
            (vla-insertColumns tblobj col (vla-GetColumnWidth tblobj (1- col)) 1)
            (vla-SetCellAlignment tblobj row col pt)
            (setq rows (vla-get-rows tblobj))
            (setq cols (vla-get-columns tblobj))
            
          )
          ((= row rows)
            (vla-insertRows tblobj row (vla-GetRowHeight tblobj (1- row)) 1)
           (vla-SetCellAlignment tblobj row col pt)
            (setq rows (vla-get-rows tblobj))
            (setq cols (vla-get-columns tblobj))
         )
          (t nil))
        (vla-SetText tblobj row col fld)
        (if (= what "Col")(setq col (1+ col))(setq row (1+ row)))
        
       )
       (t(princ "\nДля этого примитива невозможно получить свойство Area!"))
      )
     (ssdel (ssname ss 0) ss)
    )
   )
   (t
     (princ "\nТаблиц не найдено!")
   )
  )
  (princ)
)

;;--------------------------------------------------------
;; Функция получает строковое представление ObjectID
;; вне зависимости от того AutoCAD x86 или x64
;; Источник: https://discussion.autodesk.com/forums/message.jspa?messageID=6172961
;; http://forum.dwg.ru/showthread.php?t=51822
;;--------------------------------------------------------
(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)
     )
  )
)
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Размещение рекламы