寻求lisp方面的帮助-
大家好，Lisp程序的专家们。我需要对我这里的一个程序稍微修改一下，然后再修改一下。
基本上，我有一个lisp，它将把多段线的区域放在多行文字的cretin层下。
我需要它做的是将值放入块属性，而不是m text。
该块称为房间标记
属性标记为ASQFT
(defun c:PolyArea(/ BitVersion acsp ss e ptList ID StrField txt p)
(vl-load-com)
(setq BitVersion
(if (> (strlen
(vl-prin1-to-string
(vlax-get-acad-object)))
40) T nil)
acsp (vla-get-block
(vla-get-activelayout
(vla-get-activedocument
(vlax-get-acad-object)))))
(if (setq ss (ssget "_X" '((0 . "*POLYLINE")
(8 . "A-AREA")
(-4 . "&")
(70 . 1)(410 . "Model"))))
(repeat (sslength ss)
(setq e (ssname ss 0)
sum '(0 0)
verts (cdr (assoc 90 (entget e))))
(setq ptList
(mapcar 'cdr
(vl-remove-if-not
'(lambda (x) (= (car x) 10))
(entget e))))
(foreach x ptList (setq sum (mapcar '+ x sum)))
(setq ID (if BitVersion
(vlax-invoke-method
(vla-get-Utility
(vla-get-ActiveDocument
(vlax-get-acad-object)))
'GetObjectIdString
(vlax-ename->vla-object
e)
:vlax-False)
(itoa (vla-get-objectid
(vlax-ename->vla-object e)))))
(setq StrField
(strcat
"%<\\AcObjProp Object(%<\\_ObjId "
ID
">%).Area \\f \"%lu2%pr2%ps[, M²]%ct8\">%"))
(vla-put-AttachmentPoint
(setq txt (vla-addMText
acsp
(setq p (vlax-3d-point
(mapcar '/ sum
(list verts
verts))))
0StrField))
acAttachmentPointMiddleCenter)
(vla-put-InsertionPoint txt p)
(ssdel e ss)
)(princ "\0 Objects found:"))
(princ)
)
提前感谢您的帮助，非常感谢。
顺致敬意，
戴夫。 以下是vanilla AutoLISP中的一个片段，可以帮助您入门：
(defun c:rarea (/ en ss a p z bn i)
(setvar "CMDECHO" 0)
(setvar "DIMZIN" 12)
(setvar "UNITMODE" 1)
(while (not en)
(and (setq ss (ssget '((0 . "*POLYLINE")
(67 . 0)
(-4 . "&")
(70 . 1))))
(setq en (ssname ss 0))))
(command "_.AREA" "_E" en)
(setq a (getvar "AREA")
p (getvar "PERIMETER")
z (getvar "TEXTSIZE"))
(entmake (list (cons 0 "BLOCK")
(cons 2 "ROOMTAG")
(cons 70 0)
(list 10 0 0 0)))
(entmake (list (cons 0 "LINE")
(cons 8 "0")
(list 10 -1 0 0)
(list 11 +1 0 0)))
(setq bn (entmake (list (cons 0 "ENDBLK")(cons 8 "0"))))
(initget 1)
(setq i (getpoint "\nINSERT Point: "))
(entmake (list (cons 0 "INSERT")
(cons 2 bn)
(cons 10 i)
(cons 41 z)
(cons 42 z)
(cons 43 z)
(cons 66 1)))
(entmake (list (cons 0 "ATTRIB")
(cons 1 (strcat (rtos (/ a 12) 4 0) " Sq Ft"))
(cons 2 "ASQFT")
(cons 6 "BYLAYER")
(cons 7 (getvar "TEXTSTYLE"))
(cons 10 (polar i (* pi 0.5) (* z 1.5)))
(cons 11 (polar i (* pi 0.5) (* z 1.5)))
(cons 40 z)
(cons 70 0)
(cons 72 4)
(cons 62 256)
(cons 39 1e-8)))
(entmake (list (cons 0 "ATTRIB")
(cons 1 (strcat (rtos p 4 0) " Ln Ft"))
(cons 2 "APERM")
(cons 6 "BYLAYER")
(cons 7 (getvar "TEXTSTYLE"))
(cons 10 (polar i (* pi -0.5) (* z 1.5)))
(cons 11 (polar i (* pi -0.5) (* z 1.5)))
(cons 40 z)
(cons 70 0)
(cons 72 4)
(cons 62 256)
(cons 39 1e-8)))
(entmake (list (cons 0 "SEQEND")))
(prin1))
仅适用于闭合多段线。
-大卫 大卫，代码不错；然而，我认为Dave（OP）已经创建了具有特定属性的块，因此不需要创建一个。
Dave（OP），下面的代码是一个大纲，它将选择您的块（假设已经插入），并指示要修改的特定属性（这不会计算面积-如果您需要与其他代码结合的帮助，请告诉我）。需要更改YOURLAYERNAME和YOURAREAVARIABLE以满足您的需要。
;;;;;;
;CHE SYN 2013
;Vanilla LISP outline to find a block and alter a specific tag
;;;;;;
(defun c:test ( / ss e x a ax YOURAREAVARIABLE)
(setq ss (ssget "_x" '( (0 . "INSERT")(2 . "ROOM TAG")(8 . "YOURLAYERNAME") ))
e (ssname ss 0)
x (entget e)
a (entnext e)
ax (entget a)
)
(while
(/= "SEQEND" (cdr (assoc 0 ax)) )
(if
(= "ASQFT" (cdr (assoc 2 ax)) )
(progn
(entmod
(subst
(cons 1 YOURAREAVARIABLE)
(assoc 1 ax)
ax
)
)
(entupd e)
)
)
(setq a (entnext a)
ax (entget a)
)
)
(princ)
)
我看到OP有块的插入点-它是普林斯重心-因为我和吉尔斯根据点列表数据命名了这种中心。。。我不知道OP要显示哪些属性值的单位，所以我将其保留为普通dwg单位，保留了2位小数。。。另外，如果我注意到的话，David预测了更多用于标记的PLINE，但没有正确完成此功能的代码。。。这是David的扩展和我的修改。。。
(defun barycent (ptlst)
(mapcar '(lambda ( x ) (/ x (float (length ptlst))))
(mapcar '(lambda ( x ) (apply '+ x))
(apply 'mapcar (cons 'list ptlst))
)
)
)
(defun c:rarea (/ en ss a p z bn ii epar pt ptlst i)
(vl-load-com)
(setvar "CMDECHO" 0)
(setvar "DIMZIN" 12)
(setvar "UNITMODE" 1)
(setq ss (ssget '((0 . "*POLYLINE")
(67 . 0)
(-4 . "&")
(70 . 1))))
(while (setq en (ssname ss 0))
(command "_.AREA" "_E" en)
(setq a (getvar "AREA")
p (getvar "PERIMETER")
z (getvar "TEXTSIZE"))
(entmake (list (cons 0 "BLOCK")
(cons 2 "ROOMTAG")
(cons 70 0)
(list 10 0 0 0)))
(entmake (list (cons 0 "LINE")
(cons 8 "0")
(list 10 -1 0 0)
(list 11 +1 0 0)))
(setq bn (entmake (list (cons 0 "ENDBLK")(cons 8 "0"))))
(setq ptlst nil)
(setq ii -1.0)
(setq epar (vlax-curve-getendparam en))
(while (< (setq ii (1+ ii)) epar)
(setq pt (vlax-curve-getpointatparam en ii))
(setq ptlst (cons pt ptlst))
)
(setq ptlst (reverse ptlst))
(setq i (barycent ptlst))
(entmake (list (cons 0 "INSERT")
(cons 2 bn)
(cons 10 i)
(cons 41 z)
(cons 42 z)
(cons 43 z)
(cons 66 1)))
(entmake (list (cons 0 "ATTRIB")
(cons 1 (rtos a 2 2))
(cons 2 "ASQFT")
(cons 6 "BYLAYER")
(cons 7 (getvar "TEXTSTYLE"))
(cons 10 (polar i (* pi 0.5) (* z 1.5)))
(cons 11 (polar i (* pi 0.5) (* z 1.5)))
(cons 40 z)
(cons 70 0)
(cons 72 4)
(cons 62 256)
(cons 39 1e-8)))
(entmake (list (cons 0 "ATTRIB")
(cons 1 (rtos p 2 2))
(cons 2 "APERM")
(cons 6 "BYLAYER")
(cons 7 (getvar "TEXTSTYLE"))
(cons 10 (polar i (* pi -0.5) (* z 1.5)))
(cons 11 (polar i (* pi -0.5) (* z 1.5)))
(cons 40 z)
(cons 70 0)
(cons 72 4)
(cons 62 256)
(cons 39 1e-8)))
(entmake (list (cons 0 "SEQEND")))
(ssdel en ss)
)
(princ)
)
M.R。
这太尴尬了；我说得太快了，没听到。
做得好，马尔科。 大家好，非常感谢大家的回复，但在组合代码时遇到了一些问题。
chesyn-我不是百分之百确定你说的AreaVariable是什么意思，层是a-area？
关于david和marko的代码，这是一个很棒的工具，你能在其中添加不是从多段线派生的字段吗。。。
例如，我的街区房间标签是这样的。
标记值
地板饰面xxxx
房间号xxxx
从lisp插入asqft
如果我能正确地重新创建块，那么我可以使用这种编码方式。
你有什么建议，你会在我的代码中插入哪一部分？
谢谢
当做
戴夫
在这种情况下，将“YOURLAYERNAME”更改为“a-area”
计算面积时，分配一个变量（即ar），然后用ar替换areavariable。
要修改的块是否已加载到图形中，还是希望通过LISP加载？
有多少块实例？
你能发布一个包含块的示例图吗？可能还有其他解决方案？
胆碱酯酶 在这里，试试这个版本。。。根据您的请求添加了其他属性。。。
（defun重心（ptlst）（mapcar）（lambda（x）（/x（float（lengthptlst））（mapcar（x）（apply[apply+x））（apply'(cons'listptlst）））（defunc:areapls attbl（/位版本acsp ID ss i pl ii epar pt ptlst cen ar bl att att1 att2 att3 att4 strfieldar strfieldlen）（vl load com（setq位版本（if（>（strlen（vl-prin1-to-string（vlax get acad object））40）Tnil）acsp(vla get block（vla get activelayout（vla get activedocument（vlax get acad object））（if（not（tblsearch“block”“ROOM-BLOCK”）（progn（setqatt1（entmakex（list'（0.“ATTDEF”）（100.“AcDbText”）（cons40（getvar'textsize））'（1。“地板饰面=XXXX”）'（50.0.0）'（41.1.0）'（51.0.0）'（7。“标准”）'（71.0）'（72.4）'（10.0.0.0.0.0）（cons11（polar'（0.0 0.0）（*pi0.5）（*3.0（getvar'textsize））'（210 0.0 0.0 1.0）'（100。“AcDbAttributeDefinition”）'（280.0）'（3。“FLOOR FINISH Prompt”）（2。“FLOOR FINISH”）'（70.0）'（73.0）'（74.0）'（280.1））（setqatt2(entmakex（list'（0.“ATTDEF”）（100.“AcDbEntity”）（40（getvar'textsize））'（1.“房间号=X”）“（50.0.0）'（41.1.0）'（51.0.0）'（7。“Standard”）'（71.0）'（72.4）'（10.0.0.0.0）（cons11（polar'（0.0.0.0）(*pi0.5（*1.0（getvar'textsize））'（210 0.0 0 0.0 1.0）'（100。“ACDBAttribute定义”）'（280.0）'（3。“房间无提示”'（2.“房间号”'（70.0）'（73.0）'（74.0）'（280.1））（setqatt3（entmakex（list'（0.“ATTDEF”）“（100.“AcDbEntity”）”（100.“AcDbText”）（cons40（getvar'textsize））“（1.“0.0”）”（50.0.0）“（41.1.0）“（51.0.0）”（7.“标准”'（71.0）'（72.4）'（10 0.0 0.0 0.0）（cons11（polar'（0.0 0 0.0）（*pi-0.5）（*1.0（getvar'textsize（））'（210 0.0 0.0 1.0）'（100。“AcDbAttributeDefinition”）'（280.0）'（3。“区域提示”）'（2。“区域”）'（70.0）'（73.0）'（74.0）“（280.1））（setqatt4（entmakex（list'（0.“ATTDEF”）（100.“AcDbText”）（cons40（getvar'textsize））'（1。“0.0”）'（50.0.0）'（41.1.0）'（51.0.0）'（7。“标准”）'（71.0）'（72.4）'（10.0.0.0.0）（11（polar'（0.0 0.0）（*pi-0.5）（*3.0（getvar'textsize））'（210 0.0 0.0 1.0）'（100。“AcDbAttributeDefinition”）'（280.0）'（3。“perior Prompt”）'（2。“perior”）'（70.0） Hi Marko, thanks very much it works really well, would it be possible to incorporate my lisp at the start of the post, as instead of selecting the polyline that you wish to display the area in, it automatically puts it in any closed polyline under a-area?
Che i have attached a copy of the block in a test file thanks
I really appreciate the help folks.
test polyline room tag.dwg
页:
[1]