Gu_xl 老大编滴哪位老大能改改进来瞧下啊~谢谢
本帖最后由 flytoday 于 2011-12-14 14:49 编辑Gu_xl 老大这段代码能不能修改成。。
那个A BC线是由CAD画好了，
然后您这个程序由命令可以直接附属ABC线属性呢。
然后当然也能显示板厚板编号属性啊。
功能就是这个变了。。。。
http://bbs.mjtd.com/thread-91136-1-1.html原贴 本帖最后由 Gu_xl 于 2011-12-14 18:04 编辑
;;;构造匿名块
(defun MakeUnNameBlock (ss pt h a b c bh thickness / count entlist ent blk)
(setq pt (trans pt 1 0))
(entmake (list '(0 . "BLOCK")
'(2 . "*U")
'(70 . 3)
(cons 10 pt)
)
)
(setq count 0)
(repeat (sslength ss)
(setq entlist (entget (setq ent (ssname ss count))))
(setq count (1+ count))
(entmake entlist)
)
(setq count 0)
(repeat (sslength ss)
(setq ent (ssname ss count))
(setq count (1+ count))
(entdel ent)
)
(setq blk (entmake '((0 . "ENDBLK"))))
(regapp "flytoday")
(if blk
(progn
(entmake (list (cons 0 "INSERT")
'(100 . "AcDbEntity")
'(100 . "AcDbBlockReference")
'(66 . 1) ;_ 属性跟随标志,1跟随，0不跟随
(cons 2 blk)
(cons 10 pt)
(cons 41 1.0)
(cons 42 1.0)
(cons 43 1.0)
'(-3 ("flytoday" (1000 . "flytoday")))
)
)
;;;插入板编号属性
(entmake (list
'(0 . "ATTRIB")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 10 pt)
(cons 40 h)
(cons 50 0)
(cons 41 0.8)
(cons 51 0)
(cons 1 bh)
(cons 7 "Standard")
(cons 72 0)
(cons 11 pt)
'(100 . "AcDbAttribute")
(cons 2 "板编号")
(cons 70 0)
(cons 74 2)
)
)
;;;插入厚度属性
(entmake (list
'(0 . "ATTRIB")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 10 (polar pt (* -0.5 pi) (* 1.5 h)))
(cons 40 h)
(cons 50 0)
(cons 41 0.8)
(cons 51 0)
(cons 1 thickness)
(cons 7 "standard")
(cons 72 0)
(cons 11 (polar pt (* -0.5 pi) (* 1.5 h)))
'(100 . "AcDbAttribute")
(cons 2 "厚度")
(cons 70 0)
(cons 74 2)
)
)
;;;插入a线长度属性
(entmake (list
'(0 . "ATTRIB")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 10 (polar pt (* -0.5 pi) (* 3 h)))
(cons 40 h)
(cons 50 0)
(cons 41 0.8)
(cons 51 0)
(cons 1 a)
(cons 7 "standard")
(cons 72 0)
(cons 11 (polar pt (* -0.5 pi) (* 3 h)))
'(100 . "AcDbAttribute")
(cons 2 "a线长度")
(cons 70 1)
(cons 74 2)
)
)
;;;插入b线长度属性
(entmake (list
'(0 . "ATTRIB")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 10 (polar pt (* -0.5 pi) (* 4.5 h)))
(cons 40 h)
(cons 50 0)
(cons 41 0.8)
(cons 51 0)
(cons 1 b)
(cons 7 "standard")
(cons 72 0)
(cons 11 (polar pt (* -0.5 pi) (* 4.5 h)))
'(100 . "AcDbAttribute")
(cons 2 "b线长度")
(cons 70 1)
(cons 74 2)
)
)
(if c
;;;插入c线长度属性
(entmake (list
'(0 . "ATTRIB")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 10 (polar pt (* -0.5 pi) (* 6 h)))
(cons 40 h)
(cons 50 0)
(cons 41 0.8)
(cons 51 0)
(cons 1 c)
(cons 7 "standard")
(cons 72 0)
(cons 11 (polar pt (* -0.5 pi) (* 6 h)))
'(100 . "AcDbAttribute")
(cons 2 "c线长度")
(cons 70 1)
(cons 74 2)
)
)
)
;;;结束标志
(entmake '((0 . "SEQEND")))
)
)
blk
)
;;;构造线
(defun makeline (p1 p2)
(entmake (list (cons 0 "line")
(cons 10 (trans p1 1 0))
(cons 11 (trans p2 1 0))
)
)
)
;;;MakeText 生成文字函数,参数： 标注点 文字 字高 宽比 旋转角 倾角
(defun MakeText (xy Txt ZG KB XZ Qj / xyL TxtL ZGL KBL XZL QJL)
(setq xy (trans xy 1 0));;;坐标换算为世界坐标
(setq xyL(cons 10 xy)
TxtL (cons 1 Txt)
ZGL(cons 40 ZG)
KBL(cons 41 KB)
XZL(cons 50 XZ)
QJL(cons 51 QJ)
)
(setq TextL (list '(0 . "TEXT")
'(67 . 0)
'(100
.
"AcDbText"
)
xyL
ZGL
TxtL
XZL
KBL
QJL
'(7 . "standard")
)
)
(entmake TextL)
)
;;;计算两点的中点
(defun MidPoint (p1 p2)
(if (and (> (length p1) 2)(> (length p2) 2))
(list (* 0.5 (+ (car p1) (car p2))) (* 0.5 (+ (cadr p1) (cadr p2))) (* 0.5 (+ (caddr p1) (caddr p2))))
(list (* 0.5 (+ (car p1) (car p2))) (* 0.5 (+ (cadr p1) (cadr p2))))
)
)
;;;(Selectif 条件函数 选择动作 提示字串) 条件选择
;;;(Selectif (lambda (x) (= "TEXT" (gxl-dxf x 0))) entsel "\n选择 TEXT: ")
(defun Selectif ( foo fun str / e )
(while
(progn (setvar 'ERRNO 0) (setq e (car (fun str)))
(cond
( (= 7 (getvar 'ERRNO))
(princ "\n** 未选中实体, 重新选取 **")
)
( (eq 'ENAME (type e))
(if (and foo (not (foo e)))
(princ "\n** 选择实体无效 **")
)
)
)
)
)
e
)
;;;划线程序
(defun c:tt (/ OLDERROSMODECMDECHO ORTHOMODE
SS A B C P1 P2 P3
P4 P0 KD FLAG *error* en enl
)
(defun *error* (msg)
(setq *error* olderr)
(Setvar "osmode" osmode)
(Setvar "cmdecho" cmdecho)
(Setvar "orthomode" orthomode)
(princ msg)
)
(setq olderr *error*)
(setq osmode (getvar "osmode"))
(Setvar "osmode" 687)
(setq cmdecho (getvar "cmdecho"))
(Setvar "cmdecho" 0)
(setq orthomode (getvar "orthomode"))
(Setvar "orthomode" 1)
(or txtHeight
(setq txtHeight (getreal "\n输入字高<400>:"))
)
(if (null txtHeight)
(setq txtHeight 400)
)
(while (not flag)
(setq ss (ssadd)
anil
bnil
cnil
)
(setq en (Selectif (lambda (x) (= "LINE" (cdr (assoc 0 (setq enl (entget x)))))) entsel "\n 选择a线: "))
(redraw en 3)
(ssadd en ss)
(setq p1 (trans (cdr (assoc 10 enl)) 0 1)
p2 (trans (cdr (assoc 11 enl)) 0 1)
a (rtos (distance p1 p2) 2 3)
)
(MakeText (midpoint p1 (MidPoint p1 p2)) "a" txtHeight 0.8 0 0)
(ssadd (entlast) ss)
;|
(princ "\n绘a线:")
(initget 7)
(setq p1 (getpoint "\n直线第一点:"))
(initget 7)
(setq p2 (getpoint p1 "\n直线第二点:"))
(makeline p1 p2)
(setq a (rtos (distance p1 p2) 2 3))
(ssadd (entlast) ss)
(MakeText (midpoint p1 (MidPoint p1 p2)) "a" txtHeight 0.8 0 0)
(ssadd (entlast) ss)
|;
(setq en (Selectif (lambda (x) (= "LINE" (cdr (assoc 0 (setq enl (entget x)))))) entsel "\n 选择b线: "))
(redraw en 3)
(ssadd en ss)
(setq p3 (trans (cdr (assoc 10 enl)) 0 1)
p4 (trans (cdr (assoc 11 enl)) 0 1)
b (rtos (distance p3 p4) 2 3)
)
(MakeText (polar (midpoint p3 (MidPoint p3 p4)) 0 (* 0.2 txtHeight)) "b" txtHeight 0.8 0 0)
(ssadd (entlast) ss)
;|
(princ "\n绘b线:")
(initget 7)
(setq p3 (getpoint "\n直线第一点:"))
(initget 7)
(setq p4 (getpoint p3 "\n直线第二点:"))
(makeline p3 p4)
(setq b (rtos (distance p3 p4) 2 3))
(ssadd (entlast) ss)
(MakeText (midpoint p3 (MidPoint p3 p4)) "b" txtHeight 0.8 0 0)
(ssadd (entlast) ss)
|;
;(setq p0 (inters p1 p2 p3 p4 nil))
(setq p0 (midpoint
(apply 'mapcar (cons 'min (list p1 p2 p3 p4)))
(apply 'mapcar (cons 'max (list p1 p2 p3 p4)))
)
)
(progn
(setq flag nil)
(while (and (not Flag) (setq en (car(entsel "\n 选c线: "))))
(setq Flag (= "LINE" (cdr (assoc 0 (setq enl (entget en))))))
)
(if en
(progn
(redraw en 3)
(ssadd en ss)
(setq p1 (trans (cdr (assoc 10 enl)) 0 1)
p2 (trans (cdr (assoc 11 enl)) 0 1)
c (rtos (distance p1 p2) 2 3)
)
(MakeText (midpoint p1 (MidPoint p1 p2)) "c" txtHeight 0.8 0 0)
(ssadd (entlast) ss)
)
)
;|
(princ "\n绘c线:")
(if (and
(setq p1 (getpoint "\n直线第一点:"))
(setq p2 (getpoint p1 "\n直线第二点:"))
)
(progn
(makeline p1 p2)
(ssadd (entlast) ss)
(setq c (rtos (distance p1 p2) 2 3))
(MakeText (midpoint p1 (MidPoint p1 p2)) "c" txtHeight 0.8 0 0)
(ssadd (entlast) ss)
)
)
|;
(setq bh (getstring "\n板编号:"))
(setq thickness (getreal"\n厚度:"))
(if (null thickness) (setq thickness "") (setq thickness (rtos thickness 2 0)))
(MakeUnNameBlock ss p0 txtHeight a b c bh thickness)
(initget 7 "Yes No")
(setq Kd (getkword "\n[继续Yes/No]<Yes>"))
(setq Flag (= kd "No"))
)
)
(setq *error* olderr)
(Setvar "osmode" osmode)
(Setvar "cmdecho" cmdecho)
(Setvar "orthomode" orthomode)
(princ)
)
;;;双击图块，通过属性输入板编号和厚度值
;;;导出数据(c:tt1)
(defun c:tt1(/ SS F N EN LL ENL BBH THICKNESS A B C filename data)
(setq ss (ssget (list '(0 . "insert") '(-3 ("flytoday")))))
(if ss
(progn
(setq filename (getfiled "保存文件名" "data" "csv" 1))
(if filename
(progn
(if (findfile filename)
(setq f (open filename "a")) ;_ 文件已存在，自动追加
(progn
(setq f (open filename "w")) ;_ 文件不存在，新建文件
(write-line ",a,b,c,板厚" f)
)
)
(repeat (setq n (sslength ss))
(setq en (ssname ss (setq n (1- n))))
(setq ll nil)
(while
(and (setq en (entnext en))
(= "ATTRIB"
(cdr (assoc 0 (setq enl (entget en)))))
)
(setq ll (cons (cdr (assoc 1 enl)) ll))
)
(if ll
(progn
(setq data (cons (reverse ll) data))
)
)
)
(setq data
(vl-sort data
'(lambda (a b)
(< (atof (cadr a)) (atof (cadr b))))))
(foreach lldata
(setq bbh (car ll)
thickness (cadr ll)
a (caddr ll)
b (cadddr ll)
c (car (cddddr ll))
)
(WRITE-LINE
(strcat bbh
","
a
","
b
","
(if c
c
""
)
","
thickness
)
f
)
)
(close f)
;(startapp "notepad.exe" filename)
)
)
)
)
(princ)
)
Gu_xl 老大谢谢但是a bc 图中没显示啊。。其它都完美了 上个您修改的是板编号与板最不显示。。这次这两个显示了。abc不显示了 本帖最后由 flytoday 于 2011-12-14 16:10 编辑
还有板厚那个只要精确到mm就好哈
;;;插入a线长度属性 (cons 70 1)改成0会显示a 线的长度值，这功能保留（以后我有用哈）。。
要求显示上图那个样子的
偶太笨了没表达清楚吧跟字高没关系，，。其它都那么大字了，就是线上要写上AB字样而已 问题似乎已经找到。。。
gu_xl版主的程序(defun MakeText (xy Txt ZG KB XZ Qj / xyL TxtL ZGL KBL XZL QJL)
(setq xy (trans xy 1 0));;;坐标换算为世界坐标
....屏蔽坐标转换似乎没有问题了 xiaxiang Gu_xl 两位老大尽心了搞定了谢谢 谢谢不愧明经大佬 人好技术强
页:
[1]
2