pareatlb公司
嗨，这是我第一次参加论坛。我不是程序员，但我不是知道该做什么。
我有一个lisp，它可以在autocad 11 windows xp中运行，但在windows 7中运行
不要工作。我能做什么？？？也许你能帮我。
这是lisp：
(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
<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 ;_
(setqtblobj 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)
)
谢谢
纳德尔-b@zahav.net.il 纳德尔
我也欢迎你！
我添加了代码标签，如您所见，现在看起来更好了。
我会删除邮件末尾的电子邮件地址；这是一个让收件箱充满垃圾邮件的好方法。
页:
[1]