新人第一次发帖

JS结构 · 发表于 2022-12-6 14:44:17

最近在画新建建筑底图时，经常画一些开洞符号

论坛上很多大佬开发了很强的代码
不过，本人小白，对一些高级代码比较难理解
就自己写一个比较麻烦的~
各位前辈大佬多批评指正~

(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:04:10

本帖最后由 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)
)

(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-6 21:45:51

本帖最后由 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 (/ 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) 
)

tryhi · 发表于 2022-12-6 15:34:25

(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效果更好

自贡黄明儒 · 发表于 2022-12-6 15:37:03

不错呀。开始入坑了。

liuhe · 发表于 2022-12-6 16:38:19

  (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)
   )
)
   )
参考上段代码，这样就不用重复新建图层了

wzg356 · 发表于 2022-12-6 19:57:44

可以了，达到目的就行，即使有小问题，自己的使用环境习惯注意就行了

JS结构 · 发表于 2022-12-6 20:43:32

tryhi 发表于 2022-12-6 15:34
(defun c:tt (/ #k d p1 p11 p2 p22 p3)
(setq #k (getvar "clayer")) ;;取得当前图层
(command "lay ...

海总出马，代码一下就高大上了

JS结构 · 发表于 2022-12-6 20:47:29

自贡黄明儒发表于 2022-12-6 15:37
不错呀。开始入坑了。

大佬见笑啦~~

JS结构 · 发表于 2022-12-6 20:53:02

liuhe 发表于 2022-12-6 16:38
(setq linetypeName "CENTER2")
(setq err (vl-catch-all-apply
'vla-Load

感谢大佬~ 不明觉厉！我还得多多学习

depgfdepgf · 发表于 2022-12-7 09:03:39

长宽比出来的洞口线比例不好看，希望再次改进下

账号		自动登录	找回密码
密码			注册