Архитектору и проектировщику|Тепло- и звукоизоляция URSA.RU
Показать сообщение отдельно
 
Непрочитано 11.08.2009, 21:48
#41
VVA

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


Positron,
Код:
[Выделить все]
(defun C:BOXTLB ( / cmdname fld txt tblset tblobj row col dimtxt
                 whatAcadVer tstyle what
                 ss dim1 dim2 dim3)
(defun whatAcadVer ( / Aver)
;;;Ф-ция возвращает версию Автокада ввиде 2004 2005 2006 2007 2008 2009
(setq Aver (atof (substr (getvar "ACADVER") 1 4)))
(cond
((= 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 2011)
)
)
  (vl-load-com)
 (or *TEXTSIZE* (setq *TEXTSIZE* (getvar "TEXTSIZE")))
  (and
    (or ;_ > Проверяем версию
      (> (whatAcadVer) 2005)
      (alert "\nНужен Автокад версии 2006 и выше")
      ) ;_ < Проверяем версию
    (princ "\nВыберите 1-й размер")
    (setq ss nil ss (ssget "_+.:E:S" '((0 . "DIMENSION"))))
    (setq dim1 (vlax-ename->vla-object(ssname ss 0)))
     (setq dimtxt (strcat (vl-princ-to-string(vla-get-measurement dim1)) " x"))
    (or (vla-Highlight dim1 :vlax-true) t)
    (princ "\nВыберите 2-й размер : ")(princ dimtxt)
    (setq ss nil ss (ssget "_+.:E:S" '((0 . "DIMENSION"))))
    (setq dim2 (vlax-ename->vla-object(ssname ss 0)))
    (or (vla-Highlight dim2 :vlax-true) t)
    (setq dimtxt (strcat dimtxt (vl-princ-to-string(vla-get-measurement dim2)) " x"))
    (princ "\nВыберите 3-й размер : ")(princ dimtxt)
    (setq ss nil ss (ssget "_+.:E:S" '((0 . "DIMENSION"))))
    (setq dim3 (vlax-ename->vla-object(ssname ss 0)))
    (or (vla-Highlight dim3 :vlax-true) t)
    (princ (setq dimtxt (strcat dimtxt " " (vl-princ-to-string(vla-get-measurement dim3)))))
  ;_ Формируем поле
  ;;;  %<\AcObjProp Object(%<\_ObjId 2130564848>%).Measurement \f "%lu2%pr0">%
    (setq fld (strcat
                "%<\\AcObjProp Object(%<\\_ObjId " (vl-princ-to-string(Get-ObjectID-x86-x64 dim1))
                ">%).Measurement \\f \"%lu2%pr0\">%"
                "x"
                "%<\\AcObjProp Object(%<\\_ObjId " (vl-princ-to-string(Get-ObjectID-x86-x64 dim2))
                ">%).Measurement \\f \"%lu2%pr0\">%"
                "x"
               "%<\\AcObjProp Object(%<\\_ObjId " (vl-princ-to-string(Get-ObjectID-x86-x64 dim3))
               ">%).Measurement \\f \"%lu2%pr0\">%"
                ) ;_ strcat
          ) ;_ setq
  (or (vla-Highlight dim1 :vlax-false)
      (vla-Highlight dim2 :vlax-false)
      (vla-Highlight dim3 :vlax-false)
   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 Укажите точку вставки текста или ячейку таблицы(")(princ dimtxt)(princ ") :")
  (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)
  )
;;--------------------------------------------------------
;; Функция получает строковое представление 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, 17.10.2014 в 13:27. Причина: Добавлен Get-ObjectID-x86-x64
VVA вне форума  
 
Размещение рекламы