本帖最后由 lhngxy 于 2018-4-4 08:09 编辑
(defun err(msg)
(princ msg);"*cancel*")
(restore)
)
(defun init()
(command "_.undo" "be")
(setq dimzin (getvar "dimzin"))
(setvar "dimzin" 1)
(setq os (getvar "osmode"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
(setq errtmp *error*)
(setq *error* err)
)
(defun restore()
(setq *error* errtmp)
(setvar "dimzin" dimzin)
(setvar "osmode" os)
(command "_.undo" "e")
)
(defun xl-sort (lst fun / nlst)
(foreach n lst (setq nlst (xl-isort n nlst fun))))
(defun xl-isort (item lst fun / k nlst)
(setq k T
nlst (apply &＃39;append (mapcar &＃39;(lambda (x)
(if (and K ((eval fun) item x)) (progn (setq k nil) (list item x)) (list x))
) lst))
)
(if k (append lst (list item)) nlst)
)
(defun setcolor(sname color / sinf)
(setq sinf (entget sname))
(if (assoc 62 sinf)
(setq sinf (subst (cons 62 color) (assoc 62 sinf) sinf))
(setq sinf (append sinf (list (cons 62 color))))
)
(entmod sinf)
)
(defun MakeText(pt Height Ang str / dxf)
(setq dxf &＃39;((0 . "TEXT") (100 . "AcDbEntity") (67 . 0) (410 . "Model")(8 . "JZP")(100 . "AcDbText")))
(setq dxf (append dxf (list (cons 10 pt) (cons 40 height) (cons 50 Ang) (cons 1 str))))
(setq dxf (append dxf &＃39;((41 . 0.8) (51 . 0.0) (71 . 0) (72 . 0)
(210 0.0 0.0 1.0) (100 . "AcDbText") (73 . 0))))
(entmake dxf)
)
(defun MakeText2(pt Height Ang str / dxf)
(setq dxf &＃39;((0 . "TEXT") (100 . "AcDbEntity") (67 . 0) (410 . "Model")(8 . "JZP")(100 . "AcDbText")(10 0.0 0.0 0.0)))
(setq dxf (append dxf (list (cons 11 pt) (cons 40 height) (cons 50 Ang) (cons 1 str))))
(setq dxf (append dxf &＃39;((41 . 0.8) (51 . 0.0) (71 . 0) (72 . 1)
(210 0.0 0.0 1.0) (100 . "AcDbText") (73 . 2))))
(entmake dxf)
)
(defun MakeText3(pt Height Ang str / dxf)
(setq dxf &＃39;((0 . "TEXT") (100 . "AcDbEntity") (67 . 0) (410 . "Model")(8 . "JZP")(100 . "AcDbText")(10 0.0 0.0 0.0)))
(setq dxf (append dxf (list (cons 11 pt) (cons 40 height) (cons 50 Ang) (cons 1 (strcat "J" str)))))
(setq dxf (append dxf &＃39;((41 . 0.8) (51 . 0.0) (71 . 0) (72 . 1)
(210 0.0 0.0 1.0) (100 . "AcDbText") (73 . 2))))
(entmake dxf)
)
(defun OpPts(pts pt h scal / pti ptn ptc ang len params pts2 i)
(setq pts_tmp nil)
(if (equal (distance (car pts) (last pts)) 0 0.00000000001) (setq pts (cdr pts)))
(setq pts2 (xl-sort pts &＃39;(lambda(e1 e2) (<(abs (- (angle pt e1) (/ pi 4))) (abs (- (angle pt e2) (/ pi 4)))))))
(setq i 1)
(mapcar &＃39;(lambda(e)
(MakeText3 (polar e (angle pt e) h) h 0.0 (itoa i))
(setq i (1&＃43; i))
) pts)
(mapcar &＃39;(lambda(e)
(MakeText2 (polar (cadr e) (&＃43; (/ pi 2) (car e)) (* 0.75 h))
h
(if (and (> (car e) (/ pi 2.0)) (<(car e) (* pi 1.5)))
(- (car e) pi)
(car e)
)
(rtos (last e) 2 2)))
params)
)
(defun GetVer(ent / pts ents)
(while (/&＃61; (cdr (assoc 0 (setq ents (entget (setq ent (entnext ent)))))) "SEQEND")
(setq pts (append pts (list (cdr (assoc 10 ents)))))
)
pts
)
(defun GETPL (ED / ENTS PTS)
(setq ENTS (entget ED))
(while (setq ENTS (member (assoc 10 ENTS) ENTS))
(setq PTS (append PTS (list (cdar ENTS))))
(setq ENTS (CDR ENTS))
)
PTS
)
(defun Order(pts / n pt ang angn angi angAll pt pti)
(setq n (length pts))
(setq pt (list (/ (apply &＃39;&＃43; (mapcar &＃39;car pts)) n)
(/ (apply &＃39;&＃43; (mapcar &＃39;cadr pts)) n)))
(setq ang (angle pt (car pts)))
(setq angAll 0)
(foreach pti (append (cdr pts) (list(car pts)))
(setq angn (angle pt pti))
(setq angi (- angn ang))
(cond
((> angi pi) (setq angi (- angi (* pi 2))))
(()
(setq angAll (&＃43; angAll angi))
(setq ang angn)
)
(cond
((equal angAll 0 1) (list pt nil))
((> angAll 0) (list pt nil))
(()
)
(defun DoubleM(ent / ents pt pts l h x y h2)
(setq ents (entget ent))
(if (&＃61; (cdr (assoc 0 ents)) "TEXT")
(progn
(setq pt (cdr (assoc 10 ents)))
(setq pts (textbox ents))
(setq l (caadr pts))
(setq h (cdr (assoc 40 ents)))
(setq x (&＃43; l (* h 0.4)))
(setq y (* h 0.7))
(setq h2 (* h 0.5))
(MakeText (list (&＃43; (car pt) x) (&＃43; (cadr pt) y)) h2 0 "2")
)
)
)
(defun c:zdt( / pts pt pti ptn ptc ang params)
(init)
(setq Scale (getstring "\n请输入比例尺<1:200>:"))
(if (&＃61; Scale "")
(progn
(setq blc "1:200")
(setq nScale 1)(setq h 0.45)
)
(progn
(setq nScale (/ (atof scale) 200))
(setq blc (strcat "1:" scale))
(setq h (* 0.60 (/ (atof scale) 200) ))
)
)
(setq ent (car (entsel "\n请选择图形...")))
(setq pts (getpl ent))
(if (cadr (setq pt (Order (reverse pts))))
(setq pts (reverse pts))
)
(setq pt (car pt))
(setq xc (* 0.0 nscale))
(command "_.pedit" ent "w" xc "")
(setcolor ent 1)
(OpPts pts pt h nscale)
(princ "\n\nEnd!")
(restore)
(princ)
)
京公网安备 11010802041100号