求助，麻烦帮忙增加一个记忆上一次填充的功能 怎么折腾都弄不好 感谢大佬
本帖最后由 pizi158545086 于 2025-3-11 16:32 编辑(defun C:12 (/ ent ss tc_name tcm tcb tcj tc_col)
(setvar "cmdecho" 0)
(princ "继承填充（先选择填充，再选择要填充的区域）")
(setq ent (entsel "\n选择填充对象<退出>:"))
(setq tcm (cdr (assoc 2 (entget (car ent)))));获取填充图案的名称
(setq tc_name (cdr (assoc 8 (entget (car ent)))));获取填充图案的图层名
(if (= tcm "SOLID")
(setvar "hpname" tcm)
(progn
(setq tcb (cdr (assoc 41 (entget (car ent)))));获取填充图案的比例
(setq tcj (cdr (assoc 52 (entget (car ent)))));获取填充图案的角度（这个值是以弧度返回的）
(setq tc_col (cdr (assoc 62 (entget (car ent)))));获取填充图案的颜色
(setvar "hpname" tcm)
(setvar "hpscale" tcb)
(setvar "hpang" tcj)
)
)
(while (JCTC_z))
(princ)
)
(defun JCTC_z ()
(setvar "cmdecho" 0)
(defun *Error* (msg)
(if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,*EXIT*,")))
(princ))
);defun *Error*
(setvar "measurement" 1)
(setvar "measureinit" 1)
(princ "\n请选择填充区域：(提示:空选则为拾取内部点填充）")
(if (setq ss (ssget))
(command "bhatch" "s" ss "" "")
(progn
(princ "\n请拾取填充内部点：")
(command "bhatch" pause pause)
);progn
);if
(command "_.undo" "_group")
(command "change" (entlast) "" "P" "la" tc_name ""
"change" (entlast) "" "P" "c" "bylayer" "")
(command "_.undo" "_end")
(princ)
)
类似图片增加一个空格使用上一次的填充
本帖最后由 ssyfeng 于 2025-3-11 16:51 编辑
随便修改了一下，凑合着用吧
又是AI写的代码？ ssyfeng 发表于 2025-3-11 15:36
又是AI写的代码？
不是站里找的代码 ssyfeng 发表于 2025-3-11 16:24
随便修改了一下，凑合着用吧
非常感谢 ，我想问下填充的颜色变成8号色，怎么可以改成随原填充的颜色呢？ pizi158545086 发表于 2025-3-11 16:30
非常感谢 ，我想问下填充的颜色变成8号色，怎么可以改成随原填充的颜色呢？
已更新，重新下载试试 ssyfeng 发表于 2025-3-11 16:52
已更新，重新下载试试
可以了 非常感谢 (defun c:tt ()
(defun aaa ()
(setvar 'cecolor (itoa co))
(setvar 'clayer la)
(if (= hn "_USER")
(command "-bhatch" "p" "U" dr hs "y" "")
(command "-bhatch" "p" hn hs dr "")
)
(if (setq ss (ssget))
(command "-bhatch" "s" ss "" "")
(progn
(prompt "\n请拾取填充内部点：\n")
(command "bhatch" pause)
(while (> (getvar "CMDACTIVE") 0) (command PAUSE))
)
)
)
(if (and (setq s1 (car (entsel "\n选择填充源图案[空格使用上次设置]: ")))
(= (cdr (assoc 0 (entget s1))) "HATCH")
)
(setq ob (vlax-ename->vla-object s1)
hn (vla-get-patternname ob)
hs (vla-get-patternscale ob)
ha (vla-get-patternangle ob)
la (vla-get-layer ob)
co (vla-get-color ob)
dr (* 180 (/ ha pi))
aa (aaa)
)
(aaa)
)
(princ)
) xyp1964 发表于 2025-3-11 17:04
这个会改变了默认的绘图图层和颜色 pizi158545086 发表于 2025-3-11 17:30
这个会改变了默认的绘图图层和颜色
(defun c:tt ()
"记忆填充"
(setq oco (getvar 'cecolor)
ola (getvar 'clayer)
)
(defun aaa ()
(setvar 'cecolor (itoa co))
(setvar 'clayer la)
(if (= hn "_USER")
(command "-bhatch" "p" "U" dr hs "y" "")
(command "-bhatch" "p" hn hs dr "")
)
(if (setq ss (ssget))
(command "-bhatch" "s" ss "" "")
(progn
(prompt "\n请拾取填充内部点：\n")
(command "bhatch" pause)
(while (> (getvar "CMDACTIVE") 0) (command PAUSE))
)
)
)
(if (and (setq s1 (car (entsel "\n选择填充源图案[空格使用上次设置]: ")))
(= (cdr (assoc 0 (entget s1))) "HATCH")
)
(setq ob (vlax-ename->vla-object s1)
hn (vla-get-patternname ob)
hs (vla-get-patternscale ob)
ha (vla-get-patternangle ob)
la (vla-get-layer ob)
co (vla-get-color ob)
dr (* 180 (/ ha pi))
aa (aaa)
)
(aaa)
)
(setvar 'cecolor oco)
(setvar 'clayer ola)
(princ)
)
页:
[1]
2