文字 线 工具集

huangyusen2000

(defun c:HH()
(alert"\CD                 线段求和                         BS             多块同时缩放
\AREAH            面积求和                        BTJ            块统计
\DDT               打断插文字                      DIMA            测量弧长并标注弧长
\CV                多重复制                         DIB    将线等分并断开
\CP                圆变多边形                      COH      复制标高后同时改变标高数字
\CR                改多圆半径                      XT             分解文字
\CM                沿某方向多重复制             DX             改大小写
\PN                改线弧圆宽度                    CUT          剪选圈里的所有线
\LPN               按层改线弧圆宽度              LU           线自定义断实
\C1~C9            改颜色                            ZZ           z坐标值归零
\AN/0/30/45/60    旋转绘图角度               BTH          块替换
\LOCKUP             加密                     CHR       直接修改FILLET半径来修改圆角
\------------------------------------------------------------------------------
\LL              将所选对象的层变为当前层         CW    关闭所有窗口
\VL             只显示被选对象所在层               KJG   图像边框开关
\LQ              快速改对象的层                  \XKK             把实线按指定的距离断开
\LK              解锁图层                                   ztmj  总面积标注-平方米/亩/公顷
\OL/FL/KL      关闭/冻结/锁定所选对象所在的层         FT  文字字体替代
\W1/W2/W3      显示/解冻/解锁全部层          PLE    将所有line变成闭合多义线
\W123           显示+解锁+解冻全部层           GV     斜轴线对正垂直显示
\DIML           创建DIM图层                           CM     沿某方向多次复制
\IT              插入日期及时间                      CPC    复制到当前层
\TC              数字递增复制                        SPTP   SPLINE线转POLYLINE
\LJ              连接断线程序                         STPO   画双跑楼梯剖面
\CJF             复制的均分D距离                 ARZQ   增强阵列可以等距
\HJT             画箭头                                  TTA    合并字体到一起
\------------------------------------------------------------------------------
\n  [新博国际 http://www.newbo.zj.com   QQ:1173114135］        更新:2005.03.10
"))
;*******************;测量弧的线性长度并在绘图平面标注弧长

        (defun dtr (x)
        (* pi (/ x 180.00))
        )

        (defun rtd (y)
        (/ (* 180 y) pi)
        )

       (defun right ()
         (setq ang1 (angle ep cen)
              ang2 (angle ep1 cen)
              ang (- ang1 ang2)
              arclen (abs(* rad ang))
         )
        )

        (defun left ()
        (setq ang (- a1 a2))
        (setq arclen (abs(* rad ang)))
        )

        (defun C:dima (/ ang1 ang2 ang arclen rad pick_pt pick_ang
        cen pick_pt extpt1 extpt2 extpt3 extpt4 ep a1 a2 ep1 e6 e7 ent4 temp_pt1
        temp_pt2 temp_pt3 temp_pt4 e1 e2 e3 e4 text_ang th txt1 txt e5 ep1a epa
        ep1a1 epa1 search type)
        (setvar "cmdecho" 0)
        (setvar "blipmode" 0)
        (setq cn (entsel "\n选择想要标注的弧线： "))
        (setq dn (car cn))
        (setq aw (entget dn))
        (setq type (cdr(assoc 0 aw)))
     (if (= type "ARC")
          (progn
        (setq a1 (cdr (assoc 50 aw)))
        (setq a2 (cdr (assoc 51 aw)))
        (setq cen (cdr (assoc 10 aw))
              rad (cdr (assoc 40 aw)))
        (setq ep (polar cen (cdr (assoc 50 aw)) rad)
              ep1 (polar cen (cdr (assoc 51 aw)) rad))
                  (if (< a1 a2) (left)
                      (right)
                   )
         (prompt "\n请确定尺寸线的位置： ")
         (command "dim" "angular" "" cen ep ep1 pause (rtos arclen) pause "exit")
            )
        (prompt "\n所选实体并非弧线,请重新选择：")
    )
    (setvar "clayer" "0")
    (setvar "cmdecho" 1)
    (setvar "blipmode" 1)
                         (princ)
)
;****************************************************合并字体到一起
;Jion 2 text strings
(defun c:TTA (/ en1 en2 enn st1 st2 stnew)
   (setvar "cmdecho" 0)
   (prompt "\n***select 1st text string: ")
   (setq en1 (entget (car (entsel))))
   (if (= "TEXT" (cdr (assoc 0 en1))) (progn
      (prompt "\n***select 2nd text string: ")
      (setq en2 (entget (car (entsel))))
      (if (= "TEXT" (cdr (assoc 0 en2))) (progn
         (setq st1 (assoc 1 en1))
         (setq st2 (assoc 1 en2))
         (setq stnew (strcat (cdr st2) (cdr st1)))
         (setq enn en2)
         (setq enn (subst (cons 1 stnew) st2 enn))
         (entmod enn)
         (if (/= en1 en2) (entdel (cdr (car en1))))
      )(princ "Select a text please."))
   )(princ "Select a text please."))
   (princ)
)


;Break a text string
(defun c:TTB(/ en1 ang height str len ch index pos strnew entnew strold )
   (setvar "cmdecho" 0)
   (setvar "aunits" 3)
   (prompt "\n***select a text string: ")
   (setq en1 (entget (car (entsel))))
   (if (= "TEXT" (cdr (assoc 0 en1))) (progn
      (setq height (cdr (assoc 40 en1)))
      (setq ang (cdr (assoc 50 en1)))
      (setq str (cdr (assoc 1 en1)))
      (setq len (strlen str))
      (setq en1 (subst (cons 1 "") (assoc 1 en1) en1))
      (entmod en1)
      (command "_.UCS" "world")
      (command "_.UCS" "z" ang)
      (setvar "blipmode" 0)
      (setq index 1  pos 1)
      (while (<= index len)
         (setq ch (substr str index 1))
         (if (> (ascii ch) 127) (progn
            (setq strnew (substr str index 2))
            (command "_.COPY" (cdr (car en1)) ""
                     (list 0 0) (list (* pos height) 0))
            (setq entnew (entget (entlast)))
            (setq strold (assoc 1 entnew))
            (setq entnew (subst (cons 1 strnew) strold entnew))
            (entmod entnew)
            (setq index (+ index 2))
         )(progn
            (setq strnew (substr str index 1))
            (command "_.COPY" (cdr (car en1)) ""
                     (list 0 0) (list (* pos height) 0))
            (setq entnew (entget (entlast)))
            (setq strold (assoc 1 entnew))
            (setq entnew (subst (cons 1 strnew) strold entnew))
            (entmod entnew)
            (setq index (1+ index))
         ))
         (setq pos (1+ pos))
      )
      (command "_.UCS" "p")
      (command "_.UCS" "p")
      (setvar "blipmode" 1)
      (entdel (cdr (car en1)))
   )(princ "Select a text please."))
   (setvar "aunits" 0)
   (princ)
)

;************************复制的均分D距离--增强阵列可以等距---画箭头
(defun c:CJF (/ dis n)
  (initget "Divide Through")
  (setq dis (getdist "\n请输入平行复制的距离(计算均分D/通过点T): "))
  (if (= dis "Divide")
    (progn
      (setq dis        (getdist "\n总距离: ")
            n        (getint "\n复制数量: ")
            dis        (/ dis n)
      )
    )
  )
  (command "offset" dis)
  (princ)
)

(defun c:arzq (/ dis kw ls nc nr disc disr ss fnc fnr)
  (setvar "cmdecho" 0)
  (princ "\n增强阵列.")
  (if (setq ss (ssget))
    (progn
      (initget "R P")
      (if (setq ls (getkword "\n 输入阵列类型 [矩形(R)/环形(P)] : "))
        (setq kw ls)
        (setq kw "R")
      )
      (cond
        ((= kw "R")
         (if (setq ls (getint "\n行数(---)<1>: "))
           (setq nr  (abs ls)
                 fnr (/ ls nr)
           )
           (setq nr 1
                 fnr 1
           )
         )
         (if (setq ls (getint "\n列数(|||)<1>: "))
           (setq nc  (abs ls)
                 fnc (/ ls nc)
           )
           (setq nc 1
                 fnc 1
           )
         )

         (initget "Divide")
         (if (/= 1 nr)
           (progn
             (setq disr (getreal "\n行间距(---/计算均分D): "))
             (if (= disr "Divide")
               (setq dis  (getdist "\n总的距离: ")
                     disr (/ dis (1- nr) fnr)
               )
               (setq disr (* fnr disr))
             )                                ;if
           )
         )                                ;if

         (initget "Divide")
         (if (/= 1 nc)
           (progn
             (setq disc (getreal "\n列间距(|||/计算均分D): "))
             (if (= disc "Divide")
               (setq dis  (getdist "\n总的距离: ")
                     disc (/ dis (1- nc) fnc)
               )
               (setq disc (* fnc disc))
             )                                ;if
           )
         )                                ;if

         (if (and (= 1 nc) (= 1 nr))
           (princ "\n单元素阵列，没有可执行的操作. ")
           (progn
             (command "array" ss "" "r" nr nc)
             (if disr
               (command disr)
             )
             (if disc
               (command disc)
             )
           )                                ;progn
         )                                ;if
        )                                ;
        ((= kw "P")
         (princ "\n弧形阵列请使用cad命令.")
        )                                ;
        (T)
      )                                        ;cond
    )
  )                                        ;if
  (princ)
)


(defun c:hjt (/ pt1 pt2 pt3 len oplw)
  (setq oplw (getvar "plinewid"))
  (and
    (setq pt1 (getpoint "尖点: "))
    (setq pt2 (getpoint pt1 "脖点: "))
    (progn
      (setq len (distance pt1 pt2))
      (command "pline" pt1 "w" 0 (* 1.8 len) pt2)
      (command "w" (* 0.4 len) (* 1.3 len) "a")
      (princ "\n结束点: ")
      (command pause "")
    )
  )
  (setvar "plinewid" oplw)
)
;****************************************************画双跑楼梯剖面
;=======本程序可任意拷贝使用,但必须保留以下说明,并不得修改说明和程序.=======

;本程序用来画双跑楼梯剖面,装载后键入stpo即可.
;创建于1999.6.26

;1999.6.28  增加功能：1.在输入参数时,可修改踏步数和踏步高.
;                      2.若是奇数级踏步,会提问第一跑是几步.
;1999.7.2  有较大改动:1.征求了方小军意见后,修改原程序的楼梯梁位置的不正确.
;                      2.使剖到梯段,看到梯段,扶手分别画在wall,win,line图层上.
;2000.6.6  增加:1.一层楼的出错提示.
;           修改:1.原来顶层楼板的错误长度。
(setvar "cmdecho" 0)
(gc)
(defun c:stpo(/ p1 elev elevn k x stn stn1 stn2 stw sth pd1 os i
                d0 d1 d2 d3 d4 d5 d6 d7 d8 p2 p3 pd2 fd1 fd2 fd3 fd4
                a1 a2 a3 a4 a5 a6 a7 )
(prompt "---双跑楼梯剖面---by Lu Yongle")
        (setq elev (getdist "\n楼层高<2800>:"))
        (if (null elev) (setq elev 2800.0))
       
        (setq elevn (getint "\n楼层数<6>:"))
        (if (= elevn 1) (progn
                                (alert "一层楼也用楼梯吗?傻瓜!必需二层以上:)")
                                (setq elevn (getint "\n楼层数<6>:"))
                        )
        )
        (if (null elevn) (setq elevn 6))
       
        (setq k nil)
   (while (null k)
        (setq stn (getint "\n每层踏步数<18>:"))
        (if (null stn) (setq stn 18))
        (setq stw (getdist "\n踏步宽<280>:"))
        (if (null stw)(setq stw 280))
        (setq sth (/ elev stn))
        (prompt "踏步尺寸为:") (prin1 stw) (prompt "宽 x ")(prin1 sth)(prompt "高,")
        (initget 1 "Yes No")
        (setq x (getkword "可以吗?(Yes or No)"))
        (if (/= x "Yes")
            (progn (setq k nill ) (setq stn nill)(setq stw nill))
            (setq k 1)
        )
  );end while k
       
        (if (= (rem stn 2) 1)
            (progn (setq stn1 (getint "\n第一跑数:"))
                   (setq stn2 (- stn stn1))
            )
            (progn (setq stn1 (/ stn 2))
                 (setq stn2 (/ stn 2))
            )
        )

(graphscr)
(setq p1 (getpoint "\n起始点:"))
(setq d0 p1)
(setq pd1 (polar p1 (* pi 1.5) 100))

;设置绘图环境
(setq os (getvar "osmode"))
(setvar "osmode" 0)
(command "layer" "m" "line" "C" 2 "line" "")
(command "layer" "m" "win" "C" 4 "win" "")
(command "layer" "m" "wall" "C" 7 "wall" "")

(repeat (- elevn 1);楼层数

;-----下面为画楼板准备点
(setq d1 (polar p1 pi 1320))
(setq d2 (polar d1 (* pi 1.5 ) 350 ))
(setq d3 (polar d2 0 240))
(setq d4 (polar d3 (/ pi 2) 250))
(setq d5 (polar d4 0 840))
(setq d6 (polar d5 (* pi 1.5) 250))
(setq d7 (polar d6 0 240))
(setq d8 (polar d0 (* pi 1.5) 100))

(setq i 1)
(repeat stn1
        ;(/ stn 2);开始画第一跑踏步
        (setq p2 (polar p1 (/ pi 2) sth))
        (setq p3 (polar  p2 0 stw))
        (entmake (list  (cons 0 "line")(cons 8 "wall")(cons 10 p1)(cons 11 p2)))
        (if (< i stn1)
            (entmake (list  (cons 0 "line")(cons 8 "wall")(cons 10 p2)(cons 11 p3)))
        )
        (setq i (+ i 1))
        (setq pd2 (polar p1 (* pi 1.5) 100))
        (setq p1 p3)
);end repeat stn

;下面画扶手
(setq fd1 (polar d0 pi (/ stw 2)))
(setq fd2 (polar fd1 (/ pi 2) 900))
(setq fd3 (polar p2 0 (/ stw 2)))
(setq fd4 (polar fd3 (/ pi 2) 900))
(entmake (list (cons 0 "line") (cons 8 "win")(cons 10 fd1)(cons 11 fd2)))
(entmake (list (cons 0 "line") (cons 8 "win")(cons 10 fd2)(cons 11 fd4)))
(entmake (list (cons 0 "line") (cons 8 "win")(cons 10 fd4)(cons 11 fd3)))

;-----下面为画平台板准备点
(setq a7 (polar pd2 (* pi 1.5 )(- 350 sth 100)))
(setq a6 (polar a7 0 240))        ;梁宽240
(setq a5 (polar a6 (/ pi 2) 250))
(setq a4 (polar a5 0 1080))
(setq a3 (polar a4 (* pi 1.5) 250));楼板为350-250=100厚
(setq a2 (polar a3 0 240))
(setq a1 (polar a2 (/ pi 2) 350)) ;梁高350

(command "layer" "s" "wall" "")
(command "pline" d0 "w" 0 "" d1 d2 d3 d4 d5 d6 d7 d8 pd2  a7 a6 a5 a4 a3 a2 a1 p2 "")

(setq pd1 (polar p2 (* pi 1.5) 100))
(setq p1 p2)

(repeat stn2
        ;(/ stn 2);开始画第二跑踏步
        (setq p2 (polar p1 (/ pi 2) sth))
        (setq p3 (polar  p2 pi stw))
        (if (< i stn)
                (progn
                    (entmake (list (cons 0 "line")(cons 8 "line")(cons 10 p1)(cons 11 p2)))
                    (entmake (list (cons 0 "line")(cons 8 "line")(cons 10 p2)(cons 11 p3)))
                )
        )
        (setq i (+ i 1))
        (setq pd2 p1)
        (setq p1 p3)
        (setq d0 p2)
       
);end repeat stn

(setq pd2 (polar pd2 (* pi 1.5) 100))
(entmake (list (cons 0 "line")(cons 8 "line") (cons 10 pd1) (cons 11 pd2)));踏板底线

(setq fd2 fd4)
(setq fd3 (polar p2 pi (/ stw 2)))
(setq fd4 (polar fd3 (/ pi 2) 900))
(entmake (list (cons 0 "line")(cons 8 "win")(cons 10 fd2)(cons 11 fd4)));第二跑扶手

(setq pd1 (polar p1 (* pi 1.5) 100))
(setq p1 p2)

);end repeat elevn

(entmake (list (cons 0 "line")(cons 8 "win")(cons 10 fd3)(cons 11 fd4)));顶层扶手

;----下面画顶层楼板
(setq d1 (polar p2 pi 1320 ))
(setq d2 (polar d1 (* pi 1.5) 350))
(setq d3 (polar d2 0 240))
(setq d4 (polar d3 (/ pi 2) 250))
(setq d5 (polar d4 0 840))
(setq d6 (polar d5 (* pi 1.5) 250))
(setq d7 (polar d6 0 240))
(command "pline" p2 "w" 0 "" d1 d2 d3 d4 d5 d6 d7 "c")

(setvar "osmode" os)
(princ)
);end defun

;****************************************************连接断线程序
(defun c:lj (/ ent ent1 pt1 pt2 pt3 pt4 ptlst ptls kj fltrad memb sel sel1 x y)
  (setq fltrad (getvar "filletrad"))(setvar "filletrad" 0)
(setq sel (entsel"\n拾取第一条线<LINE,PLINE,ARC>:") ent (car sel)
      sel1 (entsel"\n拾取另一条线<LINE,PLINE,ARC>:")ent1 (car sel1))
(setq pt1(vlax-curve-getStartPoint ent)
      pt3(vlax-curve-getStartPoint ent1)
      pt2(vlax-curve-getEndPoint ent)
      pt4(vlax-curve-getEndPoint ent1))
    (if(and(and(=(cdr(assoc 0(entget ent)))"LINE")
           (=(cdr(assoc 0(entget ent1)))"LINE"))
      (and(null(inters pt1 pt2 pt3 pt4 nil))
            (equal(angle pt1 pt3)(angle pt1 pt4)0.0000001))
           )     
      (progn
  (setq ptlst (list (list pt1 pt3)
                    (list pt1 pt4)
                    (list pt2 pt3)
                    (list pt2 pt4)
                    )
        )
(mapcar '(lambda (x)
           (setq kj (cons(apply 'distance x)kj))
           )
        ptlst
        )
(mapcar '(lambda (y)
  (if (=(apply 'distance y)(apply 'max kj))
    (setq ptls y)
    )
           )ptlst
        )
  (cond((/=(setq memb (member(car ptls)(list pt1 pt2)))nil)               
        (if(=(cadr ptls)pt3)
(vla-put-endpoint (vlax-ename->vla-object ent1)
                  (vlax-3d-point(car ptls)))
(vla-put-startpoint (vlax-ename->vla-object ent1)
                    (vlax-3d-point(car ptls)))          
          )(vl-cmdf ".erase" ent "")
        )
       (t(if(=(car ptls)pt1)
(vla-put-endpoint (vlax-ename->vla-object ent)
                  (vlax-3d-point(cadr ptls)))
(vla-put-startpoint (vlax-ename->vla-object ent)
                    (vlax-3d-point(cadr ptls)))
          )(vl-cmdf ".erase" ent1 ""))))
    (vl-cmdf ".fillet" sel sel1)  
    )(setvar "filletrad" fltrad)(princ)
  )

;****************************************************数字递增复制
(defun c:TC (/ E ENEW NV P S)
  (princ "\n 数字递增复制")
  (if (and (setq e (car (entsel "\nSelect Text: ")))
           (setq e (vlax-ename->vla-object e))
           (or (= "AcDbText" (vla-get-ObjectName e))
               (= "AcDbMText" (vla-get-ObjectName e))
           )
      )
    (progn
      (setq s (vla-get-TextString e))
      (if (null (setq nv (getreal (strcat "\nNew value:" "<40>"))))
        (setq nv 40)
      )
      (princ "\nCopy to: ")
      (while (setq p (getpoint))
        (setq enew (vla-copy e))
        (vla-put-textstring enew (setq s (rtos (+ (atof s) nv) 2)))
        (vla-put-InsertionPoint enew (vlax-3d-point p))
      )
    )
    (princ "\n选中的不是文本或没有选择到实体.")
  )
  (princ)
)
;****************************************************插入日期及时间
(defun c:IT ( / da lst)
  (princ "\n 插入日期及时间")  
  (setq da (rtos(getvar "cdate")2 8)
        lst(mapcar '(lambda(x)(substr da (car x) (cadr x))) '((1 4) (5 2) (7 2) (10 2)(12 2)(14 2)(16 2))))
  (COMMAND "style" "宋体" "宋体" "300" "1" "0" "" "")
  (setq pt1 (getpoint "\n\t放置点 : "))
  (vl-cmdf ".text" "j" "mc" pt1 "0"
  (apply 'strcat (mapcar '(lambda(x y)(strcat x y)) lst '("年" "月" "日" "时" "分"  )))
)
    (princ)
)
;****************************************************复制到当前层
(defun C:cpc ()
(princ "\n 复制到当前层（copy_to_layer）")
    (setvar "cmdecho" 0)
    (setq c_layer (getvar "clayer")
          sset (ssget)
          pt1 (getpoint "\n基点： ")
          count 0)
   (prompt "\n位移的第二点： ")
      (setq  len (sslength sset))
      (while (< count len)
       (setq name (ssname sset count)
             ptlst (entget name)
             b (assoc 8 ptlst)
             b1 (cdr (assoc 8 ptlst))
             c (cons 8 c_layer)
             d (subst c b ptlst)
             count (1+ count))
            (entmod d)
     )
    (command "_copy" sset "" pt1 pause)
    (setq count 0)
    (while (< count len)
    (setq name (ssname sset count)
             ptlst (entget name)
             b (assoc 8 ptlst)
             c (cons 8 b1)
             d (subst c b ptlst)
             count (1+ count))
            (entmod d)
     )
     (princ)
   )

;****************************************************创建DIM图层
(defun C:DIML()
      (princ "\n 创建“DIM”图层")      
      ; if Layer "DIM" doesn't exist create it
      (if (= (tblsearch "Layer" "DIM") nil)
         (command "Layer" "new" "DIM" "color" "7" "DIM" "")
      )
      (setvar "CLAYER" "DIM")
)
;****************************************************测量长度之和
(defun c:cd()
(setq os (getvar "osmode"))
(setvar "osmode" 0)
(setq sum 0 i 0)
(setq ss (ssget))
(repeat (sslength ss)
(setq en (ssname ss i))
(command "lengthen" en "")
(setq l (getvar "perimeter"))
(setq sum (+ sum l)
i (+ i 1))
)
(setvar "osmode" os)
  sum
)
;****************************************************面积求和
(defun c:areah (/ olderr oldcmdecho errexit undox restore ss1 nr en tot_area)
(defun errexit (s)
(restore)
)

(defun undox ()
(command "._undo" "_E")
(setvar "cmdecho" oldcmdecho)
(setq *error* olderr)
(princ)
)

(setq olderr *error*
restore undox
*error* errexit
)
(setq oldcmdecho (getvar "cmdecho"))
(setvar "cmdecho" 0)
(command "._UNDO" "_BE")
(if (setq ss1 (ssget '((-4 . "<OR")
(0 . "POLYLINE")
(0 . "LWPOLYLINE")
(0 . "CIRCLE")
(0 . "ELLIPSE")
(0 . "SPLINE")
(0 . "REGION")
(-4 . "OR>")
)
)
)
(progn
(setq nr 0)
(setq tot_area 0.0)
(setq en (ssname ss1 nr))
(while en
(command "._area" "_O" en)
(setq tot_area (+ tot_area (getvar "area")))
(setq nr (1+ nr))
(setq en (ssname ss1 nr))
)
(princ "\n面积之和 = ")
(princ tot_area)
)
)
(restore)
)
;****************************************************打断插文字
(defun c:ddt ()
(setq th (getdist "\请输入文字高度:"))
(setq r(* th 1.25))
(setq t (getstring "请输入要插入的文字:"))
(setq h1 (entsel))
(setq h2 (getpoint"\n选择插入点:"))
(while h2
(command "circle" h2 r)
(setq na (entlast))
(command "trim" na "" h1"")
(command "text""J""M" h2 th""t)
(command "erase" na"")
(setq h1 (entsel))
(setq h2 (getpoint"\n选择插入点:"))
  )
)
;****************************************************多重复制
(defun C:CV (/ ss FL)
(princ "\nSelect objects: ")
(setq ss (ssget))
(setq n (sslength ss))
(command "COPY" ss "" "m" "") (repeat n (command "" copy "" ""))
)
;****************************************************圆变多边形
(defun c:cp (/ en n)
  (setvar "cmdecho" 0)
  (setq en (entsel "请选择一个圆"))
  (setq en_data (entget (car en)))
  (setq cen (cdr (assoc 10 en_data)))
  (setq r (cdr (assoc 40 en_data)))
  (setq n (getint "\n请输入正多边形的边数:"))
  (initget "I C")
  (setq        a (getkword "\n输入选项 [内接于圆(I)/外切于圆(C)] <C>:"))
  (if (= a "I")
    (progn
      (command "polygon" n cen "i" r)
    )
    (progn
      (command "polygon" n cen "c" r)
    )
  )
  (command "ERASE" en "")
  (princ)
)
;****************************************************cr改多圆半径
(defun c:cr()
    (setq cm0(getvar "cmdecho"))
    (setvar "cmdecho" 0)
    (princ "\n \n \n")
        (setq r(getdist "请输入半径或<直接回车单个修改>:"))
    (if r (progn
    (setq ss(ssget))
    (while ss
    (setq ll(sslength ss))
    (setq ll0 -1)
    (repeat ll
        (setq ll0(+ ll0 1))
        (setq si(ssname ss ll0))
        (setq cc( entget si))
        (setq ty(cdr (assoc 0 cc)))
        (if (or (= ty "CIRCLE") (= ty "ARC"))
        (progn
        (setq r0(cdr (assoc 40 cc)))
        (setq cc(subst (cons 40 r)(assoc 40 cc)cc))
        (entmod cc)(entupd si)
        ))
     )
     (setq ss(ssget))
     ))
     (progn
    (setq si(entsel "\n选择圆或弧："))
    (while si
        (setq cc(entget (car si)))
        (setq ty(cdr (assoc 0 cc)))
        (if (or (= ty "CIRCLE") (= ty "ARC"))
        (progn
            (setq nm(cdr (assoc -1 cc)))
            (setq r0(cdr (assoc 40 cc)))
            (princ r0)(setq r(getdist "->"))
            (if r (progn
            (setq cc(subst (cons 40 r)(assoc 40 cc)cc))
            (entmod cc)(entupd nm)))
        ))
        (setq si(entsel "\n选择圆或弧："))
    )
     ))
     (setvar "cmdecho" cm0)
)
;****************************************************沿某方向多重复制
(defun C:CM ()
(setq A nil)
(setq OM (getvar "OSMODE"))
(setvar "OSMODE" 33)
(setq PNT1 (getpoint "\n方向起点： "))
(setq PNT2 (getpoint "\n方向终点： " PNT1))(terpri)
(initget 1 "M E N")
(prompt "\n选择复制方式： ")
(setq CTYPE
(getkword "[最大间距(M)/精确间距(E)/数量(N)]： "))
(if (= CTYPE "M")
(setq SP (getdist "\n最大对象间距： ")))
(if (= CTYPE "E")
(setq SP (getdist "\n精确对象间距： ")))
(if (= CTYPE "N")
(setq SP (getreal "\n对象数量： ")))
(setq DIST (distance PNT1 PNT2))
(setq ANG (angle PNT1 PNT2))
(setq TEMP1 (/ DIST SP))
(setq TEMP2 (fix (/ DIST SP)))
(setq INC1 SP)
(setq INC2 (/ DIST (+ 1 (fix (/ DIST SP)))))
(setq INC3 (/ DIST (- SP 1)))
(if (= TEMP1 TEMP2) (setq INC INC1) (setq INC INC2))
(if (= CTYPE "E") (setq INC INC1) (setq INC INC))
(if (= CTYPE "N") (setq INC INC3) (setq INC INC))
(setq TMS (FIX (+ 0.00001 (/ DIST INC))))
(setvar "OSMODE" 0)
(setq A (ssget))
(setq INCR 0)
(repeat TMS
(setq INCR (+ INCR INC))
(setq NEWPT (polar PNT1 ANG INCR))
(command "copy" A "" PNT1 NEWPT)
)
(setvar "OSMODE" OM)
(setq A nil)
)
;****************************************************按层改线弧圆宽度
(defun c:lpn(/ s1 s2 wl n s3 s4 stt)
(setvar "cmdecho" 0)
(setq wl (getreal "\n输入线宽："))
(setq stt (getstring "\n输入需改线宽的层名:"))
(setq s1 (ssget "X" (list (cons 8 stt))))
  (if s1
  (progn
    (setq n 0)
    (repeat (sslength s1)
      (setq s2 (ssname s1 n))
      (if (= wl 0)      
      (if (or (= "POLYLINE" (cdr (assoc 0 (entget s2))))
               (= "LWPOLYLINE" (cdr (assoc 0 (entget s2))))  )
         (command ^"explode" s2))
      (progn
       (if (= "LINE" (cdr (assoc 0 (entget s2))))
         (command ^"pedit" s2 "y" "w" wl ""))
       (if (= "ARC" (cdr (assoc 0 (entget s2))))
         (command ^"pedit" s2 "y" "w" wl ""))
       (if (or (= "POLYLINE" (cdr (assoc 0 (entget s2))))
               (= "LWPOLYLINE" (cdr (assoc 0 (entget s2))))  )
         (command ^"pedit" s2 "w" wl ""))
      )
      );endif
      (setq n (1+ n))
    )
   )
)
(setvar "cmdecho" 1)
)
;****************************************************改线弧圆宽度
(defun C:pn (/ p l n e q w a m b layer0 color0 linetype0 layer1 color1 linetype1 rad-out rad-in)
  (setq oldblp (getvar "blipmode")
        oldech (getvar "cmdecho")
        olderr *error*
        linetype1 (getvar "celtype")
        layer1 (getvar "clayer")
        color1 (getvar "cecolor")
  )
  (setvar "blipmode" 0)
  (setvar "cmdecho" 0)
  (defun *error* (msg)
    (princ "\n")
    (princ msg)
    (setvar "blipmode" oldblp)
    (setvar "cmdecho" oldech)
    (setq *error* olderr)
    (princ)
  )  
  (prompt "\n请选择要改变宽度的线,弧,圆及多义线.")
  (setq p (ssget))
  (setq w (getreal "\n请输入宽度<50>:"))
  (if (not w) (setq w 50))
  (setq l 0 m 0 n (sslength p))
  (while (< l n)
    (setq q (ssname p l))
    (setq ent (entget q))
    (setq b (cdr (assoc 0 ent)))
    (if (member b '("LINE" "ARC"))
      (progn
        (command "PEDIT" q "y" "w" w "x")
        (setq m (+ 1 m))
      )
    )
    (if (= "LWPOLYLINE" b)
      (progn
        (command "PEDIT" q "w" w "x")
        (setq m (+ 1 m))
      )
    )
    (if (= "CIRCLE" b)
      (progn
        (if (assoc 6 ent) (setq linetype0 (cdr (assoc 6 ent))) (setq linetype0 "bylayer"))
        (setq layer0 (cdr (assoc 8 ent)))
        (if (assoc 62 ent) (setq color0 (cdr (assoc 62 ent))) (setq color0 "bylayer"))
        (setq center0 (cdr (assoc 10 ent)))
        (setq radius0 (cdr (assoc 40 ent)))
        (setq diameter0 (* 2 radius0))
        (entdel q)
        (command "color" color0)
        (command "layer" "s" layer0 "")
        (command "linetype" "s" linetype0 "")
        (if (> w diameter0)
          (progn
            (princ "\n\t 因线宽大于圆的直径，故将该圆填充")
            (princ)
            (setq rad-out (* 2 radius0)
                  rad-in 0
            )
          )
        )
        (if (<= w diameter0)
          (progn
            (setq rad-out (+ (* 2 radius0) w)
                  rad-in (- (* 2 radius0) w)
            )
          )
        )
        (command "donut" rad-in rad-out center0 "")
        (setq m (+ 1 m))
      )
    )
    (setq l (+ 1 l))
  )
  (if (= 0 m)
    (progn
     (princ "\n\t  没有任何线,弧,圆及多义线被选中")
      (princ)
    )
  )
  (setvar "blipmode" oldblp)
  (setvar "cmdecho" oldech)
  (setq *error* olderr)
  (command "color" color1)
  (command "layer" "s" layer1 "")
  (command "linetype" "s" linetype1 "")
  (princ)
)
(princ)
;****************************************************改颜色
(DEFUN C:C1 ()
        (SETVAR "CMDECHO" 0)
        (PRINC "SELECT Obj. Color be 1#: ")
        (SETQ SS(SSGET))
        (COMMAND "CHANGE" SS "" "PROPERTIES" "C" "1" "") (SETVAR "CMDECHO" 1) (PRINC))
(DEFUN C:C2 ()
        (SETVAR "CMDECHO" 0)
        (PRINC "SELECT Obj. Color be 2#: ")
        (SETQ SS (SSGET))
        (COMMAND "CHPROP" SS "" "C" "2" "") (SETVAR "CMDECHO" 1) (PRINC))
(DEFUN C:C3 ()
        (SETVAR "CMDECHO" 0)
        (PRINC "SELECT Obj. Color be 3#: ")
        (SETQ SS (SSGET))
        (COMMAND "CHPROP" SS "" "C" "3" "") (SETVAR "CMDECHO" 1) (PRINC))
(DEFUN C:C4 ()
        (SETVAR "CMDECHO" 0)
        (PRINC "SELECT Obj. Color be 4#: ")
        (SETQ SS (SSGET))
        (COMMAND "CHPROP" SS "" "C" "4" "") (SETVAR "CMDECHO" 1) (PRINC))
(DEFUN C:C5 ()
        (SETVAR "CMDECHO" 0)
        (PRINC "SELECT Obj. Color be 5#: ")
        (SETQ SS (SSGET))
        (COMMAND "CHPROP" SS "" "C" "5" "") (SETVAR "CMDECHO" 1) (PRINC))
(DEFUN C:C6 ()
        (SETVAR "CMDECHO" 0)
        (PRINC "SELECT Obj. Color be 6#: ")
        (SETQ SS (SSGET))
        (COMMAND "CHPROP" SS "" "C" "6" "") (SETVAR "CMDECHO" 1) (PRINC))
(DEFUN C:C7 ()
        (SETVAR "CMDECHO" 0)
        (PRINC "SELECT Obj. Color be 7#: ")
        (SETQ SS (SSGET))
        (COMMAND "CHPROP" SS "" "C" "7" "") (SETVAR "CMDECHO" 1) (PRINC))
(DEFUN C:C8 ()
        (SETVAR "CMDECHO" 0)
        (PRINC "SELECT Obj. Color be 8#: ")
        (SETQ SS (SSGET))
        (COMMAND "CHPROP" SS "" "C" "8" "") (SETVAR "CMDECHO" 1) (PRINC))
(DEFUN C:C9 ()
        (SETVAR "CMDECHO" 0)
        (PRINC "SELECT Obj. Color be 9#: ")
        (SETQ SS (SSGET))
        (COMMAND "CHPROP" SS "" "C" "9" "") (SETVAR "CMDECHO" 1) (PRINC))
(DEFUN C:CB ()
        (SETVAR "CMDECHO" 0)
        (PRINC "SELECT Obj. Color Bylayer: ")
        (SETQ SS (SSGET))
        (COMMAND "CHPROP" SS "" "C" "BYLAYER" "") (SETVAR "CMDECHO" 1) (PRINC))
;****************************************************旋转绘图角度
(defun c:an()  (command "snapang"))
(defun c:0()   (command "snapang" "0"))
(defun c:15()  (command "snapang" "15"))
(defun c:30()  (command "snapang" "30"))
(defun c:45()  (command "snapang" "45"))
(defun c:60()  (command "snapang" "60"))
;****************************************************Z轴归零
(defun c:zz()
   (setvar "cmdecho" 0)
   (setvar "blipmode" 0)
   (graphscr)
   (prompt "Z向归零:") (terpri)

   (princ "请选择要归零的实体")
   (setq s (ssget))
   (setq len (sslength s))
   (setq index 0)

   (repeat len
      (setq a (entget (ssname s index)))

      (setq b10 (assoc 10 a))
      (setq b11 (assoc 11 a))

      (setq x10 (cadr b10))
      (setq y10 (caddr b10))

      (setq x11 (cadr b11))
      (setq y11 (caddr b11))

      (setq b101 (cons 10 (list x10 y10 0)))
      (setq b111 (cons 11 (list x11 y11 0)))

      (setq a (subst b101 b10 a))
      (entmod a)
      (setq a (subst b111 b11 a))
      (entmod a)

      (setq index (+ index 1))
   )
   (princ "成功")
   (princ)
)
;****************************************************加密
(defun lockerror (msg)
  (if (/= msg "Function cancelled")
    (princ
      (strcat "\nError: " msg " [" (itoa (getvar "ERRNO")) "]")
    )
    (princ)
  )
  (command "UNDO" "End")
  (Abort "\n加密操作被放弃！")
  (setq *error* olderr)
  (princ)
)

(defun Abort (msg)
  (setvar "filedia" fdia)
  (setvar "cmddia" cdia)
  (setvar "cmdecho" cmd)
  (alert msg)
)
;;Exit

(defun getlayers ()
  (setq lyr (tblnext "layer" t))
  (setq laylist "")
  (while lyr
    (if        (or (and (= (cdr (assoc 62 lyr)) 8)
                 (not (wcmatch (cdr (assoc 2 lyr)) "*|*"))
            )
            (and (= (cdr (assoc 62 lyr)) 9)
                 (not (wcmatch (cdr (assoc 2 lyr)) "*|*"))
            )
            (and (= (cdr (assoc 62 lyr)) 251)
                 (not (wcmatch (cdr (assoc 2 lyr)) "*|*"))
            )
            (and (= (cdr (assoc 62 lyr)) 252)
                 (not (wcmatch (cdr (assoc 2 lyr)) "*|*"))
            )
            (and (= (cdr (assoc 62 lyr)) 253)
                 (not (wcmatch (cdr (assoc 2 lyr)) "*|*"))
            )
            (and (= (cdr (assoc 62 lyr)) 254)
                 (not (wcmatch (cdr (assoc 2 lyr)) "*|*"))
            )
            (and (= (cdr (assoc 62 lyr)) 255)
                 (not (wcmatch (cdr (assoc 2 lyr)) "*|*"))
            )
        )
      (if (equal laylist "")
        (setq laylist (strcat laylist (cdr (assoc 2 lyr))))
        (setq laylist (strcat laylist "," (cdr (assoc 2 lyr))))
      )
    )
    (setq lyr (tblnext "layer"))
  )
  laylist
)

(defun backblk (layoutName Mins)
  (if layoutName
    (cond
      ((= layoutName "14MS")
       (setq blist (list '(-4 . "<NOT")
                         '(-4 . "<OR")
                         '(67 . 1)
                         '(0 . "SOLID")
                         '(2 . "SOLID")
                         '(-4 . "OR>")
                         '(-4 . "NOT>")
                         '(-4 . "<OR")
                         (cons 8 (getlayers))
                         '(62 . 8)
                         '(62 . 9)
                         '(62 . 251)
                         '(62 . 252)
                         '(62 . 253)
                         '(62 . 254)
                         '(62 . 255)
                         '(-4 . "OR>")
                   )
       )
      )
      ((= layoutName "14PS")
       (setq blist (list '(67 . 1)
                         '(-4 . "<NOT")
                         '(-4 . "<OR")
                         '(0 . "SOLID")
                         '(2 . "SOLID")
                         '(0 . "VIEWPORT")
                         '(-4 . "OR>")
                         '(-4 . "NOT>")
                         '(-4 . "<OR")
                         (cons 8 (getlayers))
                         '(62 . 8)
                         '(62 . 9)
                         '(62 . 251)
                         '(62 . 252)
                         '(62 . 253)
                         '(62 . 254)
                         '(62 . 255)
                         '(-4 . "OR>")
                   )
       )
      )
      (T
       (setq blist (list (cons 410 layoutName)
                         '(-4 . "<NOT")
                         '(-4 . "<OR")
                         '(0 . "SOLID")
                         '(2 . "SOLID")
                         '(0 . "VIEWPORT")
                         '(-4 . "OR>")
                         '(-4 . "NOT>")
                         '(-4 . "<OR")
                         (cons 8 (getlayers))
                         '(62 . 8)
                         '(62 . 9)
                         '(62 . 251)
                         '(62 . 252)
                         '(62 . 253)
                         '(62 . 254)
                         '(62 . 255)
                         '(-4 . "OR>")
                   )
       )
      )
    )
    (setq blist        (list '(-4 . "<NOT")
                      '(-4 . "<OR")
                      '(0 . "SOLID")
                      '(2 . "SOLID")
                      '(0 . "VIEWPORT")
                      '(-4 . "OR>")
                      '(-4 . "NOT>")
                      '(-4 . "<OR")
                      (cons 8 (getlayers))
                      '(62 . 8)
                      '(62 . 9)
                      '(62 . 251)
                      '(62 . 252)
                      '(62 . 253)
                      '(62 . 254)
                      '(62 . 255)
                      '(-4 . "OR>")
                )
    )
  )
  (setq ssetb (ssget "X" blist))
  (setq viewsset (ssget "X" '((0 . "VIEWPORT"))))
  (if viewsset
    (progn
      (setq n 0)
      (repeat (sslength viewsset)
        (if (setq clipent (assoc 340 (entget (ssname viewsset n))))
          (ssdel (cdr clipent) ssetb)
        )
        (setq n (1+ n))
      )
    )
  )
  (if ssetb
    (progn
      (setq pt (list 0.0 0.0))
      (entmake ;;write block header
               (list '(0 . "BLOCK")
                     '(2 . "*anon")
                     '(70 . 1)
                     (cons '10 pt)
               )
      )
      (setq a 0)
      (repeat (sslength ssetb)
        (setq ent2 (entmake (entget (setq ent (ssname ssetb a)))))
        (if (null ent2)
          (princ (entget (setq ent (ssname ssetb a))))
        )
        (if (assoc 66 (entget ent))
          (progn
            (setq subent (entnext ent))
            (while (/= (cdr (assoc 0 (entget subent))) "SEQEND")
              (entmake (entget subent))
              (setq subent (entnext subent))
            )
            (setq ent3 (entmake (entget subent)))
            (if        (null ent3)
              (princ (entget subent))
            )
          )
        )
        (entdel ent)
        (setq a (1+ a))
        (c:spin "Making Block of background colours..")
      )
      (setq nameb (entmake '((0 . "endblk"))))
      (princ "\n  Inserting...\n")
      (if Mins
        (entmake
          (list        '(0 . "INSERT")
                (CONS '100 "AcDbMInsertBlock")
                (CONS '70 2)
                (CONS '71 2)
                (cons '2 nameb)
                (cons '10 pt)
          )
        )
        (entmake
          (list        '(0 . "INSERT")
                (cons '2 nameb)
                (cons '10 pt)
          )
        )
      )
      (setq bc (entlast))
      (setq bac "back")
      (command "_.draworder" bc "" (strcat "_" bac))
      (setq ssetb nil)
      (setq viewsset nil)
    )
  )
  (princ)
)

(defun solidblk        (layoutName Mins)
  (if layoutName
    (cond
      ((= layoutName "14MS")
       (setq slist (list '(-4 . "<NOT")                     '(67 . 1)
                         '(-4 . "NOT>")                     '(-4 . "<OR")
                         '(0 . "SOLID")                     '(2 . "SOLID")
                         '(-4 . "OR>")
                        )
       )
      )
      ((= layoutName "14PS")
       (setq slist (list '(67 . 1)
                         '(-4 . "<OR")
                         '(0 . "SOLID")
                         '(2 . "SOLID")
                         '(-4 . "OR>")
                   )
       )
      )
      (T
       (setq slist (list (cons 410 layoutName)
                         '(-4 . "<OR")
                         '(0 . "SOLID")
                         '(2 . "SOLID")
                         '(-4 . "OR>")
                   )
       )
      )
    )
    (setq slist        (list '(-4 . "<OR")
                      '(0 . "SOLID")
                      '(2 . "SOLID")
                      '(-4 . "OR>")
                )
    )
  )
  (setq ssets (ssget "X" slist))
  (if ssets
    (progn
      (setq pt (list 0.0 0.0))
      (entmake ;;write block header
               (list '(0 . "BLOCK")
                     '(2 . "*anon")
                     '(70 . 1)
                     (cons '10 pt)
               )
      )
      (setq a 0)
      (repeat (sslength ssets)
        (setq ent2 (entmake (entget (setq ent (ssname ssets a)))))
        (if (null ent2)
          (princ (entget (setq ent (ssname ssets a))))
        )
        (if (assoc 66 (entget ent))
          (progn
            ;;add sub-entities until seqend is found
            (setq subent (entnext ent))
            (while (/= (cdr (assoc 0 (entget subent))) "SEQEND")
              (entmake (entget subent))
              (setq subent (entnext subent))
            )
            (setq ent3 (entmake (entget subent)))
            (if        (null ent3)
              (princ (entget subent))
            )
          )
        )
        (entdel ent)
        (setq a (1+ a))
        (c:spin "Making Block of solids..")
      )
      (setq names (entmake '((0 . "endblk"))))
      (princ "\n  Inserting...\n")
      (if Mins
        (entmake
          (list        '(0 . "INSERT")
                (CONS '100 "AcDbMInsertBlock")
                (CONS '70 2)
                (CONS '71 2)
                (cons '2 names)
                (cons '10 pt)
          )
        )
        (entmake
          (list        '(0 . "INSERT")
                (cons '2 names)
                (cons '10 pt)
          )
        )
      )
      (setq so (entlast))
      (setq ba "back")
      (command "_.draworder" so "" (strcat "_" ba))
      (setq ssets nil)
    )
  )
  (princ)
)

(defun anonBlock (layoutName Mins)
  (if layoutName
    (cond
      ((= layoutName "14MS")
       (setq alist (list '(-4 . "<NOT")
                         '(-4 . "<OR")
                         '(67 . 1)
                         '(0 . "ACAD_PROXY_ENTITY")
                         '(0 . "AEC_*")
                         '(0 . "AECS_*")
                         '(0 . "RTEXT")
                         '(0 . "WIPEOUT")
                         ;;'(8 . "LAYCFG")
                         '
                          (0 . "SOLID")
                         '(2 . "SOLID")
                         (cons 8 (getlayers))
                         '(62 . 8)
                         '(62 . 9)
                         '(62 . 251)
                         '(62 . 252)
                         '(62 . 253)
                         '(62 . 254)
                         '(62 . 255)
                         '(-4 . "OR>")
                         '(-4 . "NOT>")
                   )
       )
      )
      ((= layoutName "14PS")
       (setq alist (list '(67 . 1)
                         '(-4 . "<NOT")
                         '(-4 . "<OR")
                         '(0 . "VIEWPORT")
                         '(0 . "ACAD_PROXY_ENTITY")
                         '(0 . "AEC_*")
                         '(0 . "AECS_*")
                         '(0 . "RTEXT")
                         '(0 . "WIPEOUT")
                         ;;'(8 . "LAYCFG")
                         '
                          (0 . "SOLID")
                         '(2 . "SOLID")
                         (cons 8 (getlayers))
                         '(62 . 8)
                         '(62 . 9)
                         '(62 . 251)
                         '(62 . 252)
                         '(62 . 253)
                         '(62 . 254)
                         '(62 . 255)
                         '(-4 . "OR>")
                         '(-4 . "NOT>")
                   )
       )
      )
      (T
       (setq alist (list (cons 410 layoutName)
                         '(-4 . "<NOT")
                         '(-4 . "<OR")
                         ;;'(8 . "LAYCFG")
                         '
                          (0 . "VIEWPORT")
                         '(0 . "ACAD_PROXY_ENTITY")
                         '(0 . "AECC_*")
                         '(0 . "AEC_*")
                         '(0 . "AECS_*")
                         '(0 . "RTEXT")
                         '(0 . "WIPEOUT")
                         '(0 . "SOLID")
                         '(2 . "SOLID")
                         (cons 8 (getlayers))
                         '(62 . 8)
                         '(62 . 9)
                         '(62 . 251)
                         '(62 . 252)
                         '(62 . 253)
                         '(62 . 254)
                         '(62 . 255)
                         '(-4 . "OR>")
                         '(-4 . "NOT>")
                   )
       )
      )
    )
    (setq alist        (list '(-4 . "<NOT")
                      '(-4 . "<OR")
                      ;;'(8 . "LAYCFG")
                      '
                       (0 . "VIEWPORT")
                      '(0 . "ACAD_PROXY_ENTITY")
                      '(0 . "AECC_*")
                      '(0 . "AEC_*")
                      '(0 . "AECS_*")
                      '(0 . "RTEXT")
                      '(0 . "WIPEOUT")
                      '(0 . "SOLID")
                      '(2 . "SOLID")
                      (cons 8 (getlayers))
                      '(62 . 8)
                      '(62 . 9)
                      '(62 . 251)
                      '(62 . 252)
                      '(62 . 253)
                      '(62 . 254)
                      '(62 . 255)
                      '(-4 . "OR>")
                      '(-4 . "NOT>")
                )
    )
  )
  (setq sset (ssget "X" alist))
  (setq viewsset (ssget "X" '((0 . "VIEWPORT"))))
  (if viewsset
    (progn
      (setq n 0)
      (repeat (sslength viewsset)
        (if (setq clipent (assoc 340 (entget (ssname viewsset n))))
          (ssdel (cdr clipent) sset)
        )
        (setq n (1+ n))
      )
    )
  )
  (if sset
    (progn
      (setq pt (list 0.0 0.0))
      (entmake ;;write block header
               (list '(0 . "BLOCK")
                     '(2 . "*anon")
                     '(70 . 1)
                     (cons '10 pt)
               )
      )
      (setq a 0)
      (repeat (sslength sset)
        (setq ent2 (entmake (entget (setq ent (ssname sset a)))))
        (if (null ent2)
          (princ (entget (setq ent (ssname sset a))))
        )
        (if (assoc 66 (entget ent))
          (progn
            ;;add sub-entities until seqend is found
            (setq subent (entnext ent))
            (while (/= (cdr (assoc 0 (entget subent))) "SEQEND")
              (entmake (entget subent))
              (setq subent (entnext subent))
            )
            (setq ent3 (entmake (entget subent)))
            (if        (null ent3)
              (princ (entget subent))
            )
          )
        )
        (entdel ent)
        (setq a (1+ a))
        (c:spin "Making Block..")
      )
      (setq name (entmake '((0 . "endblk"))))
      (princ "\n  Inserting Block..\n")
      (if Mins
        ;;Minsert block reference at insertion point
        (entmake
          (list        '(0 . "INSERT")
                (CONS '100 "AcDbMInsertBlock")
                (CONS '70 2)
                (CONS '71 2)
                (cons '2 name)
                (cons '10 pt)
          )
        )
        (entmake
          (list        '(0 . "INSERT")
                (cons '2 name)
                (cons '10 pt)
          )
        )
      )
      (setq sset nil)
      (setq viewsset nil)
    )
    (if        layoutName
      (princ (strcat "\nNo entities to lock in " layoutName))
    )
  )
  (princ)
)

(defun Finish (vers)
  (setvar "clayer" cla)
  (setvar "tilemode" space)
  (if (= vers 2)
    (command "-layer" "state" "restore" "lockup" "" "")
  )
  (command "-layer" "lock" "*" "")
  (setvar "proxyshow" 1)
  (command "regen")
  (cond
    ((= cont "Yes")
     (alert
       "\nPaper space only has been locked.
                                \nTo lock model space, run Lockup
                                \nagain and do NOT skip to paper space."
     )
    )
    ((= answer2 "Model")
     (alert "\nAll selected entities have been locked.")
    )
    ((= answer2 nil)
     (alert "\nAll selected entities have been locked.")
    )
  )
  (setq        cont nil
        answer2        nil
  )
  (princ "\n加密完成. ")
  (princ)
)
(defun goLock14PS ()
  (setvar "tilemode" 0)
  (proxy)
  (anonBlock "14PS" nil)                ; make anon insert - on paper space
  (backblk "14PS" nil)                        ; make anon insert - on paper space
  (solidBlk "14PS" nil)                        ; make anon insert - on paper space
  (anonBlock "14PS" T)                        ; make anon minsert - on paper space
  (command "zoom" "extents")
  (prompt "\n  Paper Space has been locked.")
  (Finish 0)
)

(defun goLockPS        (vers)
  (if (= vers 0)
    (goLock14PS)
    (progn
      (princ "\nType in Layout Name to make current: ")
      (command "layout" "set" pause)        ;type in whatever layout to set current
      (while (> (getvar "cmdactive") 0) (command pause))
      (proxy)
      (anonBlock (getvar "CTAB") nil)        ; make anon insert in named layout
      (backblk (getvar "CTAB") nil)        ; make anon insert in named layout
      (solidblk (getvar "CTAB") nil)        ; make anon insert in named layout
      (anonBlock (getvar "CTAB") T)        ; make anon minsert in named layout
      (command "zoom" "extents")
      (initget "Yes No")
      (prompt
        (strcat "\n  Layout " (getvar "ctab") " has been locked.")
      )
      (setq answer
             (getkword "\nAre there more layouts to lock? Y/<N>: ")
      )
      (cond
        ((or (null answer) (= answer "No"))
         (Finish vers)
        )
        ((= answer "Yes")
         (goLockPS vers)
        )
        (T nil)
      )
    )
  )
)

(defun goLock (vers)
  (setvar "tilemode" 1)
  (if (= vers 2)
    (command "-layer" "state" "save" "lockup" "" "" "")
  )
  (command "-layer" "thaw" "*" "on" "*" "unlock" "*" "")
  (command "zoom" "extents")
  (proxy)
  (if (/= vers 0)
    (progn
      (anonBlock "Model" nil)                ; make anon insert in model space
      (backblk "Model" nil)                ; make anon insert in model space
      (solidblk "Model" nil)                ; make anon insert in model space
      (anonBlock "Model" T)                ; make anon minsert in model space
    )
    (progn
      (anonBlock "14MS" nil)
      (backblk "14MS" nil)
      (solidblk "14MS" nil)
      (anonBlock "14MS" T)
    )
  )
  (prompt "\n  Model Space has been locked.")
  (initget "Yes No")
  (setq        answer
         (getkword "\nDo you want to lock Paper Space? Y/<N>: ")
  )
  (cond
    ((or (null answer) (= answer "No")) (Finish vers))
    ((= answer "Yes") (goLockPS vers))
    (T nil)
  )
)

(defun states ()
  (if (= vers 2)
    (command "-layer" "state" "save" "lockup" "" "" "")
  )
  (command "-layer" "thaw" "*" "on" "*" "unlock" "*" "")
  (command "graphscr")
  (command "zoom" "extents")
  (goLockps vers)
)

(defun continue        ()
  (initget "Yes No")
  (setq        cont (getkword
               "\nModel Space will not be locked! Continue? Y/<N>: "
             )
  )
  (cond        ((= cont "Yes") (states))
        ((= cont "No") (skip))
        ((= cont nil) (skip))
  )
)

(defun skip ()
  (initget "Skip Model")
  (setq        answer2
         (getkword
           "\nStart in Model Space or Skip to Paper Space? Skip/<Model>:"
         )
  )
  (cond        ((= answer2 "Skip") (continue))
        ((= answer2 "Model") (goLock vers))
        ((= answer2 nil) (goLock vers))
  )
)

(defun 14or2k (/ answer)
  (initget "14 2000 2000i")
  (setq        answer
         (getkword
           "\nWhat version of AutoCAD are you in? 14/2000<2000i>: "
         )
  )
  (cond
    ((= answer "14") (setq vers 0))
    ((= answer "2000") (setq vers 1))
    ((= answer "2000i") (setq vers 2))
    ((= answer nil) (setq vers 2))
  )
  (skip)
)

(defun goexp ()
  (progn
    (repeat (sslength sset)
      (command "_explode" (ssname sset CNT))
      (setq CNT (1+ CNT))
      (c:spin "Exploding..")
    )
    (alert (strcat "\n    " (itoa CNT) " Entities Exploded."))
  )
  (setq sset nil)
  (princ)
)

(defun xpproxy (/ xpl)
  (alert
    "\n     Proxy Entities have been found.
    If they are not exploded, they will
  be omitted from the lockup process."
  )
  (initget "Yes No")
  (setq xpl (getkword "\nExplode Proxy Entities? Y/<N>: "))
  (if (or (= xpl "No") (= xpl nil))
    (princ)
  )
  (if (= xpl "Yes")
    (goexp)
  )
  (princ)
)

(defun goerase ()
  (progn
    (repeat (sslength wsset)
      (entdel (ssname wsset WCNT))
      (setq WCNT (1+ WCNT))
      (c:spin "Erasing..")
    )
    (alert (strcat "\n    " (itoa WCNT) " Wipeouts Erased."))
  )
  (setq wsset nil)
  (princ)
)

(defun goaskerase (/ del)
  (alert
    "\n     Wipeouts have been found."
  )
  (initget "Yes No")
  (setq del (getkword "\nErase Wipeouts? Y/<N>: "))
  (if (or (= del "No") (= del nil))
    (princ)
  )
  (if (= del "Yes")
    (goerase)
  )
  (princ)
)

(defun gowipeout (/ where wlist)
  (setq where (getvar "tilemode"))
  (setq cs 67)
  (if (= where 0)
    (setq sp 1)
  )
  (if (= where 1)
    (setq sp 0)
  )
  (setq        wlist (list (cons cs sp)
                    '(0 . "wipeout")
              )
  )
  (setq WCNT 0)
  (setq wsset (ssget "x" wlist))
  (if (= wsset nil)
    (princ)
  )
  (if (not (= wsset nil))
    (goaskerase)
  )
  (princ)
)

(defun proxy (/ where plist)
  (setq where (getvar "tilemode"))
  (if (= where 0)
    (setq plist        '((-4 . "<NOT")
                  (67 . 0)
                  (-4 . "NOT>")
                  (-4 . "<OR")
                  (0 . "ACAD_PROXY_ENTITY")
                  (0 . "AECC_*")
                  (0 . "AEC_*")
                  (0 . "AECS_*")
                  (0 . "RTEXT")
                  (-4 . "OR>")
                 )
    )
  )
  (if (= where 1)
    (setq plist        '((-4 . "<NOT")
                  (67 . 1)
                  (-4 . "NOT>")
                  (-4 . "<OR")
                  (0 . "ACAD_PROXY_ENTITY")
                  (0 . "AECC_*")
                  (0 . "AEC_*")
                  (0 . "AECS_*")
                  (0 . "RTEXT")
                  (-4 . "OR>")
                 )
    )
  )
  (setq CNT 0)
  (setq sset (ssget "x" plist))
  (if (= sset nil)
    (princ)
  )
  (if (not (= sset nil))
    (xpproxy)
  )
  (gowipeout)
  (princ)
)

(defun c:undolock ()
  ;;Undo and Reset variables
  (setvar "cmdecho" 0)
  (princ "\nPlease wait while Lockup is undone.")
  (command "undo" "end")
  (command "undo" "back")
  (setvar "cmdecho" 1)
  (setvar "filedia" 1)
  (setvar "cmddia" 1)
  (setvar "clayer" cla)
  (princ "\nLockup has been undone.")
  (princ)
)

(defun c:look (/ alist CNT sset)
  (setq        alist '((-4 . "<OR")
                (0 . "ACAD_PROXY_ENTITY")
                (0 . "AECC_*")
                (0 . "AEC_*")
                (0 . "AECS_*")
                (0 . "RTEXT")
                (0 . "WIPEOUT")
                (-4 . "OR>")
               )
  )
  (setq CNT 0)
  (if alist
    (progn
      (setq sset (ssget "X" alist))
      (if sset
        (repeat        (sslength sset)
          (setq CNT (1+ CNT))
        )
      )
      (if (= CNT 1)
        (alert (strcat "\n        " (itoa CNT) " Entity found."))
      )
      (if (> CNT 1)
        (alert (strcat "\n       " (itoa CNT) " Entities found."))
      )
    )
  )
  (if (= sset nil)
    (alert "\nNo Entities were found.")
  )
  (princ)
)

(defun c:spin (wh)
  (prompt (strcat "\r  "
                  wh
                  (cond        ((= sp "|") (setq sp "/"))
                        ((= sp "/") (setq sp "-"))
                        ((= sp "-") (setq sp "\\"))
                        (T (setq sp "|"))
                  )
          )
  )
  (princ)
)

(defun C:Lockup        (/ start answer)
  (setq        fdia        (getvar "filedia")
        cdia        (getvar "cmddia")
        cmd        (getvar "cmdecho")
        cla        (getvar "clayer")
        space        (getvar "tilemode")
        olderr        *error*
        *error*        lockerror
        cont        nil
        answer2        nil
  )
  (setvar "cmdecho" 0)
  (command "UNDO" "Begin")
  (setvar "filedia" 0)
  (setvar "cmddia" 0)
  (command "undo" "mark")
  (command "-layer" "make" "LOCKUP" "")
  (command "color" "bylayer")
  (setvar "proxyshow" 0)
  (command "regen")
  (initget "Yes No")
  (setq        answer
         (getkword
           "\n请确认作好了图纸备份！继续加密? Y/<N>: "
         )
  )
  (cond
    ((or (= answer "No") (null answer))
     (Alert "LOCKUP aborted!")
    )
    ((= answer "Yes") (14or2k))
  )
  (command "UNDO" "End")
  (setq *error* olderr)
  (setvar "filedia" fdia)
  (setvar "cmddia" cdia)
  (setvar "cmdecho" cmd)
  (princ)
)
(princ)
;****************************************************多块同时缩放
(defun c:bs ()
  (command "_.undo" "_begin")
  (setq        old_err        *error*
        *error*        Sb_err
  )
  (setq blkname (getstring "\n请输入需缩放的块名称:"))
  (initget 7)
  (setq blkfactor (getreal "\n请输入缩放倍数:"))
  (setq blksset (ssget (list (cons 0 "INSERT") (cons 2 blkname))))
  (setq blksscnt (sslength blksset))
  (setq donecount 0)
  (while (> blksscnt 0)
    (setq temp (ssname blksset (setq blksscnt (1- blksscnt))))
    (setq templist (entget temp))
    (setq blkbasept (cdr (assoc 10 templist)))
    (command "scale" temp "" blkbasept blkfactor ^c)
    (setq donecount (1+ donecount))
  )
  (princ (strcat "\n完成缩放 "
                 (itoa donecount)
                 " 个名称为"
                 "\""
                 blkname
                 "\""
                 "的块."
         )
  )
  (command "_.undo" "_end")
)

(defun Bs_err (s)
  (princ "\n命令中止!")
  (setq *error* old_err)
  (princ)
)

(princ)
;****************************************************块统计
(defun c:btj ()
(setq st t)
(while st
(while  (not (setq st (entsel "\n选择需要统计的块:"))))
            (if  (= (cdr (assoc '0 (entget (car st)))) "INSERT")
                 (progn
                 (setq blockname (cdr (assoc '2 (entget (car st)))))
                 (setq st nil)
                 )
                 (princ "\n未选择到块!")
            )               
)

(princ (strcat "\n选择块" blockname "<全选>:"))
(setq ss (ssget))
(if (= ss nil) (setq ss (ssget "x")))
(setq n 0 m 0)
(while (and ss (< n (sslength ss)))
           (setq ssn (ssname ss n))
           (if (= (cdr (assoc '0 (entget ssn))) "INSERT")
               (progn
              (setq blockname1 (cdr (assoc '2 (entget ssn))))            
              (if (= blockname blockname1)
                  (setq m (+ m 1))
              )
              )
            )
            (setq n (+ n 1))
)
(alert  (strcat "块" blockname ":" (rtos m 2 0) "个"))
(setq pt (getpoint "\n给定输出的点位<不输出>:"))
(if pt
     (command "text" pt (getvar "textsize") "0"   (strcat "块" blockname "  " (rtos m 2 0) "个"))
)
)
;****************************************************炸开文字
(Defun C:XT (/ lvl lul lvp lvs lss ViewPL)
(SetQ lvs (GetVar "viewsize")
lss (GetVar "screensize")
)
(SetVar "cmdecho" 0)
(Defun ViewPL ( / vi vw vh vc)
(setq vi (* lvs (/ (Car lss) (Cadr lss)))
vc (GetVar "viewctr")
vw (list (- (car vc) (* 0.5 vi))
(- (cadr vc) (* 0.5 lvs))
)
vh (list (+ (car vc) (* 0.5 vi))
(+ (cadr vc) (* 0.5 lvs))
)
)
(List vw vh)
)
(PrinC "\n要分解的文字行: ")
(SetQ ltl (SSGet)
lvl (ViewPL)
lul (List (Caar lvl) (Cadadr lvl))
lvp (GetVar "viewctr")
)
(Command "mirror" ltl "" lvp "@0,1" "y"
"wmfout" "textb" ltl ""
"erase" ltl ""
"wmfin" "textb" lul "2" "" ""
"mirror" (EntLast) "" lvp "@0,1" "y"
"explode" (EntLast)
"erase" (ssget "p") "R" "W"
(polar (car lvl) (* 0.25 Pi)
(Max (Abs (/ lvs (Cadr lss)))
(Abs (/ (* lvs
(/ (Car lss) (Cadr lss))
)
(Car lss)
)
)
)
)
(cadr lvl)
""
)
(SetVar "cmdecho" 1)(PrinC)
)
;****************************************************改大小写
(defun c:dx ( / oldblp oldech olderr p dx L )
  (setq oldblp (getvar "blipmode")
        oldech (getvar "cmdecho")
        olderr *error*
  )
  (setvar "blipmode" 0)
  (setvar "cmdecho" 0)
  (defun *error* (msg)
    (princ "\n")
    (princ msg)
    (setvar "blipmode" oldblp)
    (setvar "cmdecho" oldech)
    (setq *error* olderr)
    (princ)
  )
  (prompt "\n请选择要改变的字符串.")
  (setq P (ssget))
  (initget 1 "D X")
  (setq dx (getkword"\n改成: [大写(D)/小写(X)]"))
  (setq L 0 m 0 n (sslength p))
  (while (< L n)
    (setq q (ssname p l))
    (if (= "TEXT" (cdr (assoc 0 (setq e (entget (ssname p l))))))
      (progn
        (if (= "X" dx)
          (progn
            (setq w1 (strcase (cdr (setq b (assoc 1 e))) T))
            (setq e (subst (cons 1 w1) b e))
            (entmod e)
            (setq m (+ 1 m))
          )
        )
        (if (= "D" dx)
          (progn
            (setq w1 (strcase (cdr (setq b (assoc 1 e)))))
            (setq e (subst (cons 1 w1) b e))
            (entmod e)
            (setq m (+ 1 m))
          )
        )
      )
    )
    (setq l (+ 1 l))
  )
  (if (= 0 m)
    (progn
      (princ "\n\t  没有任何被选中")
      (princ)
    )
  )
  (setvar "blipmode" oldblp)
  (setvar "cmdecho" oldech)
  (setq *error* olderr)
  (princ)
)
;****************************************************将所选对象的层变为当前层
(DEFUN C:LL( / e n)
(setq e (car (entsel "请选择对象，该对象所在层将变为当前层:")))
(if e (progn
(setq e (entget e))
(setq n (cdr (assoc 8 e)))
(command"layer" "set" n "")
))
)
;****************************************************只显示被选对象所在层
(DEFUN C:vl (/ ES EN EL A)
(princ "请选择对象，未被选中的对象所在的层将被关闭")
(setq ES (ssget) A 0 EN "" EL nil FL nil)
(while (/= EN nil)
(setq EN (ssname ES A) EL (cons EN EL) A (1+ A)))
(setq EL (cdr EL) FL (cdr (assoc ' 8 (entget (car EL)))) EL (cdr EL))
(repeat (- A 2)
(setq EN (cdr (assoc ' 8 (entget (car EL))))
  FL (strcat EN "," FL) EL (cdr EL)) )
(command "LAYER" "off" "*" "y" "on" (eval FL) "")
(princ))
;****************************************************快速改对象的层
(DEFUN C:LQ()
(princ "请选择要改变层的对象\n")
(setq ss (ssget))
(if (and ss (> (sslength ss) 0))
(progn
(setq ent (entsel "\n请选择目标层上的对象:"))
(if ent (setq la (cdr(assoc 8 (entget (car ent)))))
(setq la (getvar "clayer"))
)
(command ".chprop" ss "" "layer" la "")
)
)
(princ)
)
;****************************************************解锁图层
(defun C:LK(/ ES EN EL A)
       (princ "请选择要解锁的图层上的对象")
       (setq ES (ssget) A 0 EN "" EL nil FL nil)
       (while (/= EN nil)
       (setq EN (ssname ES A) EL (cons EN EL) A (1+ A)))
       (setq EL (cdr EL) FL (cdr (assoc ' 8 (entget (car EL)))) EL (cdr EL))
       (repeat (- A 2)
       (setq EN (cdr (assoc ' 8 (entget (car EL))))
       FL (strcat EN "," FL) EL (cdr EL)) )
       (command "LAYER" "U" (eval FL) "")
(princ))
;****************************************************关闭所选物体所在的层
(DEFUN  C:OL ()
  (setvar "cmdecho" 0)
  (prompt"\n请选择要关闭的图层上的对象")
  (setq ss (ssget))
  (if (and ss (sslength ss) 0)
    (progn
     (setq ct 0 len (sslength ss) cl (getvar "clayer"))
     (command ".layer")
     (while (< ct len)
         (setq la (cdr (assoc 8 (entget (ssname ss ct)))))
         (if (/= cl la)(command "off" la)
                       (progn (prompt "\n你选择的层:")
                              (prompt la)
                              (prompt " 是当前层，不能关闭")
                       )  ;end of progn
         )                ;end of if
         (if (= old nil)(setq OLD la)(setq OLD (strcat OLD "," la)))
         (setq ct (1+ ct))
       )                  ;end of while
       (command"")
     )                  ;end of progn
)                      ;end of if
(princ)
(setvar "cmdecho" 0) (prin1)
)
;****************************************************冻结所选物体所在的层
(defun C:FL (/ ES EN EL A)
(princ "请选择要冻结的图层上的对象.")
(setq ES (ssget) A 0 EN "" EL nil FL nil)
(while (/= EN nil)
(setq EN (ssname ES A) EL (cons EN EL) A (1+ A)))
(setq EL (cdr EL) FL (cdr (assoc ' 8 (entget (car EL)))) EL (cdr EL))
(repeat (- A 2)
(setq EN (cdr (assoc ' 8 (entget (car EL))))
  FL (strcat EN "," FL) EL (cdr EL)) )
(command "LAYER" "F" (eval FL) "")
(princ))
;****************************************************锁定所选物体所在的层
(defun C:KL (/ ES EN EL A)
(princ "请选择要加锁的图层上的对象.")
(setq ES (ssget) A 0 EN "" EL nil FL nil)
(while (/= EN nil)
(setq EN (ssname ES A) EL (cons EN EL) A (1+ A)))
(setq EL (cdr EL) FL (cdr (assoc ' 8 (entget (car EL)))) EL (cdr EL))
(repeat (- A 2)
(setq EN (cdr (assoc ' 8 (entget (car EL))))
  FL (strcat EN "," FL) EL (cdr EL)) )
(command "LAYER" "LO" (eval FL) "")
(princ))
;****************************************************显示全部层
(DEFUN C:W1 ()
       (command "layer" "on" "*" "")
(princ))
;****************************************************解冻全部层
(DEFUN C:W2 ()
        (COMMAND "LAYER" "THAW" "*" "")
    (PRINC)
)
;****************************************************解锁全部层
(DEFUN C:W3 ()
        (COMMAND "LAYER" "U" "*" "")
    (PRINC)
)
;****************************************************显示+解锁+解冻全部层
(DEFUN C:W123 ()
        (command "layer" "on" "*" "")
        (COMMAND "LAYER" "THAW" "*" "")
        (COMMAND "LAYER" "U" "*" "")
    (PRINC)
)
;****************************************************缺口线－虚线
(defun c:lu ()
  (setq    dist1 (udist 1 "" "\n\t线长" dist1 (list 0 0))
    dist2 (udist 1 "" "\n\t缺口长" dist2 (list 0 0))
    pt1   (getpoint "\n\t起点")
    pt2   (getpoint pt1 "\n\t终点")
    ang   (angle pt1 pt2)
    n1    (fix (/ (distance pt1 pt2) (+ dist1 dist2)))
  )
  (repeat (fix n1)
    (setq pt2 (polar pt1 ang dist1)
      pt3 (polar pt2 ang dist2)
    )
    (command "line" pt1 pt2 "")
    (setq pt1 pt3)
  )
  (princ)
)
(defun udist (bit kwd msg def bpt / inp)
  (if def
    (setq msg (strcat "\n" msg "<" (rtos def) ">:")
      bit (* 2 (fix (/ bit 2)))
    )
    (setq msg (strcat "\n" msg ":"))
  )
  (initget bit kwd)
  (setq    inp
     (if bpt
       (getdist msg bpt)
       (getdist msg)
     )
  )
  (if inp
    inp
    def
  )
)
(defun upoint (bit kwd msg def bpt / inp)
  (if def
    (setq pts (strcat
        (rtos (car def))
        ", "
        (rtos (cadr def))
        (if (and (caddr def) (= 0 (getvar "flatland")))
          (strcat ", " (rtos (caddr def)))
          ""
        )
          )
      msg (strcat "\n" msg "<" pts ">: ")
      bit (* (fix (/ bit 2)))
    )
    (setq msg (strcat "\n" msg ": "))
  )
  (initget bit kwd)
  (setq    inp
     (if bpt
       (getpoint msg bpt)
       (getpoint msg)
     )
  )
  (if inp
    inp
    def
  )
)
;****************************************************剪选圈里的所有线
(defun c:cut (/ p1 p2 p3 p4 dst ang p1a p2a p3a p4a lst)
(cmdla0)
(setq p1 (getpoint "\n选择矩形框的第一角：")
p2 (getcorner p1 "\n选择矩形框的另一角：")
)
(setvar "osmode" 0)
(command "undo" "be")
(command "rectang" p1 p2)
(setq lst (entlast))
(setq p3 (list (car p2) (cadr p1))
p4 (list (car p1) (cadr p2))
dst (/ (distance p1 p2) 100.0)
ang (angle p1 p2)
p1a (polar p1 ang dst)
p2a (polar p2 ang (- 0 dst))
p3a (list (car p2a) (cadr p1a))
p4a (list (car p1a) (cadr p2a))
)
(command "_.trim" lst "" "f" p1a p3a p2a p4a p1a "" "")
(if (= txt5 "1")
(command "_erase" "all" "_r" "_c" p1 p2 "")
(command "_erase" "_w" p1 p2 "")
)
(command "rectang" p1 p2)
(command "undo" "e")
(cmdla1)
)
(defun CMDLA0 ()
(setq cmd (getvar "CMDECHO"))
(setq oom (getvar "orthomode"))
(setq osm (getvar "osmode"))
(setq hlt (getvar "highlight"))
(setq rmode (getvar "regenmode"))
(setvar "regenmode" 0)
(setvar "CMDECHO" 0)
(princ)
)
(defun CMDLA1 ()
(setvar "CMDECHO" cmd)
(setvar "orthomode" oom)
(setvar "osmode" osm)
(setvar "highlight" hlt)
(setvar "regenmode" rmode)
(princ)
)

;****************************************************块替换
(defun C:bth ()
  (setvar "osmode" 0)
  (princ "\n请选择作为源块的图块:")
  (setq a1 (ssget (list (cons 0 "insert"))))
  (setq stent (ssname a1 0))
  (setq stent (entget stent))
  (setq insname (assoc 2 stent))
  (setq insname (cdr insname))
  (princ insname)
  (princ "\n请选择将替换的图块:")
  (setq a (ssget (list (cons 0 "insert"))))
  (if (/= a nil)
    (progn
      (setq n (sslength a))
      (setq index 0)
      (repeat n
        (setq foent (ssname a index))
        (setq ent1 (entget foent))
        (setq index (+ index 1))
        (setq inspt (assoc 10 ent1))
        (setq inspt (list (nth 1 inspt) (nth 2 inspt)))
        (setq insang1 (assoc 50 ent1))
        (setq insang (cdr insang1))
        (if (/= insang 0)
          (setq insang (/ (* insang 180) pi))
        )
        (command "erase" foent "")
        (command "insert" insname inspt 1 1 insang "")
      )
    )
  )
  (setvar "osmode" 687)
  (princ)
)
;****************************************************直接修改FILLET半径来修改圆角
(defun c:CHR ( / cget en ent ps1 ps2 e1 e2 r1 r2)

  (defun cget(pt siz lnm / ss eout en ent p1 p2 n)
    (setq ss
      (ssget "c"
        (list (- (car pt) siz) (- (cadr pt) siz))
        (list (+ (car pt) siz) (+ (cadr pt) siz))
        (list '(0 . "LINE") (cons 8 lnm))
      )
    )
    (if ss (progn
      (setq n 0)
      (while (and (not eout) (setq en (ssname ss n)))
        (setq ent (entget en)
              p1 (cdr (assoc 10 ent))
              p2 (cdr (assoc 11 ent)))
        (if (or (equal p1 pt siz) (equal p2 pt siz))
          (setq eout en)) ;if
        (setq n (1+ n))
      )
    )) ;if
    eout
  ) ;CGET

  (setvar "cmdecho" 0)
  (command "undo" "group")
(while   (setq en (car (entsel)))
  (setq ent (entget en)
        o1 (cdr (assoc 10 ent))
        lnm (cdr (assoc 8 ent))
        r1 (cdr (assoc 40 ent))
        a1 (cdr (assoc 50 ent))
        a2 (cdr (assoc 51 ent)))
  (redraw en 3)
  (if (setq ls (getreal (strcat "半径<" (rtos r1 2) ">: ")))
    (setq r2 ls))
  (redraw en)
;  (setq r2 2000.0)
  (if (and r2 (/= r2 r1)) (progn
    (setq ps1 (polar o1 a1 r1) ps2 (polar o1 a2 r1))
    (setq e1 (cget ps1 0.1 lnm) e2 (cget ps2 0.1 lnm))
    (if (and e1 e2) (progn
      (entdel en)
      (setvar "filletrad" r2)
      (command "fillet" (list e1 ps1) (list e2 ps2))
    )) ;if
  )) ;if
)
  (command "undo" "end")
  (princ)
)
;****************************************************关闭所有窗口
(defun C:CW (/ item cur saveQuery)
  ;;  save if requested
  (defun saveQuery (item / titled writeable name reply)
    (setq titled (= 1 (vlax-variant-value (vla-getvariable item "DWGTITLED")))
          writeable (= 1 (vlax-variant-value (vla-getvariable item "WRITESTAT")))
          name (if titled
                 (vlax-get item "fullname")
                 (vlax-variant-value (vla-getvariable item "DWGNAME")) )
          reply (acet-ui-message
                    (acet-str-format "Save changes to %1?" name)
                                     "AutoCAD"
                                     (+ Acet:YESNOCANCEL Acet:ICONWARNING) ) )
    (cond
      ((= Acet:IDYES reply)
        (cond
          ;;  REFEDIT active ??
          ((/= "" (vlax-variant-value (vla-getvariable item "REFEDITNAME")))
            (acet-ui-message "Cannot Save while REFEDIT active."
                             "AutoCAD - CLOSEALL"
                             Acet:ICONSTOP )
            (exit)
          )
          ((and titled writeable)
            (vla-save item)
          )
          (T
            (if (setq name (getfiled "Save Drawing As" name "dwg" 1))
              (vla-saveas item (vlax-make-variant name))
              (exit)
            )
          )
        )
      )
      ((= Acet:IDCANCEL reply)
        (exit) )
    )
  )

  ;;  only valid in MDI
  (if (= 0 (getvar "SDI"))
    (progn
      ;;  quiet
      (acet-error-init '(("CMDECHO" 0)))
      ;;  locate current doc
      (setq cur (vla-get-activedocument (vlax-get-acad-object)))
      ;;  for each doc
      (vlax-for item (vla-get-documents (vlax-get-acad-object))
        ;;  skip current doc
        (if (not (equal cur item))
          (progn
            ;;  command active ??
            (if (/= 0 (vlax-variant-value (vla-getvariable item "CMDACTIVE")))
              (acet-ui-message "Cannot close all drawings while commands are active."
                               "AutoCAD - CLOSEALL"
                               Acet:ICONWARNING )
              (progn
                ;;  save if modified ??
                (if (/= 0 (vlax-variant-value (vla-getvariable item "DBMOD")))
                  (saveQuery item) )
                ;;  close without saving
                (vla-close item (vlax-make-variant :vlax-false))
              )
            )
          )
        )
      )
      ;;  close current
      (vla-sendcommand cur "_.CLOSE ")
    )
    (acet-ui-message "Command not available in SDI mode."
                     "AutoCAD - CLOSEALL"
                     Acet:ICONSTOP )
  )
  (princ))

;************************************************总面积标注-平方米/亩/公顷
(prompt "\n\r      加载图狼收集lsp工具.")
(defun c:ztmj(/ pt pt1 en aa bl-bz)
  (cmdla0)
  (setq sc 0.01)
  (if (= (tblsearch "style""宋体") nil)(COMMAND "style" "宋体" "宋体" (* SC 300) "1" "0" "" ""))
  (initget "A B C")
  (setq BL-bz (getkword "\n请选择标注单位 A-平方米/B-亩/C-公顷.<平方米>:"))
  (initget "Y N")
  (setq bz2 (getkword "需要标注单位名称吗?Y/<N>"))

  (setq pt (getpoint "\n选取封闭域内一点: "))
  (while pt
    (setq pt1 pt)
    (mkla"封闭域辅助线"8)
    (command "bpoly" pt "")
    (setq en (entlast))
    (if        (/= en nil)
      (progn
        (command "area" "o" en)
        (setq aa (getvar "area"))
        (redraw en 3);1标准2空白3高亮4低亮
        ;;;此句可以显示面积数（单位平方米）
        ;;;如果是总图或测量专业，画图单位为米时，下句中1000000.0应改为1.0
        ;(alert (strcat "面积=" (rtos (/ aa 1000000.0) 2 2)))
      )
    )
    ;(entdel en);;;此句可以删除“封闭域辅助线”
    (mkla"面积标注"4)
    ;A/平方米,B/亩,C/公顷
    ;(initget "A B C")
    ;(setq BL-bz (getkword "\n请选择标注单位 A平方米/B亩/C公顷.<平方米>:"))
    (setq bz2 (if bz2 bz2 "N"))
    (if (= bz2 "N")
      (progn
        (setq BL-bz (if BL-bz BL-bz "A"))
        (if (= bl-bz "A")(setq aa (rtos (/ aa 1.0) 2 2)))
        (if (= bl-bz "B")(setq aa (rtos (/ aa (/ 2000.0 3)) 2 2)))
        (if (= bl-bz "C")(setq aa (rtos (/ aa 10000.0) 2 4)))
        )
      (progn
        (setq BL-bz (if BL-bz BL-bz "A"))
        (if (= bl-bz "A")(setq aa (strcat (rtos (/ aa 1.0) 2 2) "平方米")))
        (if (= bl-bz "B")(setq aa (strcat (rtos (/ aa (/ 2000.0 3)) 2 2)"亩")))
        (if (= bl-bz "C")(setq aa (strcat (rtos (/ aa 10000.0) 2 4) "公顷")))
        )
      )
    (command "text" "j" "mc" pt1 "0" aa)
    (setq pt (getpoint "\n选取封闭域内一点: "))
  )
  ;(prin1)
  (cmdla1)
  (pxyp"ztmj      (总图面积)")
)
;;; 保存原有系统变量，设置程序运行时的系统变量
(Defun cmdla0 ()
  (Setq        cmdech (Getvar "Cmdecho")
        oom    (Getvar "Orthomode")
        osm    (Getvar "Osmode")
        la     (Getvar "Clayer")
  )
  (Setvar "Cmdecho" 0)
  (Setvar "Regenmode" 0)
)

;;; 建图层: (mala "层名" 颜色号)
(Defun MKLA (a b)
  (If (= (Tblsearch "layer" a) nil)
    (Command "layer" "m" a "c" b a "")
    (Command "layer" "t" a "s" a "c" b a "")
  )
)

;;; 恢复原有系统变量
(Defun cmdla1 ();(/ cmdech LA oom osm)
  (Setvar "Cmdecho" cmdech)
  (Setvar "Clayer" LA)
  (Setvar "Orthomode" oom)
  (Setvar "Osmode" osm)
  (setvar "regenmode" 1)
  (Terpri)
  (Princ)
)

;;;* 显示命令简写
(DEFUN PXYP (TXT1)
  (SETQ        TXT1 (STRCAT "\n\r      程序命令: "  TXT1 "      -- gxkwok@163.com"))
  (PRINC TXT1)
  (Princ)
)
;************************************************将所有line变成闭合多义线
(defun c:ple (/ ssa ssa-ent ent-p i)
(command "undo" "be");设置返回起始点
(setq ssa (ssget))
(setq i 0)
(while (< i (sslength ssa))
(setq ssa-ent (ssname ssa i))
(setq ent-p (cdr(assoc 0 (entget ssa-ent))))
(if (not (null ent-p));判断原图元是否已串入多义线
(if (or (= ent-p "LWPOLYLINE") (= ent-p "POLYLINE"));判断原图元属性
(command "pedit" ssa-ent "j" ssa "" "")
(command "pedit" ssa-ent "y" "j" ssa "" "")
))
(setq i (1+ i))
)
(command "undo" "e");设置返回终止点
(princ)
);defun
;************************************************斜轴线对正垂直显示
(defun C:gv (/ os ctscale tt pt pt1 pt2 pt3 by ang)
  (princ (strcat "\n***斜轴线对正垂直显示软件V030528***"))
  (princ (strcat "\n        [图狼收集]"))
  (princ)
  (setvar "CMDECHO" 0)
  (setvar "ucsfollow" 0)
  (setvar "regenmode" 1)
  (setq os (getvar "OSMODE"))        ;  (if (= cts nil)(setq cts 100))
  ;;  (setq ctscale (getreal (strcat "\n出图比例(1:?) <" (rtos cts 2 0) ">:")))
  ;;  (if (= ctscale nil)(setq ctscale cts))
  ;;  (setq cts ctscale)
  (setq ctscale 100)
  (initget "Y W")
  (setq tt (getkword "\nW-世界坐标系/<垂直显示>: "))
  (if (or (= tt "w") (= tt "W"))
    (progn
      (command "plan" "w")
      (command "ucs" "w")
      (command "view" "r" "dz")
      (setq ptt nil)
      (command "regen")
    )
    (progn
      (if (= ptt nil)
        (command "view" "s" "dz")
      )
      (setvar "osmode" 513)
      (setq pt1 (getpoint "\n点取Y轴原点<退出>:"))
      (if pt1
        (progn
          (setq pt2 (getpoint "\n选择Y轴正向<退出>:"))
          (if pt2
            (progn
              (setq ang (angle pt1 pt2))
              (command "color" "250")
              (setq pt3 (polar pt1 (- ang (/ pi 2)) (* 0.1 ctscale)))
              (setvar "osmode" (+ 16384 os))
              (command "line" pt1 pt3 "")
              (command "color" "Bylayer")
              (setq pt (entlast))
              (command "ucs" "e" pt)
              (command "plan" "")
              (setq ptt '
                    (0 0))
              (setq by (* 150 ctscale))
              (command "zoom" "c" ptt by)
              (entdel pt)
              (command "regen")
            )                        ;progn
          )                          ;if pt2
        )                            ;progn
      )                              ;if pt1
      (setvar "osmode" os)
    )                                ;progn
  )                                  ;if tt
  (princ (strcat "\n***斜轴线对正垂直显示软件V030528***"))
  (princ (strcat "\n        [图狼收集]"))
  (princ)
)
;************************************************将线等分并断开
(defun c:dib (/ obj piece plen ptlst dis npt)
  (setq        obj   (vlax-ename->vla-object (setq en (car (entsel "\n选择多义线: "))))
        piece (getint "\n分段数: ")
        plen
              (vlax-curve-getdistatpoint obj (vlax-curve-getendpoint obj))
;;;        ptlst
;;;              (list (vlax-curve-getstartpoint obj))
        dis
              0
  )
  (repeat (1- piece)
    (setq dis        (+ dis (/ plen piece))
          npt        (vlax-curve-getpointatdist obj dis)
          ptlst        (cons npt ptlst)
    )
  )
;;;  (setq ptlst (reverse (cons (vlax-curve-getendpoint obj) ptlst)))
  (foreach pt ptlst
    (vl-cmdf "break" (list en pt) pt)
  )
;;;  ptlst
  (princ)
)
;************************************************文字字体替代
(defun c:ft( / lb_eng lb_chn lb_sech lb_tt1 lb_tt2 lb_a1 lb_a2 lb_hh)
  (setvar "REGENMODE" 0)
  (setq lb_eng (getstring "英文替代<Simplex>:") lb_chn (getstring "中文替代<Hztxt>:"))
  (if (= "" lb_eng)(setq lb_eng "simplex"))
  (if (= "" lb_chn)(setq lb_chn "hztxt"))
  (setq lb_sech (tblnext "style" t))
  (while lb_sech
    (setq lb_tt1 (cdr(assoc 3 lb_sech)) lb_tt2 (cdr(assoc 4 lb_sech)))
    (if (or (<= (strlen lb_tt1) 4)
            (/= "." (strcase(substr lb_tt1 (- (strlen lb_tt1) 3) 1)))        
        )
        (setq lb_tt1 (strcat lb_tt1 ".shx"))
    )
    (if (or (<= (strlen lb_tt2) 4)
            (/= "." (strcase(substr lb_tt2 (- (strlen lb_tt2) 3) 1)))
        )
        (if (/= "" lb_tt2)(setq lb_tt2 (strcat lb_tt2 ".shx")))
    )
    (if (/= ".TTF" (strcase(substr lb_tt1 (- (strlen lb_tt1) 3) 4)))
      (progn
        (if (null (findfile lb_tt1))(setq lb_a1 lb_eng)(setq lb_a1 lb_tt1))
        (if (= "" lb_tt2)
          (setq lb_a2 "")
          (if (null (findfile lb_tt2))(setq lb_a2 lb_chn)(setq lb_a2 lb_tt2))
        )
        (setq lb_hh (strcat lb_a1 "," lb_a2))
        (command "-style" (cdr(assoc 2 lb_sech)) lb_hh "" "" "" "" "" "")
      )
      (if (null (findfile lb_tt1))(command "-style" (cdr(assoc 2 lb_sech)) (strcat lb_eng "," lb_chn) "" "" "" "" "" ""))
    )
    (setq lb_sech (tblnext "style"))
  )
(setvar "REGENMODE" 1)
(command "regen")
)
(princ " HH 命令帮助")

ayl1004

这程序别说看了，就是往下拉，也得半天工夫，我是看x版给的大拇指才进来的。

hao3ren

好多字符被QQ表情占据了，这种最好发附件

enn09

好程序，感谢分享

怒放的生命acai

新人路过学习，谢谢分享...

yxianfo

谢谢分享、下载学习

wfch20000

谢谢分享，不错的程序

吴外安放

谢谢分享,不错的程序

huangpc27

好老的代码啊，谢谢分享。

许锦华_gHav7

厉害。。。这么长啊

wofatfat19777

收厉害。。。这么长啊