坐标编号导出..原来用得好好的现在不能用了求修改...源码
本帖最后由 flytoday 于 2015-8-8 13:23 编辑求大师给解决下..谢谢~ 本帖最后由 flytoday 于 2015-8-8 12:45 编辑
附件传上来了....
;;; 标注好的坐标输出到: 与DWG文件同目录、同名的TXT文件中20121121；
;;; 输出样式：
;;; X值 Y值
;;; 1, 87753.815, 52860.248
;;; 2, 2887765.655, 452850.981
;;; .
;;; .
;;; .
;;;
;;; 将编号1、2、... 写到图中.
;;;
(defun c:ZBZDC ( / ss n info ent txt pt t_h t_a tmp tmp1 tmp2 pt10 pt11 f_n f_op)
(setq ss (ssget '((0 . "TEXT") (1 . "X=*,x=*"))))
(setq n 0)
(setq info '())
(repeat (if ss (sslength ss) 0)
(setq ent (entget (ssname ss n))
txt (cdr (assoc 1 ent))
pt(cdr (assoc 10 ent))
t_h (cdr (assoc 40 ent))
t_a (cdr (assoc 50 ent))
)
(setq info (append info (list (list pt txt t_h t_a))))
(setq n (1+ n))
)
(command "_.undo" "_be")
(setq c_t '())
(setq info (mapcar '(lambda(x)
(progn (setq tmp (car x))
(setq tmp1 (mapcar '(lambda(y) (- y (caddr x))) tmp)
tmp2 (mapcar '(lambda(y) (+ y (caddr x))) tmp))
(setq ss_tmp (ssget "c" tmp1 tmp2 '((0 . "LINE"))))
(setq tmp (entget (ssname ss_tmp 0)))
(setq pt10 (cdr (assoc 10 tmp)))
(setq pt11 (cdr (assoc 11 tmp)))
(if (or (equal (angle pt10 pt11) (cadddr x) 1e-3)
(equal (angle pt11 pt10) (cadddr x) 1e-3))
(cond
((= (sslength (ssget "c" pt10 pt10 '((0 . "LINE")))) 1)
(setq c_t (append c_t
(list (list (polar pt10 (angle pt11 pt10)
(* (caddr x) 1.1))
(caddr x) (cadddr x))))))
((= (sslength (ssget "c" pt11 pt11 '((0 . "LINE")))) 1)
(setq c_t (append c_t
(list (list (polar pt11 (angle pt10 pt11)
(* (caddr x) 1.1))
(caddr x) (cadddr x))))))
)
(cond
((progn (setq tmp (entget (ssname ss_tmp 1))
pt10 (cdr (assoc 10 tmp))
pt11 (cdr (assoc 11 tmp)))
nil))
((= (sslength (ssget "c" pt10 pt10 '((0 . "LINE")))) 1)
(setq c_t (append c_t
(list (list (polar pt10 (angle pt11 pt10)
(* (caddr x) 1.1))
(caddr x) (cadddr x))))))
((= (sslength (ssget "c" pt11 pt11 '((0 . "LINE")))) 1)
(setq c_t (append c_t
(list (list (polar pt11 (angle pt10 pt11)
(* (caddr x) 1.1))
(caddr x) (cadddr x))))))
))
(and
(setq ss_tmp (ssget "c" tmp1 tmp2 '((0 . "TEXT") (1 . "Y=*,y=*"))))
(setq tmp (cdr (assoc 1 (entget (ssname ss_tmp 0)))))
(setq x (list (car x) (cadr x) tmp))
)
x)) info))
(setq info (mapcar 'append info c_t))
(setq info (vl-sort info '(lambda (x y) (< (caarx) (caary))))) ;X坐标从小到大排序.
(setq info (vl-sort info '(lambda (x y) (< (cadar x) (cadar y))))) ;Y坐标从小到大排序.
(setq c_t(mapcar 'cdddr info))
(setq f_n(getvar "DWGname")
f_n(strcat (substr f_n 1 (- (strlen f_n) 4)) ".txt")
f_n(strcat (getvar "DWGPREFIX") f_n)
)
(setq n 0)
(setq f_op (open f_n "w"))
(princ " X 值 Y 值\n" f_op)
(mapcar '(lambda(x y)
(princ (strcat (itoa (setq n (1+ n))) ", ") f_op)
(princ (substr (cadrx) 3) f_op)
(princ ", " f_op)
(princ (substr (caddr x) 3) f_op)
(princ "\n" f_op)
(command "._CIRCLE" "_non" (car y) (* (cadr y) 1.1))
(command "._TEXT" "_j" "_mc" "_non" (car y) (cadr y) (* (/ (caddr y) pi) 180) (itoa n))
) info c_t)
(close f_op)
(command "_.undo" "_end")
(princ)
)
;|
(defun c:tt ()
(setvar "CMDECHO" 0)
(if (setq ss (ssget '((0 . "TEXT") (1 . "X=*,Y=*")))) (progn
(setq i 0 dll (list))
(repeat (sslength ss)
(setq ent (entget(ssname ss i))
i (1+ i)
dll (cons (cons (cdr(assoc 10 ent)) (cdr(assoc 1 ent))) dll))
)
(setq dll (reverse dll))
(setq sdll (vl-sort dll '(lambda (x y) (< (caar x) (caar y)))))
(setq sdll (vl-sort sdll '(lambda (x y) (< (cadar x) (cadar y)))))
(setq fn (if fn fn ""))
(if (setq fn (getfiled "输出文件名" fn "txt" 1)) (progn
(setq fp (open fn "w"))
(setq ppt T)
(princ "X值 Y值" fp)
(foreach x sdll
(if ppt
(princ (strcat "\n" (substr (cdr x) 3)) fp)
(princ (strcat "" (substr (cdr x) 3)) fp)
)
(setq ppt (not ppt))
)
(close fp)
(startapp "notepad" fn)
))
))
(princ)
)
|;
看看是不是你想要的，希望对你有帮助，这个我也是下载的。
页:
[1]