[编程交流] pareatlb公司

(defun C:PAREATLB ( / en cmdname fld txt fc tblset tblobj row col pt
               whatAcadVer)
(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)((= Aver
18.1) 2011)
    (t O)))
(vl-load-com)
(or *SCALE* (setq *SCALE* 0.0001))
(or *PREC* (setq *PREC* 2))
(or *TEXTSIZE* (setq *TEXTSIZE* 30))
(or *SUFF* (setq *SUFF* ""))(or *PREF* (setq *PREF* ""))
(setq *SUFF* (vl-princ-to-string *SUFF*))
(setq *PREF* (vl-princ-to-string *PREF*))
(princ "\nscale factor = ")(princ *SCALE*)
(princ " precision = ")(princ *PREC*)
(princ " text height = ")(princ *TEXTSIZE*)
(princ " prefix= ")(princ *PREF*)(princ " suffix= ")(princ *SUFF*)
(initget "Polyline Setting sElect Polyline Setting sElect _Polyline
Setting sElect Polyline Setting sElect")
(and
  (or ;_ >check-up a version
    (> (whatAcadVer) 2005)
    (alert "\nneed autocad 2006 at least")
    ) ;_ < check-up a version
  (or ;_ >
  (while (= (setq cmdname (getkword "\nselect or draw
[Polyline/Setting/sElect] <sElect>: "))
            "Setting")
    (princ "\nnew scale factor <")(princ *SCALE*)(princ "> : ")
    (initget 6)
    (if (setq en (getdist))(setq *SCALE* en))
    (princ "\nnew precision <")(princ *PREC*)(princ "> : ")
    (initget 4)
    (if (setq en (getint))(setq *PREC* en))
    (princ "\nnew text height <")(princ *TEXTSIZE*)(princ "> : ")
    (initget 6)
    (if (setq en (getdist))(setq *TEXTSIZE* en))
    (princ "\nprefix (space-clean) <")(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 "\nsuffix (space-clean) <")(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 Polyline Setting sElect")
    )
  t
  ) ;_ <
(cond
  ((= cmdname "Polyline")(setvar "CMDECHO" 1)(command "_.PLINE")
   (while (> (getvar "CMDACTIVE") 0)(command pause))
   (setq en (entlast))
   )
  ((or (null cmdname)(= cmdname "sElect"))
       (princ "\nselect polyline,circl,spline ellipse,arc ")
       (and
         (setq tblset (ssget "_:S:E" '((0 .
"LINE,*POLYLINE,ARC,SPLINE,ELLIPSE,CIRCLE"))))
         (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)))
              ">%).Area \\f "%lu2%ps["*PREF* "," *SUFF*
              "]%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 select insert point:")
(vl-cmdf "_.copybase" (trans '(0 0 0) 0 1) txt "" "_.erase" txt ""
"_.pasteclip" "_none" pause)
;_
(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) ;_
    (vlax-property-available-p txt 'TextString)
    (vlax-put txt 'TextString fld)
    )
  )
)
(setvar "filedia" 1)
(princ)
)