Связь графических объектов и текста (Страница 3 из 4)

;_Draw Line and Insert Text
(defun C:DLIT ( / en cmdname fld txt fc tblset tblobj row col pt
                 whatAcadVer
                 drawLP
               )
;;;Ф-ция возвращает версию Автокада ввиде 2004 2005 2006 2007 2008
(defun whatAcadVer ( / Aver)
(setq Aver (atof (substr (getvar "ACADVER") 1 4)))
(cond ((= Aver 17.1) 2008)((= Aver 17.0) 2007)((= Aver 16.2) 2006)
      ((= Aver 16.1) 2005)((= Aver 16.0) 2004)((= Aver 15.06) 2002)
      (t 0)))
;_darw Line & Polyline
(defun drawLP ( cmdname )
  (setvar "CMDECHO" 1)
  (command cmdname)
  (while (> (getvar "CMDACTIVE") 0)(command pause))
  (entlast)
  )
  (vl-load-com)
  (or *SCALE* (setq *SCALE* 1))
  (or *PREC* (setq *PREC* 2))
  (or *TEXTSIZE* (setq *TEXTSIZE* (getvar "TEXTSIZE")))
  (princ "\nТекущий масштаб = ")(princ *SCALE*)
  (princ "  Текущая точность округления = ")(princ *PREC*)
  (princ "  Высота текста = ")(princ *TEXTSIZE*)
  (initget "Line Polyline Setting sElect Отрезок Полилиния Установки Выбор _Line Polyline Setting sElect Line Polyline Setting sElect")
  (and
    (or ;_ > Проверяем версию
      (> (whatAcadVer) 2005)
      (alert "\nНужен Автокад версии 2006 и выше")
      ) ;_ < Проверяем версию
    (or ;_ > Запрашиваем что рисовать + опции
    (while (= (setq cmdname (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))
      (initget "Line Polyline Setting sElect Отрезок Полилиния Установки Выбор _Line Polyline Setting sElect Line Polyline Setting sElect")
      )
    t
    ) ;_ < Запрашиваем что рисовать + опции
  (cond
    ((= cmdname "Line")(setq en (drawLP "_.Line")))
    ((= cmdname "Polyline")(setq en (drawLP "_.Pline")))
    ((or (null cmdname)(= cmdname "sElect"))
         (princ "\nВыберите отрезок или полилинию")
         (and
           (setq tblset (ssget "_:S:E" '((0 . "LINE,*POLYLINE"))))
           (setq en (ssname tblset 0))
           )
     )
    (t nil)
    )
  ;_ Формируем поле
  (setq fld (strcat
                "%<\\AcObjProp Object(%<\\_ObjId "
                (vl-princ-to-string
                  (vla-get-objectid (vlax-ename->vla-object en))
                  ) ;_ vl-princ-to-string
                ">%).Length \\f \"%lu2%pr"(itoa *PREC*) "%ct8["(vl-princ-to-string *SCALE*)"]\">%"
                ) ;_ strcat
          ) ;_ setq
    ;_ Создаем текст
  (setq txt (entmakex
      (list
        (cons 0 "TEXT")
        (cons 100 "AcDbEntity")
        (cons 100 "AcDbText")
        (cons 72 0)           ;_ выравнивание влево
        (cons 1 fld)
        ;(cons 7 style) ;_Текущий стиль
        ;(cons 8 layer) ;_Текущий слой
        (cons 10 '(0 0 0))
        (cons 11 '(0 0 0))
        (cons 40 *TEXTSIZE*) ;_Высота текста
        ) ;_ list
      ) ;_ entmakex
          )
  ;_ Копируем в буфер и обратно
  (setvar "cmdecho" 0)
  (vl-cmdf "_updatefield" txt "")
  (princ "\n Укажите точку вставки текста или ячейку таблицы:")
  (vl-cmdf "_.copybase" (trans '(0 0 0) 0 1) txt "" "_.erase" txt "" "_.pasteclip" "_none" pause)
  ;_ В txt примитив текста в pt точка вставки
  (setq txt (entlast) pt (getvar "LASTPOINT"))
  (or
    (and ;_Проверяем, попала ли точка в ячейку таблицы
      (setq  tblobj nil tblset (ssget "_X" '((0 . "ACAD_TABLE"))))
      (setq lst (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex tblset)))))
      (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)
      tblobj row col
      (or (vla-SetText tblobj row col fld) t)
      (entdel txt)
      )
    (and ;_Не попала, рисуем текст с полем
      (setq txt (vlax-ename->vla-object txt))
      (vlax-write-enabled-p txt)
      (vlax-method-applicable-p txt 'FieldCode) ;_есть метод FieldCode
      (vlax-property-available-p txt 'TextString)
      (vlax-put txt 'TextString fld)
      )
    )
  )
  (princ)
  )

(defun C:FldVizSel ( / txt lst ss _get-en-from-field)
;Возвращает список примитивов, входящих в поле (поля)
;txt — имя примитива хранителя поля (текст или атрибут таблица) [ENAME],
;      возвращаемое nentsel
(defun _get-en-from-field (txt / dict field field_data lst lst1)
  (and
    (setq dict (cdr (assoc 360 (entget txt)))) ;_Ename Dictionary Словарь примитива
    (setq dict
           (cdr (assoc 360 (member '(3 . "ACAD_FIELD") (entget dict))))
    ) ;_Enable Field Dictionary Есть поля в объекте
    (setq dict (cdr (assoc 360 (member '(3 . "TEXT") (entget dict))))) ;_ Field Record Запись поля
 ;_Sub Field Records Вторичные записи полей
    (setq field (mapcar 'cdr
                        (vl-remove-if
                          '(lambda (x) (/= (car x) 360))
                          (entget dict)
                        ) ;_ end of vl-remove-if
                ) ;_ end of mapcar
    ) ;_ end of setq
    (or (setq lst1 ;_прямые ссылки полей на примитивы
               (apply 'append
                      (mapcar '(lambda (field_data)
                                 (mapcar 'cdr
                                         (vl-remove-if
                                           '(lambda (x) (/= (car x) 331))
                                           (entget field_data)
                                         ) ;_ end of vl-remove-if
                                 ) ;_ end of mapcar
                               ) ;_ end of lambda
                              field
                      ) ;_ end of mapcar
               ) ;_ end of apply
        ) ;_ end of setq
        t
    ) ;_ end of or
    (if (setq ;_вложенные ссылки полей на примитивы (формулы в полях)
          lst (apply 'append
                     (mapcar '(lambda (field_data)
                                (mapcar 'cdr
                                        (vl-remove-if
                                          '(lambda (x) (/= (car x) 360))
                                          (entget field_data)
                                        ) ;_ end of vl-remove-if
                                ) ;_ end of mapcar
                              ) ;_ end of lambda
                             field
                     ) ;_ end of mapcar
              ) ;_ end of apply
        ) ;_ end of setq
      (setq
        lst (apply 'append
                   (mapcar '(lambda (field_data)
                              (mapcar 'cdr
                                      (vl-remove-if
                                        '(lambda (x) (/= (car x) 331))
                                        (entget field_data)
                                      ) ;_ end of vl-remove-if
                              ) ;_ end of mapcar
                            ) ;_ end of lambda
                           lst
                   ) ;_ end of mapcar
            ) ;_ end of apply
      ) ;_ end of setq
    ) ;_ end of if
  ) ;_ end of and
  (append lst lst1)
)
  (and
    (setq ss (ssget '((0 . "*TEXT"))))
    (setq txt (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
    (setq lst (mapcar '_get-en-from-field txt))
    (setq lst (apply 'append lst))
    (setq lst (vl-remove-if 'null lst))
    (setq ss nil ss (ssadd))
    (mapcar '(lambda(x)(ssadd x ss)) lst)
    (sssetfirst ss ss)
    )
  (setq ss nil)
  (princ)
  )