Помогите с лиспом PTLB

Помогите с лиспом PTLB · 27.06.2013, 12:36

Ситуация следующая.
Пользуюсь для создания журнала этим лиспом

Код:

;  Команда: PTLB
;  Эта команда позволяет вставить в указанную точку рисунка или указанную ячейку таблицы
;  текст с полем (FIELD), содержащее значение площади или длины построенного или выбранного контура.
;  Точность округления и масштабный коэффициент настраиваются через опцию Установки
;  Так как это поле связано с конкретным объектом, то при изменении
;  объекта поле пересчитывается (необходимо обновление поля)
;  Код можно сохранить в файле ptlb.lsp
;  Возможный макрос для кнопки или пункта меню:
;  ^C^C(if (not C:PTLB) (load "ptlb"));PTLB;
;; Вариант макроса для задания м2
;; ^C^C(if (not C:PTLB) (load "ptlb"));PTLB;_L;_S;1;0.001;2;3;5;;м2;
;;Где
;; _L - считать длинну (_A - площадь)
;; _S - установки
;; 1 - линейный масштабный коэффициент
;; 0.001 — площадной масштабный коэффициент
;; 2 — точность представления чисел
;; 3 - Кратность округления (0-Нет)
;; 5 — высота текста
;; префикса нет
;; м2 - суффикс

