识别线型指定层
本帖最后由 惜惜2 于 2024-9-8 22:29 编辑帮忙写一个LISP可以把块炸开然后放入0层，0层的颜色以及线型线宽随层，其中需要优先点选一个图元(同时全选相同线型的所有图元）指定到Bend层，如果BEND层不存在则自动创建，bend层颜色黄色，线型随层，线宽随层，点选的图元颜色随层，线宽随层，然后把剩余的图元放入0层。
(defun C:A11()
(vl-cmdf "qaflags" 1 "explode" (ssget "x") "" "qaflags" 0)
(if (= (getvar "cmdactive") 0)
(progn
(vl-cmdf "change" (ssget "x") "" "p" "la" 0 "")
(vl-cmdf "change" (ssget "x") "" "p" "c" "ByLayer" "")
(vl-cmdf "change" (ssget "x") "" "p" "LT" "ByLayer" "")
)
)
(command"_copyclip"(ssget "x" '((8 . "0"))))
(command"")
(princ)
)
别人帮你回答了问题，你却设置成仅作者可见？你也太自私了吧。这不利于论坛的发展，别人也无心来回答你的问题了。 qazxswk 发表于 2024-9-5 03:27
别人帮你回答了问题，你却设置成仅作者可见？你也太自私了吧。这不利于论坛的发展，别人也无心来回答你的问 ...
(defun c:A11 ()
(vlax-for blockref (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))
(if (vlax-property-available-p blockref 'Explode)
(vlax-invoke blockref 'Explode)
)
)
(setq bend-layer-exists nil)
(setq acad-doc (vla-get-activedocument (vlax-get-acad-object)))
(setq layers (vla-get-layers acad-doc))
(vlax-for layer layers
(if (and layer (equal (strcase (vla-get-name layer)) "BEND"))
(setq bend-layer-exists t)
)
)
(if (not bend-layer-exists)
(progn
(setq newLayer (vla-add layers "BEND"))
(vla-put-color newLayer 2) ;
(setq linetypes (vla-get-linetypes acad-doc))
(setq byLayerLinetype nil)
(vlax-for linetype linetypes
(if (equal (strcase (vla-get-name linetype)) "BYLAYER")
(setq byLayerLinetype linetype)
)
)
(if byLayerLinetype
(setq byLayerLinetypeName (vla-get-name byLayerLinetype))
)
(vla-put-lineweight newLayer -1) ; -1 表示 BYLAYER
)
)
(setq picked-ent (car (entsel "\n 选择一个图元: ")))
(if picked-ent
(progn
(setq ent-data (entget picked-ent))
(if ent-data
(progn
(setq linetype (cdr (assoc 6 ent-data)))
(setq filter (list (cons 0 (cdr (assoc 0 ent-data))) (cons 6 linetype)))
(setq same-linetype-ss (ssget "_X" filter))
(if same-linetype-ss
(progn
(setq i 0)
(repeat (sslength same-linetype-ss)
(setq entity (ssname same-linetype-ss i))
(if entity
(progn
(setq ent-obj (vlax-ename->vla-object entity))
(vla-put-layer ent-obj "BEND")
)
)
(setq i (1+ i))
)
)
(princ "\n 没有找到相同线型的图元.")
)
(setq remaining-ss (ssget "_X" (list (cons 0 (cdr (assoc 0 ent-data))))))
(if remaining-ss
(progn
(setq j 0)
(repeat (sslength remaining-ss)
(setq entity (ssname remaining-ss j))
(if entity
(progn
(setq ent-obj (vlax-ename->vla-object entity))
(vla-put-layer ent-obj "0")
(vla-put-linetype ent-obj byLayerLinetypeName)
(vla-put-lineweight ent-obj -1)
)
)
(setq j (1+ j))
)
)
(princ "\n 没有剩余图元.")
)
)
(princ "\n 无法获取实体数据.")
)
)
(princ "\n 未选择图元.")
)
(princ)
)
大佬帮忙改下
页:
[1]