新人第一次发帖
最近在画新建建筑底图时，经常画一些开洞符号论坛上很多大佬开发了很强的代码
不过，本人小白，对一些高级代码比较难理解
就自己写一个比较麻烦的~
各位前辈大佬多批评指正~
(defun c:JS-HKD ( / a b c d x0 x1 y0 y1 p1 p2 p3 p4 p11 p22)
(setq #k (getvar "clayer")) ;;取得当前图层
(command "layer" "M" "S_辅助线" "C" 3 "" "")
(setq p1 (getpoint"\n输入矩形的一个角点"))
(setq p2 (getpoint"\n输入矩形的另一角点"))
;分离坐标
(setq a (car p1))
(setq b (cadr p1))
(setq c (car p2))
(setq d (cadr p2))
;判断取值
(setq x0 (min a c))
(setq y0 (min b d))
(setq x1 (max a c))
(setq y1 (max b d))
;赋值/对角坐标点
(setq p11 (list x0 y0))
(setq p22 (list x1 y1))
;读取差值
(setq -x (- x1 x0))
(setq -y (- y1 y0))
;给定折点
(setq p3 (list (+ x0 (/ -x 4))(+ y0 (* -y 0.6))))
;绘图
(command "rectangle" p11 p22 "")
(command "pline" p11 p3 p22 "")
(setvar "clayer" #k) ;;恢复原来图层
(princ)
)
本帖最后由 kucha007 于 2022-12-8 02:09 编辑
又试了一下，加了线型
(defun c:TT (/ Old_Cmd Old_OSM obj ptlist pmin pmax pmid co lt *ent*)
(setq Old_Cmd (getvar "cmdecho"))
(setq Old_OSM (getvar "OSMode"))
(defun *error* ( msg );定义出错函数
(setvar "cmdecho" Old_Cmd)
(setvar "OSMode" Old_OSM)
)
(setvar "cmdecho" 0)
(command "_.rectangle" "_fillet" 0.0) ;圆角归零
(while (/= 0 (getvar 'cmdactive))(vl-cmdf pause))
(setvar "OSMode" 0)
(if (and
(setq obj (entget (entlast)))
(setq ptlist
(vl-sort
(mapcar
'(lambda (pt)
(trans
(list
(car pt);X
(cadr pt);Y
(cdr (assoc 38 obj)) ;Z
)
0 1
)
);WCS to UCS
(mapcar 'cdr
(vl-remove-if '(lambda (x) (/= (car x) 10)) obj)
);获取WCS坐标
);获取UCS点集
'(lambda (a b)
(cond
((= (car a) (car b)) (< (cadr a) (cadr b)));如果x相等，就比较y
((< (car a) (car b))) ;如果x不相等，就比较x
)
)
) ;排序:先X后Y
)
(setq pmin (car ptlist))
(setq pmax (car (reverse ptlist)))
(setq pmid (mapcar '+
pmin
(mapcar '* (mapcar '- pmax pmin) '(0.25 0.6))
)
)
)
(progn
(command "_.pline" pmin pmid pmax "")
(setq *ent* (entget (entlast)))
(setq co 8);8号色
(setq lt "DASHED");线型
(if (assoc 62 *ent*)
(entmod (subst (cons 62 co) (assoc 62 *ent*) *ent*)) ;替换颜色
(entmod (append *ent* (list (cons 62 co)))) ;添加颜色
)
(if (not (tblsearch "ltype" lt))
(vla-load (vla-get-linetypes (vla-get-activedocument (vlax-get-acad-object))) lt "acadiso.lin")
)
(if (assoc 6 *ent*)
(entmod (subst (cons 6 lt) (assoc 6 *ent*) *ent*)) ;替换线型
(entmod (append *ent* (list (cons 6 lt)))) ;添加线型
)
)
)
(setvar "cmdecho" Old_Cmd)
(setvar "OSMode" Old_OSM)
(princ)
)
本帖最后由 kucha007 于 2022-12-7 04:44 编辑
也尝试了一下
(defun c:TT (/ Old_Cmd Old_OSM obj ptlist pmin pmax pmid Col *ent*)
(setq Old_Cmd (getvar "cmdecho"))
(setq Old_OSM (getvar "OSMode"))
(defun *error* ( msg );定义出错函数
(setvar "cmdecho" Old_Cmd)
(setvar "OSMode" Old_OSM)
)
(setvar "cmdecho" 0)
(command "_.rectangle" "_fillet" 0.0) ;圆角归零
(while (/= 0 (getvar 'cmdactive))(vl-cmdf pause))
(setvar "OSMode" 0)
(if (and
(setq obj (vlax-ename->vla-object (entlast)))
(setq ptlist (vl-sort
(list
(trans (vlax-curve-getPointAtParam obj 0) 0 1)
(trans (vlax-curve-getPointAtParam obj 1) 0 1)
(trans (vlax-curve-getPointAtParam obj 2) 0 1)
(trans (vlax-curve-getPointAtParam obj 3) 0 1)
) ;list
'(lambda (a b)
(cond
((= (car a) (car b));如果x相等，就比较y
(< (cadr a)(cadr b)));
((< (car a) (car b)));如果x不相等，就比较x
)
)
)
)
(setq pmin (car ptlist))
(setq pmax (car (reverse ptlist)))
(setq pmid (mapcar '+
pmin
(mapcar '* (mapcar '- pmax pmin) '(0.25 0.6))
)
)
)
(progn
(command "_.pline" pmin pmid pmax "")
(setq *ent* (entget (entlast)))
(setq Col 8) ;设置颜色
(if (assoc 62 *ent*)
(entmod (subst (cons 62 Col) (assoc 62 *ent*) *ent*)) ;替换颜色
(entmod (append *ent* (list (cons 62 Col)))) ;添加颜色
)
)
)
(setvar "cmdecho" Old_Cmd)
(setvar "OSMode" Old_OSM)
(princ)
)
(defun c:tt (/ #k d p1 p11 p2 p22 p3)
(setq #k (getvar "clayer")) ;;取得当前图层
(command "layer" "M" "S_辅助线" "C" 3 "" "")
(setq p1 (getpoint"\n输入矩形的一个角点"))
(setq p2 (getcorner p1"\n输入矩形的另一角点"))
(setq p11 (mapcar 'min p1 p2))
(setq p22 (mapcar 'max p1 p2))
(setq d(mapcar '- p22 p11))
(setq p3(mapcar '+ p11 (mapcar '* d'(0.25 0.6))))
(command "rectangle" p11 p22 "")
(command "pline" p11 p3 p22 "")
(setvar "clayer" #k) ;;恢复原来图层
(princ)
)
用getcorner效果更好 不错呀。开始入坑了。:lol (setq linetypeName "CENTER2")
(setq err (vl-catch-all-apply
'vla-Load
(list (vla-get-Linetypes AcadDocument)
linetypeName
"acad.lin"
)
)
)
(IF (NOT (TBLSEARCH "LAYER" zxtc))
(entmake
(list '(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(70 . 0)
'(6 . "Center2")
(cons 62 x)
(cons 2 zxtc)
)
)
)
参考上段代码，这样就不用重复新建图层了 可以了，达到目的就行，即使有小问题，自己的使用环境习惯注意就行了 tryhi 发表于 2022-12-6 15:34
(defun c:tt (/ #k d p1 p11 p2 p22 p3)
(setq #k (getvar "clayer")) ;;取得当前图层
(command "lay ...
海总出马，代码一下就高大上了 自贡黄明儒 发表于 2022-12-6 15:37
不错呀。开始入坑了。
大佬见笑啦~~:lol liuhe 发表于 2022-12-6 16:38
(setq linetypeName "CENTER2")
(setq err (vl-catch-all-apply
'vla-Load
感谢大佬~ 不明觉厉！我还得多多学习 长宽比出来的洞口线比例不好看，希望再次改进下
页:
[1]
2