(defun C:PTLB ( / en cmdname fld txt fc tblset tblobj row col pt
                 whatAcadVer tstyle what *error* layer-status-save
               layer-status-restore
               )
;;;Ф-ция возвращает версию Автокада ввиде 2004 2005 2006 2007 2008
(defun whatAcadVer ( / Aver)
;;;Ф-ция возвращает версию Автокада ввиде 2004 2005 2006 2007 2008 2009
(setq Aver (atof (substr (getvar "ACADVER") 1 4)))
(cond
((= Aver 18.2) 2012)  
((= Aver 18.1) 2011)  
((= Aver 18.0) 2010)  
((= Aver 17.2) 2009)
((= 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 2013)
)
)
  (defun _round (num prec)
  (cond ((zerop prec) num)
        (t
         (* prec
            (if (minusp num)
              (fix (- (/ num prec) 0.5))
              (fix (+ (/ num prec) 0.5))
              )
            )
         )
        )
)
  (defun *error* (msg)(layer-status-restore)
    (princ msg)(princ))
  (defun layer-status-save ()
    (setq *MIP_LAYER_LST* nil)
    (vlax-for item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) 
      (setq *MIP_LAYER_LST* (cons (list item 
                                  (cons "lock" (vla-get-lock item)) 
                                  ) ;_ end of cons 
                            *MIP_LAYER_LST* 
                            ) ;_ end of cons 
            ) ;_ end of setq 
      (vla-put-lock item :vlax-false)
      ) ;_ end of vlax-for
      
    );_ end of defun
(defun layer-status-restore () 
    (foreach item *MIP_LAYER_LST*
      (if (not (vlax-erased-p (car item))) 
        (vl-catch-all-apply 
          '(lambda () 
             (vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))
             ) ;_ end of lambda 
          ) ;_ end of vl-catch-all-apply 
        ) ;_ end of if 
      ) ;_ end of foreach
    (setq *MIP_LAYER_LST* nil)
    ) ;_ end of defun 
  (vl-load-com)
  (or *SCALEL* (setq *SCALEL* 1))
  (or *SCALEA* (setq *SCALEA* 1))
  (or *PREC* (setq *PREC* 2))
  (or *OKR* (setq *OKR* 0))
  (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*))
  (and
    (or ;_ > Проверяем версию
      (> (whatAcadVer) 2005)
      (alert "\nНужен Автокад версии 2006 и выше")
      ) ;_ < Проверяем версию
    (or (initget "Length Area Длина Площадь _Length Area Length Area") t)
;;;    (if (null (setq what (getkword "\nЧто будем считать [Длина/Площадь] <Длина> :")))
      (setq what "Length") t
      (princ "\nТекущий масштаб: линейный = ")(princ *SCALEL*)(princ " площадной = ")(princ *SCALEA*)
      (princ " Точность = ")(princ *PREC*)
      (princ " Кратность округления =")(princ (if (zerop *OKR*) "нет" *OKR*))
      (princ " Высота текста = ")(princ *TEXTSIZE*)
      (princ " Префикс= ")(princ *PREF*)(princ " Суффикс= ")(princ *SUFF*)
    (or
      (initget "Polyline Setting sElect Полилиния Установки Выбор _Polyline Setting sElect Polyline Setting sElect")
      t
      )
    (or ;_ > Запрашиваем что рисовать + опции
;;;    (while (= (setq cmdname (getkword (strcat (if (= what "Area") "\n<Площадь> " "\n<Длина> ")
;;;           "Выберите или нарисуйте [Полилиния/Установки/Выбор] <Выбор>: ")))
;;;              "Setting")
;;;      (princ "\nНовый линейный масштабный коэффициент <")(princ *SCALEL*)(princ "> : ")
;;;      (initget 6)
;;;      (if (setq en (getdist))(setq *SCALEL* en))
;;;      (princ "\nНовый площадной масштабный коэффициент <")(princ *SCALEA*)(princ "> : ")
;;;      (initget 6)
;;;      (if (setq en (getdist))(setq *SCALEA* en))
;;;      (princ "\nТочность представления чисел <")(princ *PREC*)(princ "> : ")
;;;      (initget 4)
;;;      (if (setq en (getint))(setq *PREC* en))
;;;      (princ "Кратность округления (0-Нет) <")(princ (if (zerop *OKR*) "нет" *OKR*))(princ "> : ")
;;;      (initget 4)
;;;      (if (setq en (getreal))(setq *OKR* en))
;;;      (princ "\nВысота текста <")(princ *TEXTSIZE*)(princ "> : ")
;;;      (initget 6)
;;;      (if (setq en (getdist))(setq *TEXTSIZE* en))
;;;      (princ "\nПрефикс (пробел - очистить) <")(princ *PREF*)(princ "> : ")
;;;      (setq en (getstring t))(if (= en "")(setq en *PREF*))
;;;      (if (= en " ")(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 "> : ")
;;;      (setq en (getstring t))(if (= en "")(setq en *SUFF*))
;;;      (if (= en " ")(setq en ""))
;;;      (if (= (substr (vl-string-left-trim "\/" en) 1 2) "U+")
;;;      (setq en (strcat "\\" (vl-string-left-trim "\/" en))))(setq *SUFF* en)
      (initget "Polyline Setting sElect Полилиния Установки Выбор _Polyline Setting sElect Polyline Setting sElect")
;;;      )
    t
    ) ;_ < Запрашиваем что рисовать + опции
   (or (layer-status-save) t)
  (cond
    ((= cmdname "Polyline")(setvar "CMDECHO" 1)(command "_.PLINE")
     (while (> (getvar "CMDACTIVE") 0)(command pause))
     (setq en (entlast))
     )
    ((or (null cmdname)(= cmdname "sElect"))
         (princ "\nВыберите полилинию, круг, сплайн, эллипс или дугу")
         (and
           (setq tblset (ssget "_:S:E" (if (= what "Area") '((0 . "*POLYLINE,ARC,SPLINE,ELLIPSE,CIRCLE"))
                                                           '((0 . "LINE,*POLYLINE,ARC,CIRCLE")))
                                         ))
           (setq en (ssname tblset 0))
           )
     )
    (t nil)
    )
  ;_ Формируем поле
  (cond
    ((= what "Area")
    (setq fld (strcat
"%<\\AcObjProp Object(%<\\_ObjId "
(vl-princ-to-string (Get-ObjectID-x86-x64 en)) ;_ vl-princ-to-string
">%).Length \\f \"L=%lu2%pr1%ps[,м]%ct8[0.00118]\">%"
                ) ;_ strcat
          ) ;_ setq
     )
    ((and (= what "Length")
          (= (cdr(assoc 0 (entget en))) "CIRCLE")
          )
     (setq fld (strcat
"%<\\AcObjProp Object(%<\\_ObjId "
(vl-princ-to-string (Get-ObjectID-x86-x64 en)) ;_ vl-princ-to-string
">%).Length \\f \"L=%lu2%pr1%ps[,м]%ct8[0.00118]\">%"
                ) ;_ strcat
          ) ;_ setq
     )
    ((and (= what "Length")
          (= (cdr(assoc 0 (entget en))) "ARC")
          )
     (setq fld (strcat
"%<\\AcObjProp Object(%<\\_ObjId "
(vl-princ-to-string (Get-ObjectID-x86-x64 en)) ;_ vl-princ-to-string
">%).Length \\f \"L=%lu2%pr1%ps[,м]%ct8[0.00118]\">%"
                ) ;_ strcat
          ) ;_ setq
     )
    ((and (= what "Length")
          (vlax-property-available-p (vlax-ename->vla-object en) "Length")
          )
      (setq fld (strcat
"%<\\AcObjProp Object(%<\\_ObjId "
(vl-princ-to-string (Get-ObjectID-x86-x64 en)) ;_ vl-princ-to-string
">%).Length \\f \"%lu2%pr1%ps%ct8[0.00118]\">%"
                ) ;_ strcat
          ) ;_ setq
     )
    (t (setq fld "Неизвестное свойство"))
    )
;;;Округляем
   (if (not (zerop *OKR*))
     (setq fld
            (strcat
              "%<\\AcExpr ((Trunc("
              (substr fld 1 (1-(vl-string-search "\\f" fld)))
              ">%"
              " / "
              (vl-prin1-to-string *OKR*)
              " + 0.5"
              "))*"
              (vl-prin1-to-string *OKR*)
              ")"
              (substr fld (vl-string-search "\\f" fld))
              ;;">%"
              )
           )
     t
     )
(setvar "cmdecho" 0)
(setq tstyle (getvar "TEXTSTYLE")) ;_Стиль текста Стиль должен существовать
    ;_ Создаем текст
(if (= (cdr (assoc 40 (tblsearch "STYLE" tstyle))) 0.0)
     ;; нулевая высота текста
   (vl-cmdf "_.-TEXT" "_S" tstyle "_none" '(0 0 0) *TEXTSIZE* 0 fld)
   (vl-cmdf "_.-TEXT" "_S" tstyle "_none" '(0 0 0) 0 fld)
   ) ;_ end of if
    (setq txt (entlast))
  ;_ Копируем в буфер и обратно
  (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" (list '(0 . "ACAD_TABLE")(cons 410 (getvar "CTAB")))))
      (setq lst (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex tblset)))))
      (progn
        (vl-catch-all-apply '(lambda()
        (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)
      )
    )
  )
  (layer-status-restore)
  (princ)
  )
(princ "\nКоманда PTLB. Версия от 20.04.2011 http://forum.dwg.ru/showpost.php?p=183237&postcount=3")
(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)
     )
  )
)
(princ "\nКоманда PTLB. Версия от 19.03.2012 http://forum.dwg.ru/showpost.php?p=183237&postcount=3")
(princ)

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

