特定块/属性lisp
下午好我正在寻找一个遵循这些特定参数的lisp（我只是在学习lisp，我被困在这一个）：
[列表]
[*]窗口选择要更改的项目/块（具有不同名称的不同块的组合）。
[*]选择要编辑其值的属性标记（例如LOC）（用户输入）。注意：属性可能是隐藏的，可能包含也可能不包含现有值。
[*]确定属性的新值应该是什么（用户输入）。
[/列表]
选择中包含所需属性标记的块将按指定更改属性值。
有什么想法吗？有什么东西可以做这项工作吗？欢迎您的任何意见。
当做
洛辛斯基 下面是一个快速示例，使用属性函数集中的LM:setattributevalue函数：
(defun c:setattval ( / idx sel tag val )
(if (and (setq sel (ssget "_:L" '((0 . "INSERT") (66 . 1))))
(/= "" (setq tag (getstring "\nSpecify tag: ")))
(setq val (getstring t "\nSpecify new value: "))
)
(repeat (setq idx (sslength sel))
(LM:setattributevalue (ssname sel (setq idx (1- idx))) tag val)
)
)
(princ)
)
;; Set Attribute Value-Lee Mac
;; Sets the value of the first attribute with the given tag found within the block, if present.
;; blk - Block (Insert) Entity Name
;; tag - Attribute TagString
;; val - Attribute Value
;; Returns: Attribute value if successful, else nil.
(defun LM:setattributevalue ( blk tag val / enx )
(if (= "ATTRIB" (cdr (assoc 0 (setq enx (entget (setq blk (entnext blk)))))))
(if (= (strcase tag) (strcase (cdr (assoc 2 enx))))
(if (entmod (subst (cons 1 val) (assoc 1 enx) enx))
(progn
(entupd blk)
val
)
)
(LM:setattributevalue blk tag val)
)
)
)
(princ)
李刚刚赢了我，阿威尔还在这里
(defun c:caval ( / i p1 p2 ss blk attlst attname newval)
(princ "\nSelect blocks :")
(if (and (setq p1 (getpoint "\nFirst corner : ")) (setq p2 (getcorner p1 "\nSecond corner : "))
(setq ss (ssget "c" p1 p2 (list (cons 0 "insert"))))(setq i -1))
(while (setq blk (ssname ss (setq i (1+ i))))
(setq attlst (append attlst (mapcar 'vla-get-tagstring (vlax-invoke (vlax-ename->vla-object blk) 'getattributes)))))
)
(if (and (setq attname (cfl (rdup attlst))) (setq i -1)
(setq newval (getstring (strcat "\nNew value for attribute " attname " : "))))
(while (setq blk (ssname ss (setq i (1+ i))))
(vl-some '(lambda (x)(if (= attname (vla-get-tagstring x))(vla-put-textstring x newval)))
(vlax-invoke (vlax-ename->vla-object blk) 'getattributes)))
)
)
; chose from list
(defun cfl (l / f p d r)
(and (setq p (open (setq f (vl-filename-mktemp ".dcl")) "w"))
(princ "cfl:dialog{label=\"Choose\";:list_box{key=\"lb\";}ok_cancel;}" p)
(not (setq p (close p)))(< 0 (setq d (load_dialog f)))(new_dialog "cfl" d)
(progn
(start_list "lb")(mapcar 'add_list l)(end_list)
(action_tile "lb" "(setq r (nth (atoi $value) l))(done_dialog 1)")
(action_tile "accept" "(setq r (get_tile \"lb\"))(done_dialog 1)")
(action_tile "cancel" "(setq r nil)(done_dialog 0)")
(start_dialog)(unload_dialog d)(vl-file-delete f)
)
)
(cond ((= r "") nil)(r r)(t nil))
)
;remove duplicates
(defun rdup ( i / o ) (vl-remove-if '(lambda (x) (cond ((vl-position x o) t) ((setq o (cons x o)) nil))) i))
; auto run when loaded
(c:caval) 这正是我想要的。
非常感谢，
洛辛斯基 @rlx、FWIW注意：
相当于：
(setq attlst (append attlst (mapcar 'vla-get-tagstring (vlax-invoke (vlax-ename->vla-object blk) 'getattributes))))
我不认为有理由故意忽略这一点？ 李，
有没有办法添加在任何选定块中未找到指定标记的指示，然后提示重新输入？这将有利于输入标签时的拼写错误。
请尝试以下操作：
(defun c:setattval ( / att ent enx idx lst sel tag val )
(if (setq sel (ssget "_:L" '((0 . "INSERT") (66 . 1))))
(progn
(repeat (setq idx (sslength sel))
(setq ent (entnext (ssname sel (setq idx (1- idx))))
enx (entget ent)
)
(while (= "ATTRIB" (cdr (assoc 0 enx)))
(setq lst (cons (cons (strcase (cdr (assoc 2 enx))) enx) lst)
ent (entnext ent)
enx (entgetent)
)
)
)
(while
(and (/= "" (setq tag (strcase (getstring "\nSpecify tag: "))))
(not (assoc tag lst))
)
(princ (strcat "\nAttribute tag \"" tag "\" not found in selection."))
)
(if (/= "" tag)
(progn
(setq val (cons 1 (getstring t "\nSpecify new value: ")))
(while (setq att (assoc tag lst))
(if (entmod (subst val (assoc 1 (cdr att)) (cdr att)))
(entupd (cdr (assoc -1 (cdr att))))
)
(setq lst (cdr (member att lst)))
)
)
)
)
)
(princ)
) 李，
效果很好。再次感谢。
洛辛斯基 不客气！ 介意换一个李吗？
希望使lisp不需要完整的属性名。例如：
如果属性是TAGSTRIP，您可以只键入TAG。然而，如果有两个属性（例如TAG1和TAG2），它会要求您更具体。
此外，您能计算出在lisp完成时有多少块受到更改的影响吗？
我经常使用lisp，它节省了我很多时间。再次感谢。
页:
[1]
2