大家都来晒晒自己画图中比较常用的代码（使用平率高，绘图效率快）

--@-----

不管是自己的代码，还是别人的都来贴个吧，相互提高效率。我先发个文字刷的（别人的）每天都用到，可以刷块内文字，引线上的文字，天正标高及图名：(defun c:22 (/ #errxts $orr buk en1 ent i name name1 snap ss tp ty uu)
   (defun #errxts (s)         ; 出错处理程序
     (redraw name 4)
     (setvar "nomutt" 0)
     (setvar "PICKBOX" buk)
     (setvar "osmode" snap)
     (command ".UNDO" "E")
     (setq *error* $orr)
     (princ)
   )
   (setq $orr *error*)
   (setq *error* #errxts)
   (vl-load-com)          ; 主程序开始
   (setvar "cmdecho" 0)
   (command ".UNDO" "BE")
   (setq snap (getvar "osmode"))
   (setvar "osmode" 0)
   (setq buk (getvar "PICKBOX"))
   (setvar "PEDITACCEPT" 1)        ; 下面程序选择合适的源对象，如没选到重新选
   (while (not (and
   (setq name1 (nentsel "\n选择源对象:"))
   (setq name (car name1))
   (setq ent (entget name))
   (setq ty (cdr (assoc 0 ent)))
   (member ty '("TEXT" "MTEXT"
     "LWPOLYLINE" "CIRCLE"
     "INSERT" "LINE"
     "ARC" "HATCH"
     "DIMENSION" "ATTRIB"
     "TCH_ARROW" "TCH_TEXT"
     "TCH_DRAWINGNAME" "TCH_MULTILEADER"
     "TCH_ELEVATION"
    )
   )
        )
   )
     (if (= 52 (getvar "errno"))
       (vl-exit-with-error "")
     )
   )           ; 下面程序加了一个判断，如果源对象选择的是块，且不是属性或者块内文字，则认为选择的是块
   (if (and
(not (member ty '("TEXT" "MTEXT"
         "ATTRIB"
        )
       )
)
(= (type (car (last name1))) 'ename)
(= (cdr (assoc 0 (entget (car (last name1))))) "INSERT")
       )
     (setq name (car (last name1))
    ent (entget name)
    ty (cdr (assoc 0 ent))
     )
   )
   (redraw name 3)
   (setvar "nomutt" 1)
   (setvar "PICKBOX" (fix (+ 1 (* 1.2 buk))))
   (cond           ; 1、 如果源对象是文字、天正文字或者块内文字或者属性，则执行。。。
     ((member ty '("TEXT" "MTEXT"
        "ATTRIB" "TCH_TEXT"
        "TCH_ARROW" "TCH_DRAWINGNAME"
        "TCH_MULTILEADER" "TCH_ELEVATION"
       )
      )
       (setq uu (cdr (assoc 1 ent)))
       (princ (strcat "\n选择目标对象:<文字相同>  T = " "\"" uu "\""))
       (while t
(setq ss (ssget ":S" '((0 . "TEXT,MTEXT,INSERT,TCH_ARROW,TCH_TEXT,TCH_DRAWINGNAME,TCH_MULTILEADER,TCH_ELEVATION"))))
(if (= (caar (setq name1 (ssnamex ss 0))) 1) ; 如果目标文字是单选块内文字或者属性或普通文字，则执行。。。
    (progn
      (setq ent (ssname ss 0)
     en1 (car (nentselp (trans (cadr (last (car name1))) 0 1)))
     tp (cdr (assoc 0 (entget en1)))
      )
      (cond
        ((member tp '("TEXT" "MTEXT"
    "ATTRIB"
          )
         )
   (vla-put-textstring (vlax-ename->vla-object en1) uu)
   (entupd en1)
   (entupd ent)
        )
        ((member tp '("TCH_TEXT" "TCH_ELEVATION"
    "TCH_ARROW"
          )
         )
   (vlax-put-property (vlax-ename->vla-object en1) 'text uu)
        )
        ((= tp "TCH_DRAWINGNAME")
   (vlax-put-property (vlax-ename->vla-object en1) 'nametext uu)
        )
        ((= tp "TCH_MULTILEADER")
   (vlax-put-property (vlax-ename->vla-object en1) 'uptext uu)
        )
      )
    )
    (progn         ; 如果目标文字多选的是普通文字，则循环更新文字内容
      (repeat (setq i (sslength ss))
        (setq ent (entget (setq en1 (ssname ss (setq i (1- i))))))
        (setq tp (cdr (assoc 0 ent)))
        (cond
   ((member tp '("TEXT" "MTEXT"))
     (entmod (subst
        (cons 1 uu)
        (assoc 1 ent)
        ent
      )
     )
   )
   ((member tp '("TCH_TEXT" "TCH_ELEVATION"
      "TCH_ARROW"
     )
    )
     (vlax-put-property (vlax-ename->vla-object en1) 'text uu)
   )
   ((= tp "TCH_DRAWINGNAME")
     (vlax-put-property (vlax-ename->vla-object en1) 'nametext uu)
   )
   ((= tp "TCH_MULTILEADER")
     (vlax-put-property (vlax-ename->vla-object en1) 'uptext uu)
   )
        )
      )
    )
)
       )
     )
     ((member ty '("CIRCLE" "ARC"))     ; 3、 如果源对象是圆，则循环更新目标圆的直径
       (setq uu (cdr (assoc 40 ent)))
       (princ (strcat "\n选择目标对象:<半径相同>  R = " (rtos uu 2 2)))
       (repeat (setq i (sslength (setq ss (ssget '((0 . "CIRCLE,ARC"))))))
(setq ent (entget (ssname ss (setq i (1- i)))))
(entmod (subst
     (cons 40 uu)
     (assoc 40 ent)
     ent
   )
)
       )
     )
     ((= ty "INSERT")         ; 4、 如果源对象是块，则拷贝源块到目标块的位置，删除目标块
       (princ " \n选择目标对象:<块相同>")
       (setq uu (cdr (assoc 10 ent)))
       (repeat (setq i (sslength (setq ss (ssget '((0 . "INSERT"))))))
(setq ent (entget (ssname ss (setq i (1- i)))))
(command "COPY" name "" uu (cdr (assoc 10 ent)))
       )
       (command "ERASE" ss "")
     )
     ((= ty "LWPOLYLINE")        ; 5、 如果源对象是多义线，则转化目标对象的线宽
       (if (not (setq uu (cdr (assoc 43 ent))))
(setq uu (cdr (assoc 40 ent)))
       )
       (princ (strcat "\n选择目标对象:<线宽相同>   W = " (rtos uu 2 2)))
       (repeat (setq i (sslength (setq ss (ssget '((0 . "LINE,ARC,POLYLINE,LWPOLYLINE,CIRCLE"))))))
(setq name1 (ssname ss (setq i (1- i)))
        tp (cdr (assoc 0 (setq ent (entget name1))))
)
(cond
    ((member tp '("LINE" "ARC"))
      (command "pedit" name1 "w" uu "x")
    )
    ((member tp '("POLYLINE" "LWPOLYLINE"))
      (command "pedit" name1 "w" uu "x")
    )
    ((= tp "CIRCLE")
      (command "donut" (- (* (cdr (assoc 40 ent)) 2) uu) (+ (* (cdr (assoc 40 ent)) 2) uu) (cdr (assoc 10 ent)) "")
      (entdel name1)
    )
)
       )
     )           ; 6、其他的一些情况，则调用特性匹配命令
     ((member ty '("LINE" "HATCH"
        "DIMENSION"
       )
      )
       (princ "\n选择目标对象:<特性匹配>")
       (command "matchprop" name (ssget (list (cons 0 ty))) "")
     )
   )
   (redraw name 4)
   (setvar "nomutt" 0)
   (setvar "PICKBOX" buk)
   (setvar "osmode" snap)
   (command ".UNDO" "E")
   (setq *error* $orr)
   (princ)
)

--@-----

闲的没事的，大家都过来贴一个厉害的，比去找快多来

HLCAD

支持楼主，来个自己原创的：

2. ;;;-------------------------------------------------
   
3. ;;; 启用资源管理器, 打开相应图纸所在目录并选中该文件
   
4. (defun c:ddd (/ path dwgname explor)
   
5.   (setq explor (findfile"C:\\WINDOWS\\explorer.exe")
   
6.   path   (getvar "DWGPREFIX")
   
7. ;  dwgname (getvar "DWGNAME")
   
8.   dwgname (strcat """ (getvar "DWGNAME") """)
   
9.   )
   
10.   (cond
    
11.     ((and (not (null dos_execute)) explor path dwgname)
    
12.      (dos_execute (strcat explor " /e, " path ", /select, " path dwgname)))
    
13.     ((and explor path dwgname)
    
14.      (startapp (strcat explor " /e, " path ", /select, " path dwgname)))
    
15.     (t (princ "\n无法启用资源管理器!"))
    
16.     )
    
17.   (princ))
    
18. ;;;-------------------------------------------------
    

;;;-------------------------------------------------<br /> ;;; 启用资源管理器, 打开相应图纸所在目录并选中该文件<br /> (defun c:ddd (/ path dwgname explor)<br />   (setq explor (findfile"C:\\WINDOWS\\explorer.exe")<br />   path   (getvar "DWGPREFIX")<br /> ;  dwgname (getvar "DWGNAME")<br />   dwgname (strcat """ (getvar "DWGNAME") """)<br />   )<br />   (cond<br />     ((and (not (null dos_execute)) explor path dwgname)<br />      (dos_execute (strcat explor " /e, " path ", /select, " path dwgname)))<br />     ((and explor path dwgname)<br />      (startapp (strcat explor " /e, " path ", /select, " path dwgname)))<br />     (t (princ "\n无法启用资源管理器!"))<br />     )<br />   (princ))<br /> ;;;-------------------------------------------------<br />

Lispboy

楼上两位朋友，能同时把演示动画也贴出来就完美了。

laibinwu

平面图上钻孔一般都是块，这个可以快速输出坐标，很简单的程序但是很实用

1. (defun c:tt (/ ss i pt)
   
2.   (setq        ss (ssget '((0 . "INSERT")))
   
3.         i  0
   
4.         pt nil
   
5.   )
   
6.   (repeat (sslength ss)
   
7.     (setq pt (cdr (assoc 10 (entget (ssname ss i)))))
   
8.     (setq i (1+ i))
   
9.     (princ (strcat "\n "
   
10.                    (itoa i)
    
11.                    "| X = "
    
12.                    (rtos (cadr pt) 2 4)
    
13.                    ", Y = "
    
14.                    (rtos (car pt) 2 4)
    
15.            )
    
16.     )
    
17.   )
    
18.   (princ)
    
19. )

(defun c:tt (/ ss i pt)<br />   (setq        ss (ssget '((0 . "INSERT")))<br />         i  0<br />         pt nil<br />   )<br />   (repeat (sslength ss)<br />     (setq pt (cdr (assoc 10 (entget (ssname ss i)))))<br />     (setq i (1+ i))<br />     (princ (strcat "\n "<br />                    (itoa i)<br />                    "| X = "<br />                    (rtos (cadr pt) 2 4)<br />                    ", Y = "<br />                    (rtos (car pt) 2 4)<br />            )<br />     )<br />   )<br />   (princ)<br /> )

ysq101

不同专业相差大太啊~~~~~~~~~

--@-----

当时急着发帖子了，忘了把作者的名字发上来，这里很感谢下作者langjs本人，以前的文字刷也能刷天正文字的，这个还能刷引线上的文字

牢固

这样的帖子太空泛了！可以对具体的需求提出问题！

ucuc2003

好像是明经论坛langjs大侠的相同刷2.0

ucuc2003

(defun C:kh (/ s1)                ;快速选择对象，填充图案
   (setvar "cmdecho" 0)
   (setq ytc_d (getvar "hpseparate"))
   (setvar "hpassoc" 1)  ;控制填充图案是否关联(1:是；0:否)
   (setvar "hpseparate" 0)  ;控制是否创建独立填充图案(1:是；0:否)
   (princ "\n快捷填充，请选择填充区域：(***跳过则为拾取内部点填充）")
   (if (setq s1 (ssget))
       (command "bhatch" "s" s1 "" "")
       (progn
            (princ "\n请拾取填充内部点：")
            (command "bhatch" pause)
        );progn
    );if
   (setvar "hpseparate" ytc_d)
   (princ)
);defun

--@-----

ucuc2003 发表于 2013-8-2 15:15
好像是明经论坛langjs大侠的相同刷2.0

是的，就是他的刷子，呵呵 大家每人发个经典，相互利用下资源也好

--@-----

ucuc2003 发表于 2013-8-2 15:27
(defun C:kh (/ s1)                ;快速选择对象，填充图案
   (setvar "cmdecho" 0)
   (setq ytc_d ( ...

能否优化下上次填充的是以拾取点或选择对象，下次填充的方式就是默认的上次填充方式。比如要填充的都是拾取内部点，那就要每次填充都要两次空格下，虽比原CAD的填充快点，还是希望功能尽可能完美下{:soso_e100:}

qht5566

HLCAD 发表于 2013-8-1 07:26
支持楼主，来个自己原创的：

(defun c:FE ()
  (prinC "打开当前图档所在的文件夹")
  (if (= (getvar "dwgtitled") 0)
    (alert "请先保存文件")
    (startapp (strcat "explorer /select, "
              (getvar "dwgprefix")
              (getvar "dwgname")
              ", /e"
          )
    )
  )
  (princ)
)

NET-JOB

推荐下小菜的选择易，建选择集，查图元信息，都用到

qht5566

再发一个，我也不知道作者。。抱歉。。

2.           ;***********************************************矩形填充
   
3. (defun c:FF (/ pp1 pp2 ppa ppb osn redent eedel ptlist i)
   
4.   (if (= (getvar "hpname") "")
   
5.     (prompt "no hatch pattern selected: ")
   
6.     (progn
   
7.       (setvar "cmdecho" 0)
   
8.       (setq pp1 (getpoint "选择一个点:"))
   
9.       (setq pp2 (getpoint "下一点:"))
   
10.       (if (or (= pp1 nil) (= pp2 nil))
    
11.   ""
    
12.   (progn
    
13.     (setq osn (getvar "osmode"))
    
14.     (setvar "osmode" 0)
    
15.     (setq ppa (list (car pp2) (cadr pp1)))
    
16.     (setq ppb (list (car pp1) (cadr pp2)))
    
17.     (setq ptlist (list pp1 ppa pp2 ppb))
    
18.     (command "pline" pp1 ppa pp2 ppb "c")
    
19.     (setq eedel (entlast))
    
20.     (command "hatch" "" "" "" "l" "")
    
21.     (entdel eedel)
    
22.     (setq redent (ssget "f" ptlist))
    
23.     (if (= redent nil)
    
24.       ""
    
25.       (progn
    
26.         (setq i 1)
    
27.         (setq rden (ssname redent 0))
    
28.         (while rden
    
29.     (redraw rden)
    
30.     (setq rden (ssname redent i))
    
31.     (setq i (+ i 1))
    
32.         )
    
33. 
    
34.       )
    
35.       ;;progn
    
36.     )
    
37.     ;;end if
    
38.     (setvar "osmode" osn)
    
39. 
    
40.   )
    
41.       )
    
42.     )          ;end progn hpname
    
43.   )
    
44.   ;;end if hpname
    
45. )

          ;***********************************************矩形填充<br /> (defun c:FF (/ pp1 pp2 ppa ppb osn redent eedel ptlist i)<br />   (if (= (getvar "hpname") "")<br />     (prompt "no hatch pattern selected: ")<br />     (progn<br />       (setvar "cmdecho" 0)<br />       (setq pp1 (getpoint "选择一个点:"))<br />       (setq pp2 (getpoint "下一点:"))<br />       (if (or (= pp1 nil) (= pp2 nil))<br />   ""<br />   (progn<br />     (setq osn (getvar "osmode"))<br />     (setvar "osmode" 0)<br />     (setq ppa (list (car pp2) (cadr pp1)))<br />     (setq ppb (list (car pp1) (cadr pp2)))<br />     (setq ptlist (list pp1 ppa pp2 ppb))<br />     (command "pline" pp1 ppa pp2 ppb "c")<br />     (setq eedel (entlast))<br />     (command "hatch" "" "" "" "l" "")<br />     (entdel eedel)<br />     (setq redent (ssget "f" ptlist))<br />     (if (= redent nil)<br />       ""<br />       (progn<br />         (setq i 1)<br />         (setq rden (ssname redent 0))<br />         (while rden<br />     (redraw rden)<br />     (setq rden (ssname redent i))<br />     (setq i (+ i 1))<br />         )<br /> <br />       )<br />       ;;progn<br />     )<br />     ;;end if<br />     (setvar "osmode" osn)<br /> <br />   )<br />       )<br />     )          ;end progn hpname<br />   )<br />   ;;end if hpname<br /> )