各位高手求助看下这个程序如何修改！！！（如何让标注的界址点号从西北角开始顺时...
本帖最后由 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 'append (mapcar '(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 '((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 '((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 '((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 '((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 '((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 '((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 '(lambda(e1 e2) (< (abs (- (angle pt e1) (/ pi 4))) (abs (- (angle pt e2) (/ pi 4)))))))
(setq i 1)
(mapcar '(lambda(e)
(MakeText3 (polar e (angle pt e) h) h 0.0 (itoa i))
(setq i (1+ i))
) pts)
(mapcar '(lambda(e)
(MakeText2 (polar (cadr e) (+ (/ 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 (/= (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 '+ (mapcar 'car pts)) n)
(/ (apply '+ (mapcar '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))))
((< angi (- pi)) (setq angi (+ angi (* pi 2))))
)
(setq angAll (+ angAll angi))
(setq ang angn)
)
(cond
((equal angAll 0 1) (list pt nil))
((> angAll 0) (list pt nil))
((< angAll 0) (list pt t))
)
)
(defun DoubleM(ent / ents pt pts l h x y h2)
(setq ents (entget ent))
(if (= (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 (+ l (* h 0.4)))
(setq y (* h 0.7))
(setq h2 (* h 0.5))
(MakeText (list (+ (car pt) x) (+ (cadr pt) y)) h2 0 "2")
)
)
)
(defun c:zdt( / pts pt pti ptn ptc ang params)
(init)
(setq Scale (getstring "\n请输入比例尺<1:200>:"))
(if (= 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)
)
(defun c:zdt (/ pts wnp dil dis)
(setq pts
(mapcar 'cdr
(vl-remove-if
(function (lambda (x) (/= (car x) 10)))
(entget (car (entsel)))
)
)
)
(or
(< (apply
'+
(mapcar
(function
(lambda (pt1 pt2)
(- (* (car pt1) (cadr pt2)) (* (cadr pt1) (car pt2)))
)
)
(cons (last pts) pts)
pts
)
)
0
)
(setq pts (reverse pts))
)
(setq wnp (list (apply 'min (mapcar 'car pts)) (apply 'max (mapcar 'cadr pts))))
(setq diL (mapcar (function (lambda (pt) (distance pt wnp))) pts))
(setq dis (vl-position (apply 'min diL) diL))
(or (= dis 0)
(repeat dis
(setq pts (append (cdr pts) (list (car pts))))
)
)
(setq dis 0)
(setq dil (append pts (list (car pts))))
(foreach pt pts
(entmakex
(list
'(0 . "TEXT")
'(100 . "AcDbEntity")
'(67 . 0)
'(8 . "0")
'(410 . "Model")
'(100 . "AcDbText")
'(10 0.0 0.0 0.0)
(cons 11 (polar pt (+ (angle pt (cadr dil)) (* pi 0.5)) 8))
(cons 40 5.0)
(cons 1 (strcat "J" (itoa (setq dis (1+ dis)))))
'(41 . 0.8)
'(51 . 0.0)
'(71 . 0)
'(72 . 1)
'(210 0.0 0.0 1.0)
'(100 . "AcDbText")
'(73 . 2)
)
)
(setq dil (cdr dil))
)
(princ)
) 谢谢！！！ 谢谢！！！！ 谢谢！！！！ 本帖最后由 lhngxy 于 2018-4-4 08:09 编辑
高手感谢您的帮助，谢谢 看着很不错的样子啊，学习学习。。。 lhngxy 发表于 2018-4-3 22:26
高手感谢您的帮助，谢谢
会有字体编号重复
7#
应该是你的闭合线有重复节点把？
看着很不错的样子啊，学习学习。。。
页:
[1]