兄弟有源码奉献不哈，。。
这种太强大了~~
明经中，绝无仅有的。建筑类自动标注~~
............... 在公司里写的，明天要出差，过两天再把源码放上来。 等待！！！！！！！！！！！ 源码已经交给楼主了，由楼主来决定是否放出来吧~ 贴出来是应该滴………楼主哪去了 本帖最后由 xiaodao520 于 2012-5-23 12:30 编辑
flytoday 发表于 2012-5-23 11:27 http://bbs.mjtd.com/static/image/common/back.gif
贴出来是应该滴………楼主哪去了
客兄，偶哪里有这么多时间泡论坛，源码马上贴出来。 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ;;;
;;; 梁尺寸标注程序，执行命令名： LBZ ;;;
;;; ;;;
;;; ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq lbz_offset 300.0) ;;;默认偏移距离
(defun c:lbz (/ ss tmp n na ent e10 e11 pt
llstoldos lst e40 e50 e0 ob len pt1
pt2 adlst lna lay ltype sslst e6 col e62 ang
)
;;;这是子函数部分;;;
;;;检查梁线是否已经进行了标注
(defun noInLst (lst ptlst / rel n itm)
(setq rel t
n 0
)
(if lst
(progn
(while (and rel
(setq itm (nth n lst))
)
(setq n (1+ n))
(if (and (equal (DISTANCE (car itm) (cadr itm))
(DISTANCE (car ptlst) (cadr ptlst))
1.0
)
(equal ptlst itm 310.0)
)
(setq rel nil)
)
)
)
)
rel
)
;;;选择集转换成列表
(defun hb_ssToLst (ss / na ent ena n rel)
(setq n 0)
(repeat (sslength ss)
(setq na (ssname ss n)
ent (entget na)
ena (cdr (assoc -1 ent))
)
(setq rel (cons ena rel)
n (1+ n)
)
)
(reverse rel)
)
;;;子函数部分结束
;;;主程序开始
(setvar "CMDECHO" 0)
(setq oldos (getvar "OSMODE"))
(setvar "OSMODE" 0)
(command "_.UNDO" "BE")
(if (setq lna (entsel "\n选择梁所在图层目标:<梁虚线>"))
(setq ent (entget (car lna))
lay (cdr (assoc 8 ent)) ;_指定图层
ltype(assoc 6 ent) ;_指定线型
col (assoc 62 ent) ;_指定颜色
)
(setq lay "梁虚线")
)
(princ (strcat "\n当前标注梁图层*** " lay " ***"))
(if ltype
(setq sslst (list (cons 0 "LINE,ARC") ltype (cons 8 lay)))
(setq sslst (list (cons 0 "LINE,ARC") (cons 8 lay)))
)
(if (setq ss (ssget sslst))
(progn
(if (setq tmp (getdist (strcat "\n请输入尺寸偏移距离:<"
(rtos lbz_offset 2)
">"
)
)
)
(setq lbz_offset tmp)
)
(setq lst (HB_SSTOLST ss)
lst (vl-sort lst
'(lambda (a b)
(< (car (cdr (assoc 10 (entget a))))
(car (cdr (assoc 10 (entget b))))
)
)
)
lst (vl-sort lst
'(lambda (a b)
(> (cadr (cdr (assoc 10 (entget a))))
(cadr (cdr (assoc 10 (entget b))))
)
)
)
) ;_将所选线条按从上到下，左到右的方向排序
(setq n 0)
(repeat (length lst)
(setq na(nth n lst)
ent (entget na)
e0(cdr (assoc 0 ent))
e6 (assoc 6 ent)
e62 (assoc 62 ent)
n (1+ n)
)
(cond
((and (= e0 "LINE")(equal ltype e6)(equal col e62)) ;_判断与源物体是否同颜色，同线型
(setq e10 (cdr (assoc 10 ent))
e11 (cdr (assoc 11 ent))
)
(setq adlst (vl-sort (list e10 e11)
'(lambda (a b) (< (car a) (car b)))
)
adlst (vl-sort adlst '(lambda (a b) (< (cadr a) (cadr b))))
)
(if (noInLst llst adlst)
(progn
(setq llst (cons adlst llst))
(if (< (abs (- (car e10) (car e11)))
(abs (- (cadr e10) (cadr e11)))
)
(setq pt(list (- (car e10) lbz_offset) (cadr e10))
e50 (/ pi 2)
)
(setq pt(list (car e10) (+ (cadr e10) lbz_offset))
e50 0.0
)
)
(if (or (= (car e10) (car e11))
(= (cadr e10) (cadr e11))
)
(entmake (list '(0 . "DIMENSION")
'(100 . "AcDbEntity")
'(100 . "AcDbDimension")
(cons 10 pt)
'(70 . 32)
'(1 . "")
(cons 3 (getvar "DIMSTYLE"))
'(100 . "AcDbAlignedDimension")
(cons 13 e10)
(cons 14 e11)
(cons 50 e50)
'(100 . "AcDbRotatedDimension")
)
) ;_绘制线性标注
(progn
(setq ang (+ (/ pi 2) (angle e10 e11))
ang (rem ang pi)
pt(polar e10 ang lbz_offset)
)
(entmake (list '(0 . "DIMENSION")
'(100 . "AcDbEntity")
'(100 . "AcDbDimension")
(cons 10 pt)
'(70 . 33)
'(1 . "")
(cons 3 (getvar "DIMSTYLE"))
'(100 . "AcDbAlignedDimension")
(cons 13 e10)
(cons 14 e11)
)
)
) ;_绘制对齐标注
)
)
)
)
((and (= e0 "ARC")(equal ltype e6)(equal col e62)) ;_判断与源物体是否同颜色，同线型
(setq e10 (cdr (assoc 10 ent))
e40 (cdr (assoc 40 ent))
pt1 (polar
e10
(/ (+ (cdr (assoc 50 ent)) (cdr (assoc 51 ent)))
2
)
(+ e40 LBZ_OFFSET)
)
)
(setq ob(vlax-ename->vla-object na)
len (vlax-curve-getDistAtParam
ob
(vlax-curve-getEndParam ob)
)
e10 (vlax-curve-getStartPoint ob)
e11 (vlax-curve-getEndPoint ob)
)
(command "_.DIMARC"
(list na e10)
pt1
) ;_绘制弧线标注
)
)
)
)
)
(setvar "OSMODE" oldos)
(command "_.UNDO" "E")
(setvar "CMDECHO" 1)
(princ)
). hb198075 发表于 2012-5-23 10:49 static/image/common/back.gif
源码已经交给楼主了，由楼主来决定是否放出来吧~
在次感谢HB198075的帮忙，遗憾今天不能给加分。
页:
1
[2]