Дима_ · 27.06.2013, 15:49

Не проверял, но по идее должно заработать:

Код:

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

 ;  Команда: PTLB
;  Эта команда позволяет вставить в указанную точку рисунка или указанную ячейку таблицы
;  текст с полем (FIELD), содержащее значение площади или длины построенного или выбранного контура.
;  Точность округления и масштабный коэффициент настраиваются через опцию Установки
;  Так как это поле связано с конкретным объектом, то при изменении
;  объекта поле пересчитывается (необходимо обновление поля)
;  Код можно сохранить в файле ptlb.lsp
;  Возможный макрос для кнопки или пункта меню:
;  ^C^C(if (not C:PTLB) (load "ptlb"));PTLB;
;; Вариант макроса для задания м2
;; ^C^C(if (not C:PTLB) (load "ptlb"));PTLB;_L;_S;1;0.001;2;3;5;;м2;
;;Где
;; _L - считать длинну (_A - площадь)
;; _S - установки
;; 1 - линейный масштабный коэффициент
;; 0.001 — площадной масштабный коэффициент
;; 2 — точность представления чисел
;; 3 - Кратность округления (0-Нет)
;; 5 — высота текста
;; префикса нет
;; м2 - суффикс

(defun C:PTLB-lite ( / en cmdname fld txt fc tblset tblobj row col pt
                 whatAcadVer tstyle what *error* layer-status-save
               layer-status-restore
               )
;;;Ф-ция возвращает версию Автокада ввиде 2004 2005 2006 2007 2008
(defun whatAcadVer ( / Aver)
;;;Ф-ция возвращает версию Автокада ввиде 2004 2005 2006 2007 2008 2009
(setq Aver (atof (substr (getvar "ACADVER") 1 4)))
(cond
((= Aver 18.2) 2012)  
((= Aver 18.1) 2011)  
((= Aver 18.0) 2010)  
((= Aver 17.2) 2009)
((= 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 2013)
)
)
  (defun _round (num prec)
  (cond ((zerop prec) num)
        (t
         (* prec
            (if (minusp num)
              (fix (- (/ num prec) 0.5))
              (fix (+ (/ num prec) 0.5))
              )
            )
         )
        )
)
  (defun *error* (msg)(layer-status-restore)
    (princ msg)(princ))
  (defun layer-status-save ()
    (setq *MIP_LAYER_LST* nil)
    (vlax-for item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) 
      (setq *MIP_LAYER_LST* (cons (list item 
                                  (cons "lock" (vla-get-lock item)) 
                                  ) ;_ end of cons 
                            *MIP_LAYER_LST* 
                            ) ;_ end of cons 
            ) ;_ end of setq 
      (vla-put-lock item :vlax-false)
      ) ;_ end of vlax-for
      
    );_ end of defun
(defun layer-status-restore () 
    (foreach item *MIP_LAYER_LST*
      (if (not (vlax-erased-p (car item))) 
        (vl-catch-all-apply 
          '(lambda () 
             (vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))
             ) ;_ end of lambda 
          ) ;_ end of vl-catch-all-apply 
        ) ;_ end of if 
      ) ;_ end of foreach
    (setq *MIP_LAYER_LST* nil)
    ) ;_ end of defun 
  (vl-load-com)
  (or *SCALEL* (setq *SCALEL* 1))
  (or *SCALEA* (setq *SCALEA* 1))
  (or *PREC* (setq *PREC* 2))
  (or *OKR* (setq *OKR* 0))
  (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*))
  (and
    (or ;_ > Проверяем версию
      (> (whatAcadVer) 2005)
      (alert "\nНужен Автокад версии 2006 и выше")
      ) ;_ < Проверяем версию
    (or (initget "Length Area Длина Площадь _Length Area Length Area") t)
;;;    (if (null (setq what (getkword "\nЧто будем считать [Длина/Площадь] <Длина> :")))
      (setq what "Length") t
      (princ "\nТекущий масштаб: линейный = ")(princ *SCALEL*)(princ " площадной = ")(princ *SCALEA*)
      (princ " Точность = ")(princ *PREC*)
      (princ " Кратность округления =")(princ (if (zerop *OKR*) "нет" *OKR*))
      (princ " Высота текста = ")(princ *TEXTSIZE*)
      (princ " Префикс= ")(princ *PREF*)(princ " Суффикс= ")(princ *SUFF*)
    (or
      (initget "Polyline Setting sElect Полилиния Установки Выбор _Polyline Setting sElect Polyline Setting sElect")
      t
      )
    (or ;_ > Запрашиваем что рисовать + опции
;;;    (while (= (setq cmdname (getkword (strcat (if (= what "Area") "\n<Площадь> " "\n<Длина> ")
;;;           "Выберите или нарисуйте [Полилиния/Установки/Выбор] <Выбор>: ")))
;;;              "Setting")
;;;      (princ "\nНовый линейный масштабный коэффициент <")(princ *SCALEL*)(princ "> : ")
;;;      (initget 6)
;;;      (if (setq en (getdist))(setq *SCALEL* en))
;;;      (princ "\nНовый площадной масштабный коэффициент <")(princ *SCALEA*)(princ "> : ")
;;;      (initget 6)
;;;      (if (setq en (getdist))(setq *SCALEA* en))
;;;      (princ "\nТочность представления чисел <")(princ *PREC*)(princ "> : ")
;;;      (initget 4)
;;;      (if (setq en (getint))(setq *PREC* en))
;;;      (princ "Кратность округления (0-Нет) <")(princ (if (zerop *OKR*) "нет" *OKR*))(princ "> : ")
;;;      (initget 4)
;;;      (if (setq en (getreal))(setq *OKR* en))
;;;      (princ "\nВысота текста <")(princ *TEXTSIZE*)(princ "> : ")
;;;      (initget 6)
;;;      (if (setq en (getdist))(setq *TEXTSIZE* en))
;;;      (princ "\nПрефикс (пробел - очистить) <")(princ *PREF*)(princ "> : ")
;;;      (setq en (getstring t))(if (= en "")(setq en *PREF*))
;;;      (if (= en " ")(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 "> : ")
;;;      (setq en (getstring t))(if (= en "")(setq en *SUFF*))
;;;      (if (= en " ")(setq en ""))
;;;      (if (= (substr (vl-string-left-trim "\/" en) 1 2) "U+")
;;;      (setq en (strcat "\\" (vl-string-left-trim "\/" en))))(setq *SUFF* en)
      (initget "Polyline Setting sElect Полилиния Установки Выбор _Polyline Setting sElect Polyline Setting sElect")
;;;      )
    t
    ) ;_ < Запрашиваем что рисовать + опции
   (or (layer-status-save) t)
  (cond
    ((= cmdname "Polyline")(setvar "CMDECHO" 1)(command "_.PLINE")
     (while (> (getvar "CMDACTIVE") 0)(command pause))
     (setq en (entlast))
     )
    ((or (null cmdname)(= cmdname "sElect"))
         (princ "\nВыберите полилинию, круг, сплайн, эллипс или дугу")
         (and
           (setq tblset (ssget "_:S:E" (if (= what "Area") '((0 . "*POLYLINE,ARC,SPLINE,ELLIPSE,CIRCLE"))
                                                           '((0 . "LINE,*POLYLINE,ARC,CIRCLE")))
                                         ))
           (setq en (ssname tblset 0))
           )
     )
    (t nil)
    )
  ;_ Формируем поле
  (cond
    ((= what "Area")
    (setq fld (rtos (vla-get-area(vlax-ename->vla-object en))) 
          ) ;_ setq
     )
    ((and (= what "Length")
          (= (cdr(assoc 0 (entget en))) "CIRCLE")
          )
     (setq fld (rtos (* Pi (vla-get-diameter (vlax-ename->vla-object en))))
          ) ;_ setq
     )
    ((and (= what "Length")
          (= (cdr(assoc 0 (entget en))) "ARC")
          )
     (setq fld (rtos (vla-get-arclength (vlax-ename->vla-object en)))
          ) ;_ setq
     )
    ((and (= what "Length")
          (vlax-property-available-p (vlax-ename->vla-object en) "Length")
          )
      (setq fld (rtos (vla-get-length (vlax-ename->vla-object en)))
          ) ;_ setq
     )
    (t (setq fld "Неизвестное свойство"))
    )
;;;Округляем
   (if (not (zerop *OKR*))
     (setq fld
            (strcat
              "%<\\AcExpr ((Trunc("
              (substr fld 1 (1-(vl-string-search "\\f" fld)))
              ">%"
              " / "
              (vl-prin1-to-string *OKR*)
              " + 0.5"
              "))*"
              (vl-prin1-to-string *OKR*)
              ")"
              (substr fld (vl-string-search "\\f" fld))
              ;;">%"
              )
           )
     t
     )
(setvar "cmdecho" 0)
(setq tstyle (getvar "TEXTSTYLE")) ;_Стиль текста Стиль должен существовать
    ;_ Создаем текст
(if (= (cdr (assoc 40 (tblsearch "STYLE" tstyle))) 0.0)
     ;; нулевая высота текста
   (vl-cmdf "_.-TEXT" "_S" tstyle "_none" '(0 0 0) *TEXTSIZE* 0 fld)
   (vl-cmdf "_.-TEXT" "_S" tstyle "_none" '(0 0 0) 0 fld)
   ) ;_ end of if
    (setq txt (entlast))
  ;_ Копируем в буфер и обратно
  (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" (list '(0 . "ACAD_TABLE")(cons 410 (getvar "CTAB")))))
      (setq lst (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex tblset)))))
      (progn
        (vl-catch-all-apply '(lambda()
        (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)
      )
    )
  )
  (layer-status-restore)
  (princ)
  )
(princ "\nКоманда PTLB. Версия от 20.04.2011 http://forum.dwg.ru/showpost.php?p=183237&postcount=3")
(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)
     )
  )
)
(princ "\nКоманда PTLB. Версия от 19.03.2012 http://forum.dwg.ru/showpost.php?p=183237&postcount=3")
(princ)

запускать PTLB-lite

alivstar · 27.06.2013, 16:24

Спасибо! Тему можно закрывать.

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Товарищи! помогите с лиспом	САПР	LISP	27	11.02.2019 09:00
Помогите лиспом??	Gri05-1	LISP	7	19.04.2013 11:19
помогите с лиспом !!!!!!!!	САПР	LISP	44	05.04.2007 17:04
Помогите с лиспом	GarryPop	LISP	6	04.01.2007 09:19
Помогите, пожалуйста, с лиспом...	4eh	LISP	9	15.11.2005 14:22

Опции темы	Поиск в этой теме
	Поиск в этой теме: Расширенный поиск

	Реклама i