;;; 1998.03.19
;;; 1998.06.01 1998.08.06
;;; Solid色块填充
;;;*** *** main func 色块填充------------------------------
(defun #stc (/	   cc	 e     ii    pt	   se	 ft    lay   undom
	     e0	   hand	 laybj layfh wjms  wjmu	 bigb  exb   flag
	     dklx  se0	 fhb   ss0   ss1   bjent ss    pt    ptb  loop
	    )
  (szload pub_save_var "wwpublic")
  (pub_save_var)
  (setq	lay   "PP-DK-SK"
	layfh "PP-DX-FH"
	se0   7
  )
  (mk_lay lay)

  (setq cc "\n选边界线:")
  (setq undom (HY_ClearUNDO))
  (setq ft t)
  (while ft
    (initget "H X Y U")
    (setq pt
	   (getpoint
	     "\n回车退出 / 回退 U / 选边界线 Y / 选图素构造边界线 X / 绘边界线 H / <点取填充域>:"
	   )
    )
    (cond
      ((= pt nil)
       (setq ft	nil
	     e	nil
       )
      )
      ((= pt "U")
       (setq e nil)
       (if (> (getvar "undomarks") undom)
	 (HY_UndoB)
	 (progn
	   (prompt "\n已全部回退！")
	   (beep)
	 )
       )
      )
      ((= pt "H")
       (setq e	   (&gzdkbj)
	     bjent e
       )
      )
      ((= pt "X")
       (setq y t)
       (while y
	 (prompt "\n回车或空选返回 /<选择边界图素>:")
	 (setq ss (ssget))
	 (cond
	   ((= ss nil) (setq y nil))
	   (t
	    (initget 1)
	    (setq pt (getpoint "\n点取闭合区域内任一点:"))
	    (setq e (hy_bpoly pt ss))
	    (if	e
	      (progn
		(redraw e 3)
		(initget "Y N")
		(setq kk (getkword "\n变虚的线是边界线吗(y/n)?<y>:"))
		(if (= kk "N")
		  (progn
		    (entdel e)
		    (setq e nil)
		    (print)
		  )
		  (setq	y nil
			bjent e
		  )
		)
	      )
	      (progn
		(setq e nil)
		(print)
		(prompt "\n选择图素太复杂,不能形成边界线!")
	      )
	    )
	   )
	 )				;end of cond ss
       )
      )
      ((= pt "Y")
      　(setq loop t)
       (while loop
            (setq e (HY_SelSingleEnt cc "*POLYLINE" nil nil))
            (if (/= e "RETURN") (setq loop nil) (print "所选的边界不是PLINE线,请重新选取！"))
       )
                
       (if (= (type e) 'LIST)
	 (progn
	   (setq e (car e))
	   (if (or (= 1 (cdr (assoc 70 (entget e))))
		   (equal (car (setq ptb (bg-ypp e))) (last ptb) 0.01)
	       )
	     (redraw e 3)
	     (progn
	       (setq e nil)
	       (prompt "\n边界不闭合!\n")
	     )
	   )
	 )
	 (progn
	   (setq e nil)
	   (beep)
	   (prompt "\n没有找到边界.")
	 )
       )
      )
      ((= (type pt) 'LIST)
       (setq e (#seltcbj pt))
       (if (= e nil)
	 (progn
	   (beep)
	   (prompt "\n没有找到边界.")
	 )
       )
      )
    )
    (if	e
      (progn
	(HY_UndoM)
	(setq e0 (entlast))
	(prompt "\n选择域内不填充的文字(TEXT)或复合线(POLYLINE):")
	(setq ss0 (ssget))
	(if ss0
	  (ssadd e ss0)
	  (progn
	    (setq ss0 (ssadd))
	    (ssadd e ss0)
	  )
	)
	(setq se (acad_colordlg se0 nil))
	(if (= se nil)
	  (setq se se0)
	  (setq se0 se)
	)

	(command ".hatch" "s" ss0 "")
	(if (and ss1 (> (sslength ss1) 0))
	  (command "erase" ss1 "")
	)

	(if (equal e0 (entlast))
	  (prompt "\n色块填充没有成功.")
	  (progn
	    (setq hand (cdr (assoc 5 (entget e))))
	    (command ".area" "o" e)
	    (HY_KZSJXZ (entlast) nil 62 se)
	  )
	)
      )
      (if (and bjent (entget bjent))
	(entdel bjent)
      )
    )
  )
  (if (and bjent (entget bjent))
    (entdel bjent)
  )
  (pub_re_var)
  (princ)
)
;;-----------------------------
(defun #seltcbj	(pt / ft pt ent k1 lay layold dd plw xjbz kk e)
  (setq	layold (getvar "clayer")
	plw    (getvar "plinewid")
  )
  (setq ft t)
  (while ft
    (if	(= pt nil)
      (setq ft	nil
	    ent	nil
      )
      (progn
	(if (= ent nil)
	  (setq	xjbz "X"
		ent  (hy_bpoly pt)
	  )
	  (setq xjbz "J")
	)
	(if ent
	  (progn
	    (redraw ent 3)
	    (initget "Y N")
	    (setq kk (getkword "\n变虚的线是边界线吗(Y/N)?<Y>:"))
	    (if	(= kk "N")
	      (progn
		(if (= xjbz "X")
		  (entdel ent)
		  (redraw ent 4)
		)
		(setq ent nil)
		(setq pt (getpoint "\n回车返回 /<点取闭合域内任一点>:"))
	      )
	      (progn
		(redraw ent 4)
		(setq ft nil)
	      )
	    )
	  )
	  (progn
	    (prompt "\n请靠近闭合域边界点取,回车返回!")
	    (getpoint)
	    (setq ft  nil
		  ent nil
	    )
	  )
	)
      )
    )
  )					;end of while ft
  (setvar "plinewid" plw)
  (setvar "clayer" layold)
  (setq e ent)
  (if (and e (= xjbz "X"))
    (setq bjent e)
  )
  e
)
;;;*** ***延长实体
(defun lineyhf (en el startp endp selectp / dis1 dis2 n	z1 z2 newp ang
		dist dist1)
  (setq dis1 (distance startp selectp))
  (setq dis2 (distance endp selectp))
  (setq dist1 (distance startp endp))
  (setq ang (angle endp startp))
  (setvar "snapang" ang)
  (setvar "orthomode" 1)
  (prompt (strcat "\n选择直线长度为:" (rtos dist1 2 pre)))
  (if (< dis1 dis2)
    (progn
      (initget "D")
      (setq dist (getpoint startp "\n输入长度 D / < 点示位置 >:"))
      (cond
	((= dist "D")
	 (setq dist (getreal "\n输入长度:"))
	 (setq newp (polar startp (angle endp startp) dist))
	)
	(t
	 (setq
	   dist	(* (distance dist startp)
		   (cos (- (angle startp dist) (angle endp startp)))
		)
	 )
	 (setq newp (polar startp (angle endp startp) dist))
	)

      )
      (if dist
	(progn
	  (setq	z1 (caddr startp)
		z2 (caddr endp)
	  )
	  (if (< z1 z2)
	    (setq newp (list (car newp)
			     (cadr newp)
			     (- z1 (* (/ dist dist1) (- z2 z1)))
		       )
	    )
	    (setq newp (list (car newp)
			     (cadr newp)
			     (+ z1 (* (/ dist dist1) (- z1 z2)))
		       )
	    )
	  )
	  (setq el (subst (cons 10 newp) (cons 10 startp) el))
	)
      )
    )
    (progn
      (initget "D")
      (setq dist (getpoint endp "\n输入长度 D /< 点示位置 >:"))
      (cond
	((null dist))
	((= dist "D")
	 (setq dist (getreal "\n输入长度:"))
	 (setq newp (polar endp (angle startp endp) dist))
	)
	(t
	 (setq dist (* (distance dist endp)
		       (cos (- (angle endp dist) (angle startp endp)))
		    )
	 )
	 (setq newp (polar endp (angle startp endp) dist))
	)
      )
      (if dist
	(progn
	  (setq	z1 (caddr endp)
		z2 (caddr startp)
	  )
	  (if (< z1 z2)
	    (setq newp (list (car newp)
			     (cadr newp)
			     (- z1 (* (/ dist dist1) (- z2 z1)))
		       )
	    )
	    (setq newp (list (car newp)
			     (cadr newp)
			     (+ z1 (* (/ dist dist1) (- z1 z2)))
		       )
	    )
	  )
	  (setq el (subst (cons 11 newp) (cons 11 endp) el))
	)
      )
    )
  )
  (if dist
    (progn
      (entmod el)
      (entupd en)
    )
  )
  (setvar "snapang" 0)
  (setvar "orthomode" 0)
)



(defun $lengthen (/	   enta	    entname  entlist  entpoint enttype
		  dis	   entstart entend   entstartp	       entendp
		  p	   r	    newarc   dis1     dis2     loop
		  uctr	   pre
		 )
  (szload pub_save_var "wwpublic")
  (pub_save_var)
  (setq loop t)
  (setq uctr (HY_ClearUNDO))
  (setq pre (getvar "luprec"))
  (while loop
    (setq enta (HY_SelSingleEnt	"\n回车退出 / 回退 U / 请选择直线或者弧:"
			"LINE,ARC"
			nil
			nil
			"U"
	       )
    )
    (cond
      ((null enta) (setq loop nil))
      ((= enta "RETURN")
       (prompt "\n请选择直线或弧!")
      )
      ((= enta "U")
       (if (<= (getvar "undomarks") uctr)
	 (prompt "\n已全部回退!")
	 (HY_UndoB)
       )
      )
      (t
       (setq entname (car enta))
       (setq entlist (entget entname))
       (setq entpoint (cadr enta))
       (setq enttype (cdr (assoc 0 entlist)))
       (cond
	 ((= enttype "LINE")
	  (setq entstart (cdr (assoc 10 entlist)))
	  (setq entend (cdr (assoc 11 entlist)))
	  (HY_UndoM)
	  (lineyhf entname entlist entstart entend entpoint)
	 )
	 ((= enttype "ARC")
	  (setq entstart (cdr (assoc 50 entlist)))
	  (setq entend (cdr (assoc 51 entlist)))
	  (setq p (cdr (assoc 10 entlist)))
	  (setq r (cdr (assoc 40 entlist)))
	  (setq entstartp (polar p entstart r))
	  (setq entendp (polar p entend r))
	  (setq dis1 (distance entstartp entpoint))
	  (setq dis2 (distance entendp entpoint))
	  (prompt (strcat "\n选择弧长度为:"
			  (rtos (arc_len entname) 2 pre)
			  ",夹角为:"
			  (rtos (rtod (arc_ang entname)) 2 3)
			  "度"
		  )
	  )
	  (setq newarc (getangle p "\n点示或输入角度:"))
	  (if newarc
	    (progn
	      (if (< dis1 dis2)
		(setq entlist (subst (cons 50 newarc)
				     (cons 50 entstart)
				     entlist
			      )
		)
		(setq entlist (subst (cons 51 newarc)
				     (cons 51 entend)
				     entlist
			      )
		)
	      )
	      (HY_UndoM)
	      (entmod entlist)
	      (entupd entname)
	    )
	  )
	 )
       )
      )
    )
  )
  (pub_re_var)
  (princ)
)
;;;*** *** 改标注位数
;;;1998.2.2
(defun ~gbzws (/ key)
  (initget "C S E")
  (setq	key (getkword
	      "\n以层选 C / 以小数点后位数选 S /退出 E / <回车选数字>"
	    )
  )
  (cond	((not key) (gws ""))
	((= key "C") (gws "C"))
	((= key "S") (gwss))
	((= key "E"))
  )
  (princ)
)
;;;
;;;
(defun gws (cs / y ss e1 gqz gqc gqz1 ghz index n e2)
  (setq y t)
  (while y
    (if	(= cs "C")
      (setq ss (ssget (glcm)))
      (setq ss (ssget '((0 . "TEXT"))))
    )
    (if	ss
      (progn
	(setq n	    (sslength ss)
	      index 0
	)
	(initget 5)
	(setq ws (getint "请输入新的小数位数:"))
	(repeat	n
	  (setq e1 (entget (ssname ss index)))
	  (setq index (+ index 1))
	  (setq gqz1 (cdr (assoc 1 e1)))
	  (setq gqz (car (ggtodn gqz1)))
	  (setq gqc (cadr (ggtodn gqz1)))
	  (if gqz
	    (progn
	      (setq gqs (atof gqz))
	      (setq ghz (rtos gqs 2 ws))
	      (setq ghz (strcat gqc ghz))
	      (setq e2 (subst (cons 1 ghz) (cons 1 gqz1) e1))
	      (entmod e2)
	    )
	  )
	  (setq y nil)
	)
      )
    )
  )
)

;;;;过滤位数
(defun glws (zfc / s zfcl dot? yws k)
  (if (= (ascii zfc) 46)
    (setq yws (- (strlen zfc) 1))
    (progn
      (if (and (/= (type (read zfc)) 'REAL)
	       (/= (type (read zfc)) 'INT)
	  )
	(setq yws nil)
	(progn
	  (if (= (type (read zfc)) 'INT)
	    (setq yws 0)
	    (progn
	      (setq zfcl (strlen zfc))
	      (setq k 0)
	      (setq s t)
	      (while s
		(setq dot? (substr zfc zfcl))
		(if (= (ascii dot?) 46)
		  (setq	yws k
			s nil
		  )
		  (setq	k    (1+ k)
			zfcl (- zfcl 1)
		  )
		)
	      )
	    )
	  )
	)
      )
    )
  )
  yws
)
(defun gwss (/ y ws ss mm yws e1 gqz ghz gqc gqz1 index n e2)
  (setq y t)
  (initget 5)
  (setq mm (getint "请输入小数位数:"))
  (prompt "请选择范围:")
  (while y
    (setq ss (ssget '((0 . "TEXT"))))
    (if	ss
      (progn
	(setq n	    (sslength ss)
	      index 0
	)
	(initget 5)
	(setq ws (getint "请输入新的小数位数:"))
	(repeat	n
	  (setq e1 (entget (ssname ss index)))
	  (setq index (+ index 1))
	  (setq gqz1 (cdr (assoc 1 e1)))
	  (setq gqc (cadr (ggtodn gqz1)))
	  (setq gqz (car (ggtodn gqz1)))
	  (if gqz
	    (progn
	      (setq yws (glws gqz))
	      (if (= mm yws)
		(progn
		  (setq gqs (atof gqz))
		  (setq ghz (rtos gqs 2 ws))
		  (setq ghz (strcat gqc ghz))
		  (setq e2 (subst (cons 1 ghz) (cons 1 gqz1) e1))
		  (entmod e2)
		)
	      )
	    )
	  )
	  (setq y nil)
	)
      )
    )
  )
)
(defun glcm (/ y s c h1 c1 ssb)
  (setq y t)
  (while y
    (while (null (setq s (car (entsel "\n选字样:")))))
    (if	(= (cdr (assoc 0 (entget s))) "TEXT")
      (setq y nil)
      (prompt "\n未选中字重选!")
    )
  )
  (setq c (strcase(cdr (assoc 8 (entget s)))))
  (setq c1 (getstring (strcat "\n字层" "<" c ">:")))
  (if (/= c1 "")
    (setq c (strcase c1))
  )
  (prompt "请选择范围:")
  (setq ssb (list (cons 8 c) '(0 . "TEXT")))
)
(defun ggtodn (ss / ns ns1 xh ss2 num num2)
  (if (or (null ss) (= ss ""))
    nil
    (progn
      (setq ns	(strlen ss)
	    ns1	0
	    xh	t
      )
      (while xh
	(setq ss2 (substr ss (- ns ns1) 1))
	(if (or	(= ss2 ".")
		(and (/= ss2 ")") (= (type (read ss2)) 'INT))
	    )
	  (setq ns1 (+ ns1 1))
	  (setq xh nil)
	)
	(if (= ns1 ns)
	  (setq xh nil)
	)
      )
      (cond
	((= ns ns1) (list ss ""))
	((/= ns1 0)
	 (setq num (substr ss (- ns ns1 -1)))
	 (setq num2 (substr ss 1 (- ns ns1)))
	 (list num num2)
	)
	(t nil)
      )
    )
  )
)
;;end of defun

(defun purge&clear( )
   (setvar "cmdecho" 0)
   (command "purge" "B" "" "N")
   (HY_ClearInvalidGroup)
   (setvar "cmdecho" 1)
)
;;; *** *** 分类编辑
;;;-----------------------------
;;;删除某类ENT
;;;-----------------------------
(defun dele (/ ft e eb lx lay ss kk)

  (setvar "cmdecho" 1)
  (setvar "blipmode" 0)
  (setq ft t)
  (while ft
    (setq e (entsel "\n选择某类实体中的任一个:"))
    (if	e
      (progn
	(setq e	  (car e)
	      eb  (entget e)
	      lx  (cdr (assoc 0 eb))
	      lay (strcase(cdr (assoc 8 eb)))
	)
	(redraw e 3)
	(if (= lx "INSERT")
	  (setq km (strcase(cdr (assoc 2 eb))))
	  (setq km "")
	)
	(if (wcmatch km "`**")
	  (setq km "`**")
	)				;*** Unnamed Block.

	(prompt
	  (strcat "\n过滤" lay "层的" lx "实体" km ", 请选择:")
	)
	(if (/= km "")
	  (setq ss (ssget (list (cons 0 lx) (cons 2 km) (cons 8 lay))))
	  (setq ss (ssget (list (cons 0 lx) (cons 8 lay))))
	)
	(if ss
	  (progn
	    (initget "F CHange Copy Move Erase")
	    (setq kk
		   (getkword
		     (strcat
		       "\n对选中的"
		       (itoa (sslength ss))
		       "个实体: 返回选择集F / CHange / Copy / Move /<Erase>:"
		     )
		   )
	    )
	    (if	(= kk nil)
	      (setq kk "Erase")
	    )
	    (cond
	      ((= kk "F")
	       (prompt
		 "\n对ACAD的其它命令的'select object'提示, 输入p得到上一个选择集."
	       )
	       (setq ft nil)
	      )
	      ((= kk "Erase") (command "erase" ss ""))
	      ((= kk "Move") (command "move" ss "" pause pause))
	      ((= kk "Copy")
	       (command "copy" ss "" pause pause)
	       (while (/= (getvar "cmdnames") "") (command pause))
	      )
	      ((= kk "CHange")
	       (command "change" ss "" "p")
	       (while (/= (getvar "cmdnames") "") (command pause))
	      )
	    )
	  )
	  (redraw e 4)
	)
      )
      (setq ft nil)
    )
  )
  (princ)
)
;;--------------------------
;; 冻/锁/关某些层  "f"/"lo"/"off"
;;--------------------------
(defun lay00(flag / fhb layb lay laytmp)
  (setvar "cmdecho" 0)
  (setq laytmp (getvar "clayer"))
  
  (setq ft t)
  (while ft
    (initget 128)
    (setq e (entsel "\n 回车退出 / <选取层中任一实体>"))
    
    (cond
      ((= STR (type e)) (setq ft nil))
      ((= e nil) (princ))
      (t
        (setq e (car e)
              eb (entget e)
              lay (strcase(cdr (assoc 8 eb)))
        )
        (if (member lay fhb)
          (prompt (strcat "\n" lay "层已经提取。"))
          (progn
            (setq fhb (cons lay fhb))
            (setq fhb (liscut fhb laytmp))
  	    (if fhb 
    		(progn
      		   (setq layb (getlay "*"))
      		   (command "layer")
      		   (foreach lay layb
        		(if (member lay fhb) (command flag lay))
     		   )
     		   (command "")
    		   )		
    		(prompt "\n没有选层。")
 	     )
 	  )
        )
      )
    )
  )
  ;;(setq fhb (qlayer))   
)
;;--------------------------
;; 冻/锁/关某些层外所有层  "f"/"lo"/"off"
;;--------------------------
(defun lay11(flag / fhb layb lay laytmp)
  (setvar "cmdecho" 0)
  (setq laytmp (getvar "clayer"))
  
  (setq fhb (qlayer))
  (setq fhb (cons laytmp fhb))
  (if fhb 
    (progn
      (setq layb (getlay "*"))
      (command "layer")
      (foreach lay layb
        (if (member lay fhb) 
          (princ)
          (command flag lay)
        )
      )
      (command "")
    )
    (prompt "\n没有选层。")
 )
  ;;(setq fhb (qlayer))  
)
;;-----------------------------
;; 1996.10.15 thu
;; 解冻/锁  "t"/"u"/"on"
;;-----------------------------
(defun lay22(flag / fhb lay laytmp)
  (setvar "cmdecho" 0)
  (setq laytmp (getvar "clayer"))
  (setq fhb (getlay "*"))
  
  (command "layer")
  (foreach lay fhb
    (command flag lay)
  )
  (command "")
  (princ)    
)
;;-----------------------------
;; 1996.10.15 tue
;; 取层
;; return => ("12" "23" ...) / nil
;;-----------------------------
(defun qlayer(/ ft e eb lay fhb)

  (setq ft t)
  (while ft
    (initget "E")
    (setq e (entsel "\n 回车退出 / <选取层中任一实体>"))
    
    (cond
      ((= STR (type e)) (setq ft nil))
      ((= e nil) (princ))
      (t
        (setq e (car e)
              eb (entget e)
              lay (strcase(cdr (assoc 8 eb)))
        )
        (if (member lay fhb)
          (prompt (strcat "\n" lay "层已经提取。"))
          (progn
            (initget "Y N")
            (setq e (getkword (strcat "\n该层为" lay ",是否提取(Y/N):<Y>")))
            (if (/= e "N") (setq fhb (cons lay fhb)))
          )
        )
      )
    )
  )
  fhb
)
;;-------------------------------------------
;; 1996.02.12 mon
;; 取得某类层 --- getlay(pattern)
;; pattern    --- 某类层之特征 ("*" for all)
;; 返回由符合条件的层名组成的表 ("xxx" "xxx" ...)
;;-------------------------------------------
(defun getlay(patt / b1 lay1 layb fftt fhb)
;----- 取层表 layb -----------------
  (setq b1 (tblnext "LAYER" t))   ;***** goto the first LAYER ***** 
  (setq lay1 (strcase(cdr (assoc 2 b1))))
  (setq layb (list lay1))

  (setq fftt t)
  (while fftt
    
    (setq b1 (tblnext "LAYER"))
    (if (= b1 nil)
      (progn
        (setq fftt nil)
        (tblnext "layer" t)       ;***** goto the first LAYER ***** 
      )
      (progn
        (setq lay1 (strcase(cdr (assoc 2 b1))))
        (setq layb (append (list lay1) layb))
      )
    )
  )
;--------------------------------------------
  (setq fhb nil)
  (foreach lay1 layb
    (if (wcmatch lay1 patt)
      (setq fhb (append (list lay1) fhb))
    )
  )
;--------------------------------------------  
  fhb
)
;;;--------------------------------
;;; 1996.05.13 mon   LISCUT(B e)
;;;--- 去掉表中的某一元素e --- 
;;; B : 可能含有e的表
;;;--------------------------------
(defun liscut(b e / ft ee bb)

  (setq ft t)  
  (foreach ee b
    (if (and (= ee e) (= ft t))
      (setq ft nil)
      (setq bb (cons ee bb))
    )
  )
  (setq bb (reverse bb))
)

;;; *** *** 改当前层
;;;------------------------------
;;; 1997.08.01 fri
;;; 切换当前层
;;;------------------------------
(defun qhlay (/ layold e eb lay layb)

  (setvar "cmdecho" 0)
  (setvar "blipmode" 0)
  (setq layold (getvar "clayer"))

  (prompt "\n*** 将当前层切换到选中实体所在的层 ***")
  (prompt (strcat "\n当前层: " layold))

  (initget "S")
  (setq e (entsel "\n切换到: 输入层名 S / <选目标层中的任一实体>:"))
  (cond
    ((= e nil) (princ))
    ((= e "S")
     (setq layb (getlay "*"))
     (setq lay (getstring "\n输入层名:"))
     (if (member (strcase lay) layb)
       (progn
	 (setvar "clayer" lay)
	 (prompt (strcat "\n当前层切换到: " lay))
       )
       (progn
	 (prompt "\n输入的层名不存在.")
	 (beep)
       )
     )
    )
    (t
     (setq e   (car e)
	   eb  (entget e)
	   lay (strcase(cdr (assoc 8 eb)))
     )
     (prompt (strcat "\n当前层切换到: " lay))
     (setvar "clayer" lay)
    )
  )
  (princ)
)
;;;-----------------------------
;;; 改实体图层
;;;-----------------------------
(defun ggtc (/ ss e eb lay layb lx km kk)

  (setvar "cmdecho" 0)
  (setvar "blipmode" 0)

					;(prompt "\n选择要更改图层的实体:")

  (prompt "\n*** 将选中实体转换到指定实体所在的图层上 ***")
  (setq ss t)
  (while ss
    (initget "F")
    (setq kk (getkword "\n分类过虑选择 F /<选择任意实体>:"))
    (if	(/= kk "F")
      (setq ss (ssget))
      (progn
	(setq e (entsel "\n选择某类实体中的任一个:"))
	(if e
	  (progn
	    (setq e   (car e)
		  eb  (entget e)
		  lx  (cdr (assoc 0 eb))
		  lay (strcase(cdr (assoc 8 eb)))
	    )
	    (redraw e 3)
	    (if	(= lx "INSERT")
	      (setq km (strcase(cdr (assoc 2 eb))))
	      (setq km "")
	    )
	    (if	(wcmatch km "`**")
	      (setq km "`**")
	    )				;*** Unnamed Block.

	    (prompt
	      (strcat "\n过滤" lay "层的" lx "实体" km ", 请选择:")
	    )
	    (if	(/= km "")
	      (setq
		ss (ssget (list (cons 0 lx) (cons 2 km) (cons 8 lay)))
	      )
	      (setq ss (ssget (list (cons 0 lx) (cons 8 lay))))
	    )
	  )
	  (setq ss nil)
	)
      )
    )
    (if	ss
      (progn
	(initget "S")
	(setq
	  e (entsel "\n转换到: 输入层名 S / <选目标层中的任一实体>:")
	)
	(cond
	  ((= e nil) (princ))
	  ((= e "S")
	   (setq layb (getlay "*"))
	   (setq lay (getstring "\n输入层名:"))
	   (if (member (strcase lay) layb)
	     (progn
	       (command "change" ss "" "p" "la" lay "")
	       (prompt (strcat "\n实体图层转换到: " lay))
	     )
	     (progn
	       (prompt "\n输入的层名不存在.")
	       (beep)
	     )
	   )
	  )
	  (t
	   (setq e   (car e)
		 eb  (entget e)
		 lay (strcase(cdr (assoc 8 eb)))
	   )
	   (command "change" ss "" "p" "la" lay "")
	   (prompt (strcat "\n实体图层转换到: " lay))
	  )
	)
      )
    )
  )
  (princ)
)
;;;------------------------------
(defun setnil ()
  (setq	qhlay nil
	ggtc nil
  )
  (princ)
)
;;; *** *** 移动实体
(defun dw-move (xz / p s)
  (szload pub_save_var "wwpublic")
  (pub_save_var)
  (prompt "\n选取目标:")
  (setq ss (ssget))
  (if (/= ss nil)
    (progn
      (if (null #getpt)
	(#ppls "pppp")
      )

      (setq p1 (getpoint "\n回车:方向+距离 / <基点>:"))

      (if p1
	(progn
	  (initget "P R X G")
	  (setq	p2
		 (#getpt
		   p1
		   "\n测量点 R / 已知点+方向+距离 P / 两线 X / 一个方向+距某线距离 G / 到点:"
		 )
	  )
	  (HY_SV)
	  (if (= xz "move")
	    (command ".move" ss "" p1 p2)
	    (command ".copy" ss "" p1 p2)
	  )
	  (HY_RV)
	)
	(progn

	  (setq ang (#setangww nil ""))

	  (setq ang (rtod ang))
	  (setq d (getdist "\n距离:"))
	  (if d
	    (progn
	      (HY_SV)
	      (if (= xz "move")
		(command ".move"
			 ss
			 ""
			 '(0 0)
			 (strcat "@" (rtos d 2 3) "<" (rtos ang 2 3))
		)
		(command ".copy"
			 ss
			 ""
			 '(0 0)
			 (strcat "@" (rtos d 2 3) "<" (rtos ang 2 3))
		)
	      )
	      (HY_RV)
	    )
	  )


	)
      )

    )
  )
  (command "snapang" 0)
  (PUB_RE_VAR)
)


					;
;;;设倾角
(defun #setangww
       (pt str / y ent entb etype p1 p2 ang mat ent1 wpt nent)
  (setq y t)
  (while y

    (while (= ent nil)
      (initget "S")
      (setq ent (nentsel "\n输入角度 S / 选择方向参考线:"))
    )
    (if	(= ent "S")
      (progn
	(setq ang (getangle "\n角度<0>:"))
	(if (null ang)
	  (setq ang 0)
	)
	(setq y nil)
      )
      (progn


	(setq pt (cadr ent))
	(if ent
	  (progn
	    (if	(= (length ent) 4)
	      (setq mat	 (caddr ent)
		    nent ent
	      )
	      (setq mat nil)
	    )
	    (setq ent	(car ent)
		  entb	(entget ent)
		  etype	(cdr (assoc 0 entb))
	    )
	    (cond
	      ((= etype "LWPOLYLINE")
	       (setq entb (dw-ypp1 (if nent
				     nent
				     ent
				   )
				   pt
			  )
	       )
	       (if (and entb (zerop (cadddr entb)))
		 (progn
		   (setq p1 (cadr entb)
			 p2 (caddr entb)
		   )
		   (setq ang (min (angle p1 p2) (angle p2 p1))
			 y   nil
		   )
		 )
		 (progn
		   (beep)
		   (prompt "\n请选直线段!")
		 )
	       )
	      )
	      ((= etype "LINE")
	       (setq p1	(cdr (assoc 10 entb))
		     p2	(cdr (assoc 11 entb))
	       )
	       (if mat
		 (setq p1 (pt_m2wcs p1 mat)
		       p2 (pt_m2wcs p2 mat)
		 )
	       )
	       (setq ang (min (angle p1 p2) (angle p2 p1))
		     y	 nil
	       )
	      )
	      ((= etype "VERTEX")
	       (if (zerop (cdr (assoc 42 entb)))
;;;polyline's line seg
		 (progn
		   (setq p1 (cdr (assoc 10 entb))
			 p2 (cdr
			      (assoc 10 (setq entb (entget (entnext ent))))
			    )
		   )
		   (if (null p2)
		     (progn
		       (setq ent1 (cdr (assoc -2 entb))
			     p2	  (cdr (assoc 10 (entget (entnext ent1))))
		       )
		     )
		   )
		   (if mat
		     (setq p1 (pt_m2wcs p1 mat)
			   p2 (pt_m2wcs p2 mat)
		     )
		   )
		   (setq ang (min (angle p1 p2) (angle p2 p1))
			 y   nil
		   )
		 )
		 (progn
		   (beep)
		   (prompt "\n请选直线段!")
		 )
	       )
	      )
	      (t
	       (beep)
	       (prompt "\n请选直线段!")
	      )
	    )
;;;end of cond

	    (if	(numberp ang)
	      (progn
		(setq p1 0)
		(setq ang (+ ang p1))
	      )
	    )

	    (HY_SV)

	    (if	pt
	      (progn
		(if (numberp ang)
		  (progn
		    (setvar "snapang" ang)
		    (setvar "orthomode" 1)
		  )
		  (setq ang (getvar "snapang"))
		)
		(setq ang (getangle pt (strcat "\n" str "方向:")))
		(if (null ang)
		  (setq ang (angle pt (cadr (grread t))))
		)
	      )
	    )

	  )
	  (setq y nil)
	)
      )
    )

  )
;;;end of while y
  (if (not (numberp ang))
    (setq ang (getvar "snapang"))
  )
  (HY_RV)
  ang
)
;;; *** *** 放缩图块
;;;-----------------------------
;;;放缩块
;;;-----------------------------
;;;1998.05.09
(defun dw-sblk (/     y	    n	  bl	oldbl ss    len	  blkn	lay
		entb  tkb   ent	  uctr	e     eb    tkm	  etype	pt
	       )
  (szload pub_save_var "wwpublic")
  (pub_save_var)
  (setq	oldbl 1.0
	uctr  (HY_ClearUNDO)
  )
  (setq y t)
  (while y
    (setq ent (HY_SelSingleEnt "\n回车退出 / 回退 U / 选取要放缩块中的一个:"
		       "INSERT"
		       nil
		       nil
		       "U"
	      )
    )
    (cond
      ((null ent) (setq y nil))
      ((= ent "RETURN") (prompt "\n未选中块,重选."))
      ((= ent "U")
       (if (<= (getvar "undomarks") uctr)
	 (prompt "\n已全部回退!")
	 (HY_UndoB)
       )
      )
      (t
       (setq ent   (car ent)
	     eb	   (entget ent)
	     etype (cdr (assoc 0 eb))
	     lay   (strcase(cdr (assoc 8 eb)))
       )
       (redraw ent 3)
       (setq tkm (strcase(cdr (assoc 2 eb))))
       (prompt (strcat "\n过滤"		lay
		       "层的"		etype
		       "实体"		tkm
		       ",请选择范围(全选敲all):"
		      )
       )
       (setq ss (ssget (list (cons 0 etype) (cons 2 tkm) (cons 8 lay))))
       (if (null ss)
	 (progn (setq ss (ssadd)) (ssadd ent ss))
       )
       (if ss
	 (progn
	   (initget 6)
	   (setq
	     bl	(getreal (strcat "\n缩放比例<" (rtos oldbl 2 2) ">:"))
	   )
	   (if bl
	     (setq oldbl bl)
	     (setq bl oldbl)
	   )
	   (if (not (equal bl 1 0.01))
	     (progn
	       (HY_UndoM)
	       (setq n 0)
	       (while (< n (sslength ss))
		 (setq e (ssname ss n))
		 (setq entb (entget e))
		 (setq pt (cdr (assoc 10 entb)))
		 (command "scale" e "" pt bl)
		 (setq n (1+ n))
	       )
	     )
	   )
	 )
       )
       (redraw ent 4)
      )
    )
  )
  (pub_re_var)
  (princ)
)
;;; *** *** 交互修改线形线宽
;;; ver r14
(defun dw-ww1 (/ y y1 dh yy s s1 n c h zh dd k h1 c1 l e kk y2 uctr ss
	       la)
  (setvar "cmdecho" 0)
  (setvar "blipmode" 0)
  (setq uctr (HY_ClearUNDO))
  (setq y2 t)
  (while y2
    (initget "X W U")
    (setq
      kk (getkword "\n回车退出 / 回退 U / 改颜色.线型 X / 改线宽 W:")
    )
    (cond
      ((null kk) (setq y2 nil))
      ((= kk "U")
       (if (<= (getvar "undomarks") uctr)
	 (prompt "\n已全部回退！")
	 (HY_UndoB)
       )
      )
      ((= kk "X")
       (setq yy t)
       (while yy
	 (initget "L C U")
	 (setq dh
		(getkword "\n回车退出 / 回退 U / 所有被选线 L / 某层线 C:"
		)
	 )
	 (cond
	   ((null dh) (setq yy nil))
	   ((= dh "U")
	    (if	(<= (getvar "undomarks") uctr)
	      (prompt "\n已全部回退！")
	      (HY_UndoB)
	    )
	   )
	   ((= dh "L")
	    (setq y t)
	    (while y
	      (prompt "\n选取线:")
	      (setq ss
		     (ssget
		       '((0 . "ARC,CIRCLE,LINE,SPLINE,XLINE,*POLYLINE,RAY")
			)
		     )
	      )
	      (if (null ss)
		(setq y nil)
		(dw-xx ss)
	      )
	    )
	   )
	   ((= dh "C")
	    (setq y t)
	    (while y
	      (setq s
		     (HY_SelSingleEnt "\n选样线:"
			      "ARC,CIRCLE,LINE,SPLINE,XLINE,*POLYLINE,RAY"
			      nil
			      nil
			      nil
		     )
	      )
	      (cond
		((null s) (setq y nil))
		((= s "RETURN") (prompt "\n未选中线,重选!"))
		(t
		 (setq la (strcase(cdr (assoc 8 (entget (car s))))))
		 (setq c1 (getstring (strcat "\n线层" "<" la ">:")))
		 (if (/= c1 "")
		   (setq la (strcase c1))
		 )
		 (setq ss
			(ssget
			  "X"
			  (list
			    (cons 8 la)
			    '(0
			      .
			      "ARC,CIRCLE,LINE,SPLINE,XLINE,*POLYLINE,RAY"
			     )
			  )
			)
		 )
		 (dw-xx ss)
		)
	      )
	    )
	   )
	 )
       )
;;;end of yy
      )
      ((= kk "W")
       (setq yy t)
       (while yy
	 (initget "L C U")
	 (setq dh
		(getkword "\n回车退出 / 回退 U / 所有被选线 L / 某层线 C:"
		)
	 )
	 (cond
	   ((null dh) (setq yy nil))
	   ((= dh "U")
	    (if	(<= (getvar "undomarks") uctr)
	      (prompt "\n已全部回退！")
	      (HY_UndoB)
	    )
	   )
	   ((= dh "L")
	    (setq y t)
	    (while y
	      (prompt "\n选取线:")
	      (setq ss (ssget '((0 . "ARC,LINE,*POLYLINE"))))
	      (if (null ss)
		(setq y nil)
		(dw-ww2 ss nil)
	      )
	    )
	   )
	   ((= dh "C")
	    (setq y t)
	    (while y
	      (setq s
		     (HY_SelSingleEnt "\n选样线:" "ARC,LINE,*POLYLINE" nil nil nil)
	      )
	      (cond
		((null s) (setq y nil))
		((= s "RETURN") (prompt "\n未选中线,重选!"))
		(t
		 (setq la (strcase(cdr (assoc 8 (entget (car s))))))
		 (setq c1 (getstring (strcat "\n线层" "<" la ">:")))
		 (if (/= c1 "")
		   (setq la (strcase c1))
		 )
		 (setq
		   ss (ssget
			"X"
			(list (cons 8 la) '(0 . "ARC,LINE,*POLYLINE"))
		      )
		 )
		 (dw-ww2 ss la)
		)
	      )
	    )
;;; end of y
	   )
	 )
       )
;;;end of yy
      )
    )
  )
  (princ)
)
;;;
(defun dw-xx (ss / yy ts ccl cxin clo cxin xin xin1 n s0)
  (setq ccl (strcat "\n选择颜色 1-红 2-黄 3-绿 4-青 5-兰 6-降红 7-白:"))
  (initget 6)
  (setq clo (getint ccl))
  (initget (+ 2 4))
  (setq cxin "\n选择线型 1-连续线 2-虚线 3-点划线 4-双点划线<1>:")
  (setq xin (getint cxin))
  (if (= xin nil)
    (setq xin 1)
  )
  (if (= xin 1)
    (setq xin1 "continuous")
  )
  (if (= xin 2)
    (setq xin1 "dashed")
  )
  (if (= xin 3)
    (setq xin1 "dashdot")
  )
  (if (= xin 4)
    (setq xin1 "divide")
  )

  (if (/= ss nil)
    (progn
      (HY_UndoM)
      (setq n 0)
      (while (< n (sslength ss))
	(setq s0 (ssname ss n))
	(if (= clo nil)
	  (command "change" s0 "" "p" "lt" xin1 "")
	  (command "change" s0 "" "p" "c" clo "lt" xin1 "")
	)
	(setq n (+ n 1))
      )
    )
  )

)
;;;
(defun dw-ww2 (ss    lay   /	 defw  lw    ss1   ent2	 ll    ff
	       pt1   pt2   pt3	 pt4   ptb   jd	   lay	 layb  ent1
	       etype v70
	      )
  (if lay
    (setq defw (DL_GetLayerLineWidth lay))
  )
  (if defw
    (progn
      (initget 4)
      (setq lw (getreal (strcat "\n图纸线宽<" (rtos defw 2 2) ">:")))
      (if (null lw)
	(setq lw defw)
      )
    )
    (progn
      (initget (+ 1 4))
      (setq lw (getreal "\n图纸线宽:"))
    )
  )
  (setq lw (/ lw (DL_GetDrawingFactor)))
  ;;(setq lw (/ lw 2.0))
  (prompt "\n正在工作,请稍侯...")
  (if ss
    (progn
      (HY_UndoM)
;;;modi 1998.08.06
;;;remove z value
      (setq len	(sslength ss)
	    n	0
      )
      (repeat len
	(setq ent   (ssname ss n)
	      entb  (entget ent)
	      etype (cdr (assoc 0 entb))
	      n	    (1+ n)
	)
	(cond
	  ((= etype "LINE")
	   (setq p1 (p# (cdr (assoc 10 entb)))
		 p2 (p# (cdr (assoc 11 entb)))
	   )
	   (HY_KZSJXZ ent nil 10 p1 11 p2)
	  )
	  ((= etype "ARC")
	   (setq p1 (p# (cdr (assoc 10 entb))))
	   (HY_KZSJXZ ent nil 10 p1)
	  )
	  (T
	  )
	)
      )
;;;----------------------
      (while (setq ent1 (ssname ss 0))
	(ssdel ent1 ss)
	(setq ss1 (ssadd))
	(ssadd ent1 ss1)
	(setq ptb (bg-ypp ent1)
	      pt1 (last ptb)
	      pt2 (car ptb)
	      ll  0
	      ff  0
	      jd  0.01
	)
	(while (setq ent2 (ssname ss ll))
	  (setq	ptb (bg-ypp ent2)
		pt3 (cadr ptb)
		pt4 (car ptb)
	  )
	  (cond
	    ((equal pt1 pt3 jd)
	     (setq pt1 pt4)
	     (ssdel ent2 ss)
	     (ssadd ent2 ss1)
	     (setq ff 1
		   ll -1
	     )
	    )
	    ((equal pt1 pt4 jd)
	     (setq pt1 pt3)
	     (ssdel ent2 ss)
	     (ssadd ent2 ss1)
	     (setq ff 1
		   ll -1
	     )
	    )
	    ((equal pt2 pt4 jd)
	     (setq pt2 pt3)
	     (ssdel ent2 ss)
	     (ssadd ent2 ss1)
	     (setq ff 1
		   ll -1
	     )
	    )
	    ((equal pt2 pt3 jd)
	     (setq pt2 pt4)
	     (ssdel ent2 ss)
	     (ssadd ent2 ss1)
	     (setq ff 1
		   ll -1
	     )
	    )
	  )

	  (setq ll (1+ ll))
	)

	(setq entb  (entget ent1)
	      etype (cdr (assoc 0 entb))
	      v70   (cdr (assoc 70 entb))
;;;close ?
	)
	(if (and (wcmatch etype "*POLYLINE") (= V70 1))
	  (command ".pedit" ent1 "w" lw "")
	  (progn
	    (if	(wcmatch etype "*POLYLINE")
	      (if (= ff 1)
		(command ".pedit" ent1 "j" ss1 "" "w" lw "")
		(command ".pedit" ent1 "w" lw "")
	      )
	      (if (= ff 1)
		(command ".pedit" ent1 "" "j" ss1 "" "w" lw "")
		(command ".pedit" ent1 "" "w" lw "")
	      )
	    )
	  )
	)
	(HY_Waiting)
	(princ)
;;;10:03 99-2-2add (princ)
      )
    )
  )
  (princ ".OK!")
  (princ)
)
;;; *** *** 旋转
(defun w_protat	(/ ssr p1 angr ang0)
  (szload pub_save_var "wwpublic")
  (pub_save_var)
  (HY_SV)
  (prompt "\n选择物体:")
  (if (setq ssr (ssget))
    (progn
      (sa_osmode)
      (setvar "osmode" 1)
      (prompt "\n当前捕捉方式为端点...")
      (initget 1)
      (setvar "blipmode" 1)
      (setq p1 (getpoint "\n选择基点:"))
      (setvar "blipmode" 0)
      (re_osmode)
      ;;;(setvar "osmode" 0)
      (setq angr (getr-ang "\n选择方向基线:"))
      (setq ang0 (getr-ang "\n选择方向参考线:"))
      (if (/= (getvar "orthomode") 1)
	(setvar "orthomode" 1)
      )
      (setvar "snapang" ang0)
      (command "rotate" ssr "" p1 "r" (rtod angr))
      (prompt "\n点示方位:")
      (command pause)
    )
  )
  (HY_RV)
  (pub_re_var)
  (princ)
)

;;;;add by wzy 2003-5-10 16:33 begin
(defun batchedit ( / w_prec ss_data ss_text  w_suffix w_prefix 
								w_input w_operator )
  (hy_set0)
  (sa_osmode)		
  (command "_.undo" "_begin")
  (pusherr chd_err)
  (setq back_lunits (getvar "lunits"))
  (setq back_luprec (getvar "luprec"))
  (setq back_dimzin (getvar "dimzin"))
  (setq back_aperture (getvar "aperture"))
  (setq back_ucsfollow (getvar "ucsfollow"))
  (setq back_blipmode (getvar "blipmode"))
  (setvar "cmdecho" 0)
  ;;;;(setvar "osmode" 0)
  (setvar "lunits" 2)
  (setvar "luprec" 3)
  (setvar "dimzin" 0)
  (setvar "aperture" 4)
  (setvar "ucsfollow" 0)
  (setvar "blipmode" 0)
  (princ "\n请选择需批量修改的数字文本集合：")
  (setq sset (ssget (list (cons 0 "text"))))
  (if (null sset)
    (progn (princ "\n没有选择任何包含数字的文本!") (exit))
  )
  (setq w_prefix "")
  (setq w_suffix "")
  (initget 0)
  (setq
    w_input (getstring (strcat "\n请输入文字前缀 <回车无前缀>:"))
  )
  (setq w_prefix w_input)
  (initget 0)
  (setq
    w_input (getstring (strcat "\n请输入文字后缀 <回车无后缀>:"))
  )
  (setq w_suffix w_input)
  (setq w_prefixlen (strlen w_prefix))
  (setq w_suffixlen (strlen w_suffix))
  (setq	sscnt	 (sslength sset)
	ss_text (ssadd)
	ss_data (ssadd)
  )
  (while (> sscnt 0)
    (setq temp (ssname sset (setq sscnt (1- sscnt))))
    (if	(= (cdr (assoc 0 (entget temp))) "TEXT")
      (ssadd temp ss_text)
    )
  )
  (setq txt_count (sslength ss_text))
  (if (= txt_count 0)
    (progn (princ "\n没有选择任何包含数字的文本!") (exit))
  )
  (while (> txt_count 0)
    (setq temp_text (ssname ss_text (setq txt_count (1- txt_count))))
    (setq textcont (cdr (assoc 1 (entget temp_text))))
    (setq textcont (vl-string-trim  " " textcont))
    (setq txt_len (strlen textcont))
    (if
      (and
	(= (substr textcont 1 w_prefixlen) w_prefix)
	(if (> txt_len w_suffixlen)
	  (= (substr textcont (- txt_len w_suffixlen -1) w_suffixlen)
	     w_suffix
	  )
	  nil
	)
	(dataflag temp_text)
      )
       (ssadd temp_text ss_data)
    )
  )
  (setq txt_count (sslength ss_text))
  (setq datasscnt (sslength ss_data))
  (if (= datasscnt 0)
    (progn (princ "\n您没有选择到任何有效数据!") (exit))
  )
  (setq datasscnt (sslength ss_data))
  (while (> datasscnt 0)
    (redraw (ssname ss_data (setq datasscnt (1- datasscnt))) 3)
  )
  (if (null w_operator)
    (setq w_operator "1")
  )
  (setq w_operator w_operator)
  (initget 0 "1 2 3 4 5 6 7")
  (setq	w_input
	 (getkword
	   (strcat "\n请选择数据操作类型(⑴+ ⑵- ⑶* ⑷/ ⑸Sq ⑹Sqrt ⑺Sum) <"
		   w_operator
		   ">:"
	   )
	 )
  )
  (if w_input
    (setq w_operator w_input)
  )
  (setq w_operator w_operator)
  (cond	((= w_operator "1")
	 (initget 1)
	 (setq operatordata (getreal "\n请输入增量:"))
	)
	((= w_operator "2")
	 (initget 1)
	 (setq operatordata (getreal "\n请输入减量:"))
	)
	((= w_operator "3")
	 (initget 1)
	 (setq operatordata (getreal "\n请输入乘数:"))
	)
	((= w_operator "4")
	 (initget 3)
	 (setq operatordata (getreal "\n请输入除数:"))
	)
  )
  (setvar "dimzin" 8)
  (if (null w_prec)
    (setq w_prec 3)
  )
  (setq dataprec w_prec)
  (initget 4)
  (setq	w_input (getint (strcat "\n请输入需保留的小数位数：<"
			      (rtos w_prec)
			      ">:"
		      )
	      )
  )
  (if w_input
    (setq dataprec w_input)
  )
  (setq w_prec dataprec)
  (setvar "luprec" dataprec)
  (if (null dfstxtstflag)
    (setq dfstxtstflag "Y")
  )
  (setq stxtstflag dfstxtstflag)
  (initget 0 "Y N")
  (setq	w_input (getkword
		(strcat "\n是否截去后缀零(Y/N) <" dfstxtstflag ">:")
	      )
  )
  (if w_input
    (setq stxtstflag w_input)
  )

  (setq dfstxtstflag stxtstflag)
  (if (= stxtstflag "Y")
    (setvar "dimzin" 8)
    (setvar "dimzin" 0)
  )
  
   (if (= w_operator "7")
	  (progn
		(setq datasscnt (sslength ss_data))
		  (setq sumdata 0)
		  (while (> datasscnt 0)
			(setq datalist
			   (entget (ssname ss_data (setq datasscnt (1- datasscnt)))
			   )
			)
			(setq origindatacont (cdr (assoc 1 datalist)))
			  (setq origindatacont (vl-string-trim  " " origindatacont))
			  (setq origindatacont (substr origindatacont (1+ w_prefixlen)))
			  (setq origindatalen (strlen origindatacont))
			  (setq datacont (substr origindatacont 1 (- origindatalen w_suffixlen)))
			  (setq data (atof datacont))
			  (setq sumData (+ sumData data))
		  )
		  (setq txt_count (sslength ss_text))
		  (setq datasscnt (sslength ss_data))
		  (princ (strcat "\n统计：选中 "
				 (itoa txt_count)
				 " 个文字,"
				 " 其中 "
				 (itoa datasscnt)
				 " 个有效数据."
			 )
		  )
		  (setq totalvalue (strcat w_prefix (rtos sumData) w_suffix))
		  (princ (strcat "\n     统计成功 总和为 " totalvalue)
		  )
		  (DL_DrawText totalvalue)
		 )
	  (progn
		(setq datasscnt (sslength ss_data))
		  (setq chcount 0)
		  (while (> datasscnt 0)
			(setq datalist
			   (entget (ssname ss_data (setq datasscnt (1- datasscnt)))
			   )
			)
			(setq origindatacont (cdr (assoc 1 datalist)))
			(opdata operatordata)
		  )
		  (setq txt_count (sslength ss_text))
		  (setq datasscnt (sslength ss_data))
		  (princ (strcat "\n统计：选中 "
				 (itoa txt_count)
				 " 个文字,"
				 " 其中 "
				 (itoa datasscnt)
				 " 个有效数据."
			 )
			 )
		  (princ (strcat "\n     更改成功 " (itoa chcount) " 个数据.")
		  )
		  (setq sscnt (sslength sset))
		  (while (> sscnt 0)
			(redraw (ssname sset (setq sscnt (1- sscnt))) 4)
		   )
	  )
	)	
  
  (redraw)
  (re_osmode)
;;;;  (setvar "osmode" back_osmode)
  (setvar "lunits" back_lunits)
  (setvar "luprec" back_luprec)
  (setvar "dimzin" back_dimzin)
  (setvar "aperture" back_aperture)
  (setvar "ucsfollow" back_ucsfollow)
  (setvar "blipmode" back_blipmode)
  (command "_.undo" "_end")
  (clr_err)
  (hy_rv)
  (princ)
)
(defun chd_err (s)
 ;;;;; (princ "\n命令中止!")
  (if sset
    (progn (setq sscnt (sslength sset))
	   (while (> sscnt 0)
	     (redraw (ssname sset (setq sscnt (1- sscnt))) 4)
	   )
    )
  )
  (redraw)
;;;;  (setvar "osmode" back_osmode)
  (setvar "lunits" back_lunits)
  (setvar "luprec" back_luprec)
  (setvar "dimzin" back_dimzin)
  (setvar "aperture" back_aperture)
  (setvar "ucsfollow" back_ucsfollow)
  (princ)
)
(defun dataflag (text_name / digitflag)
  (setq digitflag 1)
  (setq textlist (entget text_name))
  (setq baktextcont (cdr (assoc 1 textlist)))
  (setq baktextcont (vl-string-trim  " " baktextcont))
  (setq baktextcont (substr baktextcont (1+ w_prefixlen)))
  (setq origintextlen (strlen baktextcont))
  (setq textcont (substr baktextcont 1 (- origintextlen w_suffixlen)))
  (setq signc (substr textcont 1 1))
  (if (or (= (ascii signc) 43) (= (ascii signc) 45))
    (progn (setq digitflag nil) (setq count 1))
    (setq count 0)
  )
  (setq c "0")
  (while (or (= (ascii c) 46)
	     (and (>= (ascii c) 48) (<= (ascii c) 57))
	 )
    (setq count (1+ count))
    (setq c (substr textcont count 1))
  )
  (if (/= c "")
    (setq digitflag 1)
    (setq digitflag nil)
  )
  (if digitflag
    nil
    T
  )
)
(defun opdata (delta)
  (setq origindatacont (vl-string-trim  " " origindatacont))
  (setq origindatacont (substr origindatacont (1+ w_prefixlen)))
  (setq origindatalen (strlen origindatacont))
  (setq datacont (substr origindatacont 1 (- origindatalen w_suffixlen)))
  (setq data (atof datacont))
  (cond	((= w_operator "1") (setq cdata (+ data delta)))
	((= w_operator "2") (setq cdata (- data delta)))
	((= w_operator "3") (setq cdata (* data delta)))
	((= w_operator "4") (setq cdata (/ data delta)))
	((= w_operator "5") (setq cdata (expt data 2.0)))
	((= w_operator "6") (setq cdata (sqrt data)))
  )
  (setq	cdatalist (subst (cons 1 (strcat w_prefix (rtos cdata) w_suffix))
			 (assoc 1 datalist)
			 datalist
		  )
  )
  (entmod cdatalist)
  (setq chcount (1+ chcount))
)





(defun drawzp(  /  pt1 pt2 pt3 )
(HY_SET0)
      (initget 1)
      (setq pt1 (getpoint "\n请点取路肩边缘点:"))
　　　(initget 1)
      (setq pt2 (getpoint pt1 "\n请点取锥坡中点:"))
      (command "line" pt1 pt2 "")
　　　(initget 1)
      (setq pt3 (getpoint pt2 "\n请点取坡脚边缘点:"))
      (setq jd1 (angle pt2 pt1))
      (setq pi 3.14159265)
      (setq jd2 (angle pt2 pt3))
      (setq dist1 (distance pt1 pt2))
      (setq dist2 (distance pt2 pt3))
      (setq pt21 (polar pt2 jd1 (+ dist1 10.0)))
      (setq pt31 (polar pt2 jd2 (+ dist2 10.0)))
      (command "line" pt2 pt21 "")
        (setq ss1 (ssget "l"))
        (command "line" pt2 pt31 "")
        (setq ss2 (ssget "l"))
      (setq jd0 (- jd2 jd1)) 
      (if (> jd0 pi) (setq kind 1) (setq kind -1))
      (if (> jd0 pi) (setq jd0 (- (* 2 pi) jd0)))
      (if (< jd0 (- 0 pi)) (setq jd0 (+ pi pi jd0)))
      (if (< jd0 0) (setq kind 1))
            (setq jd0 (abs jd0))
     ;;;;---------确定椭圆长轴与短轴----------------------------------
      (if (> jd0 1.5707963) (setq jd01 (- pi jd0)) (setq jd01 jd0))  
      (setq a (+ (* dist1 dist1) (* dist2 dist2)))
      (setq b (* dist1 dist2 (sin jd01)))
      (setq a1 (+ a (* 2 b)))
      (setq b1 (- a (* 2 b)))
      (setq temp1 (/ (- (sqrt a1) (sqrt b1)) 2))
      (setq temp2 (/ (+ (sqrt a1) (sqrt b1)) 2))
      (setq temp1 (abs temp1))
      (setq temp2 (abs temp2))
      ;;;-------------------------------------------
  
      ;;;------bt确定椭圆长轴与斜轴的夹角------------
       (setq a2 (abs (* (+ dist2 temp2) (- dist2 temp2))))
       (setq b2 (abs (* (+ temp1 dist2) (- temp1 dist2))))
           (setq a2 (sqrt a2))
           (setq b2 (sqrt b2))
       (if (> jd0 1.5707963) (progn (if (= kind -1) (setq bt (atan (* temp2 b2) (* temp1 a2)))
                                                  (setq bt (atan (* temp1 a2) (* temp2 b2)))
                                     )
                             )
       )
;;;*******************
       (if (<= jd0 1.5707963)
        (progn
        	 (if (= kind 1) (setq bt (atan (* temp2 b2) (* temp1 a2)))
		          (setq bt (atan (* temp1 a2) (* temp2 b2)))
		        )
        )
       )

       ;;;-----以下行确定椭圆长轴位置-------------  
       (if (> jd0 1.5707963) (progn (if (= kind 1) (setq pl (polar pt2 (- jd2 bt) temp2))
                                       (setq pl (polar pt2 (- jd2 bt 1.5707963) temp2))
                                     )
                              )
        )
       (if (<= jd0 1.5707963) (progn (if (= kind 1) (setq pl (polar pt2 (- jd2 bt 1.5707963) temp2))
                                                  (setq pl (polar pt2 (- jd2 bt) temp2))
                                      )
                               )
       )
       ;;;;-----------------------------------------
   (if (> jd0 1.5707963)   
    (progn
         (setq jd (/ jd0 6 kind))
         (setq pt11 (polar pt2 (+ jd2 jd) (* dist1 0.2))
               pt12 (polar pt2 (+ jd2 (*  2 jd)) (* dist1 0.2))
               pt13 (polar pt2 (+ jd2 (*  3 jd)) (* dist1 0.2))
               pt14 (polar pt2 (+ jd2 (*  4 jd)) (* dist1 0.2))
               pt15 (polar pt2 (+ jd2 (*  5 jd)) (* dist1 0.2))
         )
         (command "ellipse" "c" pt2 pl temp1)
        (setq ent (entlast))
         
        (command "line" pt2 pt11 "")
        (setq ent1 (entlast))
        (command "extend" ent1 ent "" (list ent1 pt11) "")
        (setq pt11   (cdr (assoc 11 (entget ent1))))
        (setq pt11 (polar pt2 (+ jd2 jd) (* (distance pt2 pt11) 0.5)))
        (entdel ent1)
        (command "line" pt2 pt11 "")
        
        
        (command "line" pt2 pt12 "")
        (setq ent2 (entlast))
        (command "extend" ent2 ent "" (list ent2 pt12) "")
        (setq pt12   (cdr (assoc 11 (entget ent2))))
        (setq pt12 (polar pt2 (+ jd2 (*  2 jd)) (* (distance pt2 pt12) 0.8)))
        (entdel ent2)
        (command "line" pt2 pt12 "") 
        (setq ent2 (entlast))    
        
        (command "line" pt2 pt13 "") 
        (setq ent3 (entlast))
        (command "extend" ent3 ent "" (list ent3 pt13) "")
        (setq pt13   (cdr (assoc 11 (entget ent3))))
        (setq pt13 (polar pt2 (+ jd2 (*  3 jd)) (* (distance pt2 pt13) 0.5)))
        (entdel ent3)
        (command "line" pt2 pt13 "")       
        (command "line" pt2 pt14 "")
        (setq ent4 (entlast))
        (command "extend" ent4 ent "" (list ent4 pt14) "")
        (setq pt14   (cdr (assoc 11 (entget ent4))))
        (setq pt14 (polar pt2 (+ jd2 (*  4 jd)) (* (distance pt2 pt14) 0.8)))
        (entdel ent4)
        (command "line" pt2 pt14 "")
        
        (command "line" pt2 pt15 "") 
        (setq ent5 (entlast))
        (command "extend" ent5 ent "" (list ent5 pt15) "")
        (setq pt15   (cdr (assoc 11 (entget ent5))))
        (setq pt15 (polar pt2 (+ jd2 (*  5 jd)) (* (distance pt2 pt15) 0.5)))
        (entdel ent5)
        (command "line" pt2 pt15 "")
        
        )
     (progn
        (setq jd (/ jd0 4 kind)) 
        (setq pt11 (polar pt2 (+ jd2 jd) (* dist1 0.2))
              pt12 (polar pt2 (+ jd2 (*  2 jd)) (* dist1 0.2))
              pt13 (polar pt2 (+ jd2 (*  3 jd)) (* dist1 0.2))
              pt14 (polar pt2 (+ jd2 (*  4 jd)) (* dist1 0.2))
        )
        (command "ellipse" "c" pt2 pl temp1)
        (setq ent (entlast))
        (command "line" pt2 pt11 "")   
        (setq ent1 (entlast))  
        (command "extend" ent1 ent "" (list ent1 pt11) "")
        (setq pt11   (cdr (assoc 11 (entget ent1))))
        (setq pt11 (polar pt2 (+ jd2 jd) (* (distance pt2 pt11) 0.5)))
        (entdel ent1)
        (command "line" pt2 pt11 "")
        
        (command "line" pt2 pt12 "")
        (setq ent2 (entlast))   
        (command "extend" ent2 ent "" (list ent2 pt12) "")
        (setq pt12   (cdr (assoc 11 (entget ent2))))
        (setq pt12 (polar pt2 (+ jd2 (*  2 jd)) (* (distance pt2 pt12) 0.8)))
        (entdel ent2)
        (command "line" pt2 pt12 "") 
        (setq ent2 (entlast))    
                
        (command "line" pt2 pt13 "")
        (setq ent3 (entlast))           
        (command "extend" ent3 ent "" (list ent3 pt13) "")
        (setq pt13   (cdr (assoc 11 (entget ent3))))
        (setq pt13 (polar pt2 (+ jd2 (*  3 jd)) (* (distance pt2 pt13) 0.5)))
        (entdel ent3)
        (command "line" pt2 pt13 "")
        
        
        
     )
    )
        ;(setq p4 (polar pt2 (- jd2 bt pi) temp2))
        ;(setq ss3 (ssget p4))  
        ;;;(setq pt122 (polar pt2 (angle (pt12 pt2) )))
        ;;;(setq ss3 (entsel "\n选择欲删部分:"))
        (command "extend" ent ent2 "" (list ent2 pt2) "")
        (setq pt121   (cdr (assoc 10 (entget ent2))))
        (setq pt122   (cdr (assoc 11 (entget ent2))))
        (if(equal pt12 pt122 )
        	(setq pt122  pt121)
        )
        (setq ss3 (list ent pt122))   
        (command "trim" ss1 ss2 "" ss3 "")
        (entdel  ent2 )
        (command "line" pt2 pt12 "")
       (command "erase" ss1 ss2 "")
        (command "line" pt2 pt3 "")
        (hy_rv)
        (redraw)
)

(DEFUN drawarrow( / w_pt0 w_pt1 w_pt2 w_pt3 w_pt4 w_pt5 w_pt6 w_pt7 kword ang dst)
				(hy_set0)
       (initget "D")
       (setq kword (getkword "\n 双线 D / <回车单线>"))
       
       
       
       (initget 1)
       (setq w_pt0 (getpoint "\n请点取起点："))
       (initget 1)
       (setq w_pt5 (getpoint  w_pt0 "\n请点取终点："))
       (grdraw w_pt0 w_pt5 -1)
       (if kword
           (progn
                (setq ang (angle w_pt0 w_pt5)  
                      dst (distance w_pt0 w_pt5)
                      w_pt1 (polar w_pt0 (+ ang (/ pi 2.0)) (* 0.25 dst))
                      w_pt2 (polar w_pt0 (- ang (/ pi 2.0)) (* 0.25 dst))
                      w_pt3 (polar w_pt2 ang (* 0.35 dst))
                      w_pt4 (polar w_pt3 (- ang (/ pi 2.0)) (* 0.25 dst))
                      w_pt7 (polar w_pt1 ang (* 0.35 dst))
                      w_pt6 (polar w_pt7 (+ ang (/ pi 2.0)) (* 0.25 dst))
                 )
     (command "pline" w_pt1 "W" "0" "0" w_pt2 w_pt3 w_pt4 w_pt5 w_pt6 w_pt7 "c" )
           
        )
        (progn
              (setq ang (angle w_pt5 w_pt0)
                      dst (distance w_pt0 w_pt5)
                      w_pt1 (polar w_pt5 (+ (dtor 10) ang) (* 0.35 dst))
                      w_pt2 (polar w_pt5 (- ang (dtor 10)) (* 0.35 dst))
                )
                (command "pline" w_pt0 "W" "0" "0" w_pt5 w_pt1 "")
                (command "redraw")
        )
   　);;;;if
 		(hy_rv)      
       (princ)
)
(defun dtor(deg / )
     (* deg (/ pi 180.0))
)

(princ)



;;将用户选择的实体转为PLINE(不能是闭合的)
(defun to_pline ( / uctr y ent wid_pl dist_pre eraseOld key)
  (szload pub_save_var "wwpublic")
  (pub_save_var)
  (setq wid_pl (getvar "plinewid"))
  (setq dist_pre 1.0)
  (setq	uctr (hy_ClearUndo))
  (setq y t)
  (while y
    (initget "U S")
    (setq ent (entsel "\n回车退出 / 回退 U / 设置 S /选择需转换为PLINE线的实体(不能是闭合的):"))
    (cond
      ((null ent) (setq y nil))
      ((= ent "RETURN") (prompt "\n未实体,重选."))
      ((= ent "S")
       (setq key  (getreal (strcat "\n请输入拟合精度:<" (rtos dist_pre 2 2) ">")))
       (prompt "提示:凸度较大时该值应该小一些,系统默认值为1.0")
       (if (/=  key nil) (setq dist_pre key))
       (setq key  (getreal (strcat "\n请输入转换后的PLINE线宽度:<" (rtos wid_pl 2 2) ">")))
       (if (/=  key nil) (setq wid_pl key))
      )
      ((= ent "U")
       (if (<= (getvar "undomarks") uctr)
	 (prompt "\n已全部回退!")
	 (HY_UndoB)
       )
      )
      (t
        (setq ent (car ent))
        (redraw ent 3)
        (HY_undom)
        (hy_set0)
        (c_useren_pline ent dist_pre wid_pl)
        (hy_rv)
        (initget "Y N")
        (if (null  eraseOld ) (setq eraseOld "N"))
        (setq  key (getKword (strcat "\n是否删除转换前的实体,Y/N?<" eraseOld ">")))
        (if (not (null key)) (setq eraseOld key))
        (if (= eraseOld "Y") (entdel ent))
        (redraw ent 4)
       
      )
   )
  )
 (pub_re_var)
)


;;将用户自定义线条变成PLINE
(defun c_useren_pline(ent dist_pre wid_pl / ent_obj pt_start pt_end len_ent pt_list ns ns1 len_repeat
       pt_current    )
 (if (= vlax-curve-getStartPoint nil) (progn
   (vl-load-com)
 ))
 (if (= wid_pl nil) (progn
   (setq wid_pl 0.0)
 ))
 (setq ent_obj (vlax-ename->vla-object ent) )
 (setq pt_start (vlax-curve-getStartPoint ent_obj) pt_end (vlax-curve-getEndPoint ent_obj) )
 (if (or (= pt_start nil) (= pt_end nil)) (progn
   (prompt "\n 要转换线条有问题，没有转换.")
  ) (progn
	 (setq len_ent (vlax-curve-getDistAtPoint ent_obj pt_end))
   (if (and (/= (type len_ent) 'REAL) (/= (type len_ent) 'INT)) (progn
     (prompt "\n 要转换线条有问题，没有转换.")
    ) (progn
		 (setq pt_list (cons pt_start pt_list))
		 (setq ns (fix (/ len_ent dist_pre)) ns1 1)
		 (repeat ns
		  (setq len_repeat (* ns1 dist_pre)
		        pt_current (vlax-curve-getPointAtDist ent_obj len_repeat)
		  )
		  (setq pt_list (cons pt_current pt_list))
		  (setq ns1 (+ ns1 1))
		 )
		 (if (> (- len_ent (* ns dist_pre)) (* dist_pre 0.0001)) (progn
		   (setq pt_list (cons pt_end pt_list))
		 ))
		 (setq pt_list (reverse pt_list) pt_start (car pt_list) pt_list (cdr pt_list))
		 (command "pline" pt_start "w" wid_pl wid_pl)
		 (foreach pt_current pt_list
		     (command pt_current)
		 )
		 (command "")
	 ))  ;end of if (and (/= (type len_ent) 'REAL) (/= (type len_ent) 'INT)) (progn
 ))    ;end of if (or (= pt_start nil) (= pt_end nil)) (progn
 (princ)
)    ;end of defun
;;
;;




;;把图面上所有实体标高转换到零高度
(defun elev_to_zero( / ss )
 (szload pub_save_var "wwpublic")
 (pub_save_var)
 (prompt "\n <回车>将图面上所有的巨大Z值转为零 / 请选择Z值要转换为零的实体:")
 (setq ss (ssget))
 (command ".view" "s" "A0")
 (prompt "\n 正在工作，请稍候...")
 (hy_set0)
 (c_hy_largzto0 ss)
 (hy_rv)
 (pub_re_var)
 (c:pm)
 (command "view" "r" "A0")
)

;;将图面上的巨大Z值实体转化为Z＝0，同时它还具有把传入的选择集、实体名表或单个实体的Z值转化为零的功能
;;该函数尚未完成 2003.4.23 谷德性
(defun c_hy_largzto0(ss_var / ss_tmp ent ns ns1 enlx wb p1 p2    )

  (if (= ss_var nil) (progn
    (setq ss_var (ssget "X" '((-4 . "<or") (-4 . "*,*,>") (10 0.0 0.0 1.0e20)
                          (-4 . "*,*,>") (11 0.0 0.0 1.0e20) (-4 . ">") (38 . 1.0e20) 
                          (-4 . "*,*,<") (10 0.0 0.0 -1.0e20)
                          (-4 . "*,*,<") (11 0.0 0.0 -1.0e20) (-4 . "<") (38 . -1.0e20)(-4 . "or>"))
             )
    )
    
  ))

  (cond
   ((and (= (type ss_var) 'LIST) (= (type (car ss_var)) 'ENAME))
    (setq ss_tmp (ssadd))
    (foreach ent ss_var
        (ssadd ent ss_tmp)
    )
    (setq ss_var ss_tmp)
   )
   ((= (type ss_var) 'ENAME)
    (setq ss_tmp (ssadd))
    (ssadd ss_var ss_tmp)
    (setq ss_var ss_tmp)
   )
  )

  (if (= (type ss_var) 'PICKSET) (progn
    (setq ns (sslength ss_var) ns1 0)
    (repeat ns
     (setq ent (ssname ss_var ns1) wb (entget ent) enlx (cdr (assoc 0 wb)) )
     (cond
      ((= enlx "LINE")
       (setq p1 (cdr (assoc 10 wb)) p2 (cdr (assoc 11 wb))
             p1 (list (car p1) (cadr p1) 0.0) p2 (list (car p2) (cadr p2) 0.0)
       )
       (setq wb (subst (cons 10 p1) (assoc 10 wb) wb)
             wb (subst (cons 11 p2) (assoc 11 wb) wb)
       )
       (entmod wb)
       (entupd ent)
;       (kzsjxz ent nil 10 (list (car p1) (cadr p1) 0.0) 11 (list (car p2) (cadr p2) 0.0) )
      )
      (t
       (command "change" ent "" "p" "e" 0.0 "")
      )
     )
     (setq ns1 (+ ns1 1))
    )    ;end of repeat
  ))    ;;end of if (= (type ss_var) 'PICKSET) (progn
)
;;


(defun getr-ang
       (prmpt / pt y ent entb etype p1 p2 ang mat ent1 wpt nent)
  (setq y t)
  (while y
    (setq ent nil)
    (while (= ent nil)
      (setq ent (nentsel prmpt))
    )

    (setq pt (cadr ent))
    (if	ent
      (progn
	(if (= (length ent) 4)
	  (setq	mat  (caddr ent)
		nent ent
	  )
	  (setq mat nil)
	)
	(setq ent   (car ent)
	      entb  (entget ent)
	      etype (cdr (assoc 0 entb))
	)
	(cond
	  ((= etype "LWPOLYLINE")
	   (setq entb (dw-ypp1 (if nent
				 nent
				 ent
			       )
			       pt
		      )
	   )
	   (if (and entb (zerop (cadddr entb)))
	     (progn
	       (setq p1	(cadr entb)
		     p2	(caddr entb)
	       )
	       (setq ang (min (angle p1 p2) (angle p2 p1))
		     y	 nil
	       )
	     )
	     (progn
	       (beep)
	       (prompt "\n请选直线段!")
	     )
	   )
	  )
	  ((= etype "LINE")
	   (setq p1 (cdr (assoc 10 entb))
		 p2 (cdr (assoc 11 entb))
	   )
	   (if mat
	     (setq p1 (pt_m2wcs p1 mat)
		   p2 (pt_m2wcs p2 mat)
	     )
	   )
	   (setq ang (min (angle p1 p2) (angle p2 p1))
		 y   nil
	   )
	  )
	  ((= etype "VERTEX")
	   (if (zerop (cdr (assoc 42 entb)))
;;;polyline's line seg
	     (progn
	       (setq p1	(cdr (assoc 10 entb))
		     p2	(cdr (assoc 10 (setq entb (entget (entnext ent)))))
	       )
	       (if (null p2)
		 (progn
		   (setq ent1 (cdr (assoc -2 entb))
			 p2   (cdr (assoc 10 (entget (entnext ent1))))
		   )
		 )
	       )
	       (if mat
		 (setq p1 (pt_m2wcs p1 mat)
		       p2 (pt_m2wcs p2 mat)
		 )
	       )
	       (setq ang (min (angle p1 p2) (angle p2 p1))
		     y	 nil
	       )
	     )
	     (progn
	       (beep)
	       (prompt "\n请选直线段!")
	     )
	   )
	  )
	  (t
	   (beep)
	   (prompt "\n请选直线段!")
	  )
	)
;;;end of cond
      )
    )
  )
  ang
)


