悬赏50币，求写梁线标注。

flytoday

兄弟有源码奉献不哈，。。
这种太强大了~~

明经中，绝无仅有的。建筑类自动标注~~

652758365

...............

hb198075

在公司里写的，明天要出差，过两天再把源码放上来。

vlisp2012

等待！！！！！！！！！！！

hb198075

源码已经交给楼主了，由楼主来决定是否放出来吧~

flytoday

贴出来是应该滴………楼主哪去了

xiaodao520

flytoday 发表于 2012-5-23 11:27
贴出来是应该滴………楼主哪去了

客兄，偶哪里有这么多时间泡论坛，源码马上贴出来。

xiaodao520

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                                ;;;
;;;                          梁尺寸标注程序，执行命令名： LBZ                        ;;;
;;;                                                                                ;;;
;;;                                                                                ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(setq lbz_offset 300.0) ;;;默认偏移距离

(defun c:lbz (/            ss          tmp        n     na    ent          e10        e11   pt
              llst  oldos 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)
).

xiaodao520

hb198075 发表于 2012-5-23 10:49
源码已经交给楼主了，由楼主来决定是否放出来吧~

在次感谢HB198075的帮忙，遗憾今天不能给加分。