愿意花100明经币求写代码

flytoday

没有人说要帮忙..怕久了没人写啊[em0]
哪位大师愿意帮忙滴说下啊谢谢

198526

你的测试图里，没把你要的效果表达出来。最好是表达一下。
疑问 1.A1 放在哪个位置  2.是要标注还是像你测试图里一样写文字，把长度用文字写在线上方。

flytoday

A1放线中………把长度用文字在线上方…这个用标注也行…就是标注样子要好看点…不然界面会乱

langjs

编了一点点，等有空再完善吧。
(defun c:aa (/ color ent h i ll la layer layers name pt pt0 pt0x pt0y pt1 pt1x pt1y pt2 pt2x pt2y r ss txt)
  (defun maketext (txt pt h r color la)
    (entmake (list '(0 . "TEXT") (cons 8 la) (cons 62 color) ; 颜色
     (cons 10 pt)        ; 坐标
     (cons 40 h)        ; 高度
     (cons 1 txt)        ; 内容
     (cons 50 r)        ; 旋转
     '(41 . 0.8) '(72 . 1) (cons 11 pt) ; 坐标
     '(73 . 0)
      )
    )
  )
  (setq h 230)          ; 字体高度
  (setq ll 47)          ; 距离直线
  (setq ss (ssget '((0 . "LINE"))))
  (repeat (setq i (sslength ss))
    (setq name (ssname ss (setq i (1- i))))
    (setq ent (entget name))
    (setq pt1 (cdr (assoc 10 ent)))
    (setq pt2 (cdr (assoc 11 ent)))
    (setq pt1x (car pt1))
    (setq pt1y (cadr pt1))
    (setq pt2x (car pt2))
    (setq pt2y (cadr pt2))
    (setq pt0x (/ (+ pt1x pt2x) 2))
    (setq pt0y (/ (+ pt1y pt2y) 2))
    (setq pt0 (list pt0x pt0y))
    (setq la (cdr (assoc 8 ent)))
    (setq color (vla-get-color (vlax-ename->vla-object name)))
    (setq txt (rtos (distance pt1 pt2)))
    (setq r (angle pt1 pt2))
    (setq pt (polar pt0 (+ r (/ pi 2)) ll))
    (maketext txt pt h r color la)
  )
  (princ)
)

flytoday

先顶一下哈哈

flytoday

198526 兄弟及langjs 兄弟了。。。。
198526 兄弟的代码
如果能设置几个条件就非常完美了
第1个就是默认条件重线只标注长的一条，等长重线只标注一条
第2个就是标注可以进行字高设置
第3个提供个条件两条平行线距离351mm以内，一种选择是标注一边，一种是两边都标注
第4个支持第二次提取EXL输出。。。如标注完增加。。
我在标注处修改增加的字如3000（B1），90。。。。增加以后通过命令一次性提取下。。。

198526

langjs 发表于 2012-4-26 10:24
编了一点点，等有空再完善吧。
(defun c:aa (/ color ent h i ll la layer layers name pt pt0 pt0x pt0y  ...

评分里我居然只能+1个币，我本来是想给您加80个的。我的100个来得太简单了。

198526

flytoday 发表于 2012-4-26 17:14
198526 兄弟及langjs 兄弟了。。。。
198526 兄弟的代码
如果能设置几个条件就非常完美了

1.你可以直接用一个删除重线命令把图清理一下再使用此程序。
2.(setq h 230)你把这个改成(setq h (GETREAL “\n请输入字高”))当然可以再加一个默认值
3.不是很理解，你的意思是线太长了写一个标注在那有时看得不是很方便，想要增加一个可以标两边的选项？如果是这样也不是很麻烦。
4.这个我就无能为力了。

langjs

flytoday 发表于 2012-4-26 17:14
198526 兄弟及langjs 兄弟了。。。。
198526 兄弟的代码
如果能设置几个条件就非常完美了

1.用删除重复线的程序解决。
2.这个好弄
3and4，编起来太复杂
修改一下198526的代码，把多义线加上了，程序稍许完整一点。
(defun c:aa (/ a b chra color db dm dmm ent file_id file_idx h h1 i j la ll n name pt pt0 pt0x pt0y pt1 pt1x pt1y pt2 pt2x pt2y pt3
               ptslist r ss txt vtxlst x )
  (defun dimtext (pt1 pt2)
    (setq pt1x (car pt1)  pt1y (cadr pt1)  pt2x (car pt2)  pt2y (cadr pt2)  pt0x (/ (+ pt1x pt2x) 2)
          pt0y (/ (+ pt1y pt2y) 2)  pt0 (list pt0x pt0y) )
    (setq txt (rtos (distance pt1 pt2))          r (angle pt1 pt2)  pt (polar pt0 (+ r (/ pi 2)) ll)  b (assoc color a)
          db (list (caadr b) (cons txt (cadadr b)))  dm (strcat (car db) (itoa (length (cadr db)))))
    (setq a (subst  (list color db)  b  a ) )
    (maketext (strcat txt "(" dm ")") pt h r color la)
  )
  (defun maketext (txt pt h r color la)
    (entmake (list '(0 . "TEXT") (cons 8 la) (cons 62 color) (cons 10 pt) (cons 40 h) (cons 1 txt) (cons 50 r) '(41 . 0.8) '
                   (72 . 1) (cons 11 pt) '(73 . 0) ) )
  )
  (setvar "cmdecho" 0)
  (vl-load-com)
  (if (setq h1 (getint "\n输入字高:<100>")) (setq h h1) (setq h 100) )
  (setq ll (/ h 2) chra 65 a '())
  (setq ss (ssget '((0 . "LINE,LWPOLYLINE,POLYLINE"))))
  (repeat (setq i (sslength ss))
    (setq name (ssname ss (setq i (1- i)))  ent (entget name)  la (cdr (assoc 8 ent)))
    (if (not (assoc 62 ent))
      (setq color (cdr (assoc 62 (tblsearch "LAYER" (cdr (assoc 8 ent))))))
      (setq color (cdr (assoc 62 ent)))
    )
    (if (not (assoc color a)) (setq a (cons (list color (list (chr (+ chra (length a))) nil)) a)) )
    (if (= "LINE" (cdr (assoc 0 ent)))
      (progn(setq pt1 (cdr (assoc 10 ent)) pt2 (cdr (assoc 11 ent)))(dimtext pt1 pt2))
      (progn
        (if (= "LWPOLYLINE" (cdr (assoc 0 ent))) (setq n 2) (setq n 3))
        (setq vtxlst (vlax-safearray->list (vlax-variant-value (vlax-get-property (vlax-ename->vla-object name) 'coordinates))))
        (setq j 0   ptslist nil        )
        (repeat (/ (length vtxlst) n)
          (setq ptslist (append          ptslist
                          (list (list (nth j vtxlst) (nth (1+ j) vtxlst) (if (= n 3) (nth (+ 2 j) vtxlst)  0.0 )) )
                        ))
          (setq j (+ j n))
        )
        (setq pt1 nil  pt2 nil)
        (foreach x ptslist
          (if (null pt1)(setq pt1 x pt3 x ) (setq pt2 x))
          (if pt2 (progn (dimtext pt1 pt2) (setq pt1 pt2)))
        )
        (if (= 1 (cdr (assoc 70 ent)))(dimtext pt2 pt3))
      )
    )
  )
  (setq file_idx (getfiled "指定输出文件路径" "" "xls" 1)
        file_id (open file_idx "w")
  )
  (write-line "颜色号码\t对应代码\t长度" file_id)
  (foreach b (reverse a)
    (setq dmm (strcat (itoa (car b)) "\t" (caadr b)) n 0 )
    (foreach x (reverse (cadadr b))
      (write-line (strcat dmm (itoa (setq n (1+ n))) "\t" x) file_id)
    )
  )                                     
  (close file_id)
  (princ)
)

flytoday

198526 发表于 2012-4-26 17:43
1.你可以直接用一个删除重线命令把图清理一下再使用此程序。
2.(setq h 230)你把这个改成(setq h (GETRE ...

不知道为什么有时重线消除不干净。。侧试图中我试了下有些重线无法消除。。
那个两边标注我想将程序用到其它地方。都是两根平行线我只想。。标注一根所以。才想有个设置该多好哈

不过还是谢谢你哈