多义线边长标注

香田里浪人

有人编过多义线边长标注，程序如下，标注单个多义线是没问题，可惜不能批量标注，如何修改，使之能够批量标注多义线。

;;;;多义线边长标注
(defun c:bcbz (/ obj pianju sHandle  pt np gx bj np xc  rr  cp n ang1 zjp ms AddText)
;;;构造text
(command "layer" "M" "边长标注" "C" "3" "" "LT" "CONTINUOUS" "" "");设置一个标注图层
(command "style" "tukou" "宋体" "0" "" "0" "" "")
  (defun AddText (obj TextString  InsertionPoint  Height xz kb qx Alignment style / obj1 err)
  (setq obj1 (vla-addtext obj TextString  (vlax-3d-point InsertionPoint)  Height))
  (vla-put-Rotation obj1 xz)
  (vla-put-ScaleFactor obj1 kb)
  (vla-put-ObliqueAngle obj1 qx)
  (vla-put-alignment obj1 Alignment)
  (if (/= Alignment acAlignmentLeft)
    (vla-put-TextAlignmentPoint obj1 (vlax-3d-point InsertionPoint))
    (vla-put-InsertionPoint obj1 (vlax-3d-point InsertionPoint))
   )
   (VL-CATCH-ALL-APPLY 'vla-put-StyleName (list obj1 style))
  obj1
  )
(setq pi2 (/ pi 2))
  (setq ms (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object))))
(setq  bcHeight (getdist "\n输入标注文字高度:");文字高度
        kgb         0.8 ; 宽高比
       Style         "BG_ST" ; 字体
        ZJWS         2 ;_ 注记位数
       DimScale 1 ; 边长尺度，若单位为mm,该值为1000
        flag         nil ;标注在多段线走向的右侧,T 左侧
) ;_ setq
(while  (setq pen (car (entsel "\n选择多段线：")))
  (setq pianju (* bcHeight 0.7)) ;边长离线距离
  (setq obj (vlax-ename->vla-object pen)
        n 0)
  (while (and (setq pt (vlax-curve-getPointAtParam obj n))
              (setq np (vlax-curve-getPointAtParam obj (1+ n)))
         ) ;_ 结束and
    (if        (/= 0.0 (setq bugle (vla-GetBulge obj n)))
      (progn
        (setq midpt (vlax-curve-getPointAtParam obj (+ 0.5 n))
             bj (* (atan (abs bugle)) 4)
            xc (* 0.5 (distance Pt np))
            gg (abs (* bugle xc))
            rr (/ (+ (* xc xc) (* gg gg)) (* 2 gg))
            ang1 (angle pt np)
            cp (polar Pt ang1 xc)
            cp (polar midpt (angle midpt cp) rr)
            bc (rtos (/ (- (vlax-curve-getDistAtParam obj (1+ n)) (vlax-curve-getDistAtParam obj n)) DimScale) 2 ZJWS)
              )
       (if flag
            (setq zjp (polar midpt (cond ((> bugle 0)(angle midpt cp))(t (angle  cp midpt))) pianju))
            (setq zjp  (polar midpt (cond ((> bugle 0)(angle  cp midpt))(t (angle midpt cp))) pianju))
     )
        (if (not (or (and (>= ang1 0) (< ang1 (* 0.666666 pi))) (and (> ang1 (* 1.666666 pi)) (< ang1 (* 2.0 pi)))))
         (setq ang1 (- ang1 pi))
          )
        (AddText ms bc  zjp  bcHeight ang1 kgb 0 acAlignmentMiddle Style)
     );progn
      (progn
        (setq midpt (vlax-curve-getPointAtParam obj (+ 0.5 n))
              ang1 (angle pt np)
              bc (rtos (/ (- (vlax-curve-getDistAtParam obj (1+ n)) (vlax-curve-getDistAtParam obj n)) DimScale)  2 ZJWS)
              )
        (if flag
            (setq zjp (polar midpt (+ pi2 ang1) pianju))
          (setq zjp (polar midpt (- ang1 pi2) pianju))
               )
        (if (not (or (and (>= ang1 0) (< ang1 (* 0.666666 pi))) (and (> ang1 (* 1.666666 pi)) (<= ang1 (* 2.0 pi)))))
          (setq ang1 (- ang1 pi))
          )
        (AddText ms bc  zjp  bcHeight ang1 kgb 0 acAlignmentMiddle Style)
      );progn
    ) ;结束if
    (setq n (1+ n))
  ) ; 结束while
)
  (princ)
  )

zyhandw

也看过一些楼主发的帖子，我想这应该不能难倒楼主啊，如下是帮你改了以后的程序，试试看看是否是你想要的结果。

2. ;;;多义线边长标注
   
3. (defun c:bcbz (/ obj pianju sHandle  pt np gx bj np xc  rr  cp n ang1 zjp ms AddText pen-n pen-all)
   
4. ;;;构造text
   
5. (command "layer" "M" "边长标注" "C" "3" "" "LT" "CONTINUOUS" "" "");设置一个标注图层
   
6. (command "style" "tukou" "宋体" "0" "" "0" "" "")
   
7.   (defun AddText (obj TextString  InsertionPoint  Height xz kb qx Alignment style / obj1 err)
   
8.   (setq obj1 (vla-addtext obj TextString  (vlax-3d-point InsertionPoint)  Height))
   
9.   (vla-put-Rotation obj1 xz)
   
10.   (vla-put-ScaleFactor obj1 kb)
    
11.   (vla-put-ObliqueAngle obj1 qx)
    
12.   (vla-put-alignment obj1 Alignment)
    
13.   (if (/= Alignment acAlignmentLeft)
    
14.     (vla-put-TextAlignmentPoint obj1 (vlax-3d-point InsertionPoint))
    
15.     (vla-put-InsertionPoint obj1 (vlax-3d-point InsertionPoint))
    
16.    )
    
17.    (VL-CATCH-ALL-APPLY 'vla-put-StyleName (list obj1 style))
    
18.   obj1
    
19.   )
    
20. (setq pi2 (/ pi 2))
    
21.   (setq ms (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object))))
    
22. (setq  bcHeight (getdist "\n输入标注文字高度:");文字高度
    
23.         kgb         0.8 ; 宽高比
    
24.        Style         "BG_ST" ; 字体
    
25.         ZJWS         2 ;_ 注记位数
    
26.        DimScale 1 ; 边长尺度，若单位为mm,该值为1000
    
27.         flag         nil ;标注在多段线走向的右侧,T 左侧
    
28. ) ;_ setq
    
29. (setq pen-n 0)
    
30. (if (setq pen-all (ssget '((0 . "*polyline"))))
    
31.     (repeat (sslength pen-all)
    
32.             (setq pianju (* bcHeight 0.7)) ;边长离线距离
    
33.             (setq pen-en (ssname pen-all pen-n))
    
34.             (setq obj (vlax-ename->vla-object pen-en)
    
35.                   n 0)
    
36.               (while (and (setq pt (vlax-curve-getPointAtParam obj n))
    
37.               (setq np (vlax-curve-getPointAtParam obj (1+ n)))
    
38.          ) ;_ 结束and
    
39.     (if        (/= 0.0 (setq bugle (vla-GetBulge obj n)))
    
40.       (progn
    
41.         (setq midpt (vlax-curve-getPointAtParam obj (+ 0.5 n))
    
42.              bj (* (atan (abs bugle)) 4)
    
43.             xc (* 0.5 (distance Pt np))
    
44.             gg (abs (* bugle xc))
    
45.             rr (/ (+ (* xc xc) (* gg gg)) (* 2 gg))
    
46.             ang1 (angle pt np)
    
47.             cp (polar Pt ang1 xc)
    
48.             cp (polar midpt (angle midpt cp) rr)
    
49.             bc (rtos (/ (- (vlax-curve-getDistAtParam obj (1+ n)) (vlax-curve-getDistAtParam obj n)) DimScale) 2 ZJWS)
    
50.               )
    
51.        (if flag
    
52.             (setq zjp (polar midpt (cond ((> bugle 0)(angle midpt cp))(t (angle  cp midpt))) pianju))
    
53.             (setq zjp  (polar midpt (cond ((> bugle 0)(angle  cp midpt))(t (angle midpt cp))) pianju))
    
54.      )
    
55.         (if (not (or (and (>= ang1 0) (< ang1 (* 0.666666 pi))) (and (> ang1 (* 1.666666 pi)) (< ang1 (* 2.0 pi)))))
    
56.          (setq ang1 (- ang1 pi))
    
57.           )
    
58.         (AddText ms bc  zjp  bcHeight ang1 kgb 0 acAlignmentMiddle Style)
    
59.      );progn
    
60.       (progn
    
61.         (setq midpt (vlax-curve-getPointAtParam obj (+ 0.5 n))
    
62.               ang1 (angle pt np)
    
63.               bc (rtos (/ (- (vlax-curve-getDistAtParam obj (1+ n)) (vlax-curve-getDistAtParam obj n)) DimScale)  2 ZJWS)
    
64.               )
    
65.         (if flag
    
66.             (setq zjp (polar midpt (+ pi2 ang1) pianju))
    
67.           (setq zjp (polar midpt (- ang1 pi2) pianju))
    
68.                )
    
69.         (if (not (or (and (>= ang1 0) (< ang1 (* 0.666666 pi))) (and (> ang1 (* 1.666666 pi)) (<= ang1 (* 2.0 pi)))))
    
70.           (setq ang1 (- ang1 pi))
    
71.           )
    
72.         (AddText ms bc  zjp  bcHeight ang1 kgb 0 acAlignmentMiddle Style)
    
73.       );progn
    
74.     ) ;结束if
    
75.     (setq n (1+ n))
    
76.   ) ; 结束while
    
77.   (setq pen-n (1+ pen-n)))
    
78. )
    
79.   (princ)
    
80.   )

;;;多义线边长标注<br /> (defun c:bcbz (/ obj pianju sHandle  pt np gx bj np xc  rr  cp n ang1 zjp ms AddText pen-n pen-all)<br /> ;;;构造text<br /> (command "layer" "M" "边长标注" "C" "3" "" "LT" "CONTINUOUS" "" "");设置一个标注图层<br /> (command "style" "tukou" "宋体" "0" "" "0" "" "")<br />   (defun AddText (obj TextString  InsertionPoint  Height xz kb qx Alignment style / obj1 err)<br />   (setq obj1 (vla-addtext obj TextString  (vlax-3d-point InsertionPoint)  Height))<br />   (vla-put-Rotation obj1 xz)<br />   (vla-put-ScaleFactor obj1 kb)<br />   (vla-put-ObliqueAngle obj1 qx)<br />   (vla-put-alignment obj1 Alignment)<br />   (if (/= Alignment acAlignmentLeft)<br />     (vla-put-TextAlignmentPoint obj1 (vlax-3d-point InsertionPoint))<br />     (vla-put-InsertionPoint obj1 (vlax-3d-point InsertionPoint))<br />    )<br />    (VL-CATCH-ALL-APPLY 'vla-put-StyleName (list obj1 style))<br />   obj1<br />   )<br /> (setq pi2 (/ pi 2))<br />   (setq ms (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object))))<br /> (setq  bcHeight (getdist "\n输入标注文字高度:");文字高度<br />         kgb         0.8 ; 宽高比<br />        Style         "BG_ST" ; 字体<br />         ZJWS         2 ;_ 注记位数<br />        DimScale 1 ; 边长尺度，若单位为mm,该值为1000<br />         flag         nil ;标注在多段线走向的右侧,T 左侧<br /> ) ;_ setq<br /> (setq pen-n 0)<br /> (if (setq pen-all (ssget '((0 . "*polyline"))))<br />     (repeat (sslength pen-all)<br />             (setq pianju (* bcHeight 0.7)) ;边长离线距离<br />             (setq pen-en (ssname pen-all pen-n))<br />             (setq obj (vlax-ename->vla-object pen-en)<br />                   n 0)<br />               (while (and (setq pt (vlax-curve-getPointAtParam obj n))<br />               (setq np (vlax-curve-getPointAtParam obj (1+ n)))<br />          ) ;_ 结束and<br />     (if        (/= 0.0 (setq bugle (vla-GetBulge obj n)))<br />       (progn<br />         (setq midpt (vlax-curve-getPointAtParam obj (+ 0.5 n))<br />              bj (* (atan (abs bugle)) 4)<br />             xc (* 0.5 (distance Pt np))<br />             gg (abs (* bugle xc))<br />             rr (/ (+ (* xc xc) (* gg gg)) (* 2 gg))<br />             ang1 (angle pt np)<br />             cp (polar Pt ang1 xc)<br />             cp (polar midpt (angle midpt cp) rr)<br />             bc (rtos (/ (- (vlax-curve-getDistAtParam obj (1+ n)) (vlax-curve-getDistAtParam obj n)) DimScale) 2 ZJWS)<br />               )<br />        (if flag<br />             (setq zjp (polar midpt (cond ((> bugle 0)(angle midpt cp))(t (angle  cp midpt))) pianju))<br />             (setq zjp  (polar midpt (cond ((> bugle 0)(angle  cp midpt))(t (angle midpt cp))) pianju))<br />      )<br />         (if (not (or (and (>= ang1 0) (< ang1 (* 0.666666 pi))) (and (> ang1 (* 1.666666 pi)) (< ang1 (* 2.0 pi)))))<br />          (setq ang1 (- ang1 pi))<br />           )<br />         (AddText ms bc  zjp  bcHeight ang1 kgb 0 acAlignmentMiddle Style)<br />      );progn<br />       (progn<br />         (setq midpt (vlax-curve-getPointAtParam obj (+ 0.5 n))<br />               ang1 (angle pt np)<br />               bc (rtos (/ (- (vlax-curve-getDistAtParam obj (1+ n)) (vlax-curve-getDistAtParam obj n)) DimScale)  2 ZJWS)<br />               )<br />         (if flag<br />             (setq zjp (polar midpt (+ pi2 ang1) pianju))<br />           (setq zjp (polar midpt (- ang1 pi2) pianju))<br />                )<br />         (if (not (or (and (>= ang1 0) (< ang1 (* 0.666666 pi))) (and (> ang1 (* 1.666666 pi)) (<= ang1 (* 2.0 pi)))))<br />           (setq ang1 (- ang1 pi))<br />           )<br />         (AddText ms bc  zjp  bcHeight ang1 kgb 0 acAlignmentMiddle Style)<br />       );progn<br />     ) ;结束if<br />     (setq n (1+ n))<br />   ) ; 结束while<br />   (setq pen-n (1+ pen-n)))<br /> )<br />   (princ)<br />   )

edata

@2006
(command "style" "tukou" "宋体" "0" "" "0" "" "")
==>
(command "style" "tukou" "宋体" "0" "" "0" "" "" "")

香田里浪人

zyhandw 发表于 2014-1-18 09:09
也看过一些楼主发的帖子，我想这应该不能难倒楼主啊，如下是帮你改了以后的程序，试试看看是否是你想要的结 ...

很好！谢谢您！满足我的要求。

陈亚娣

测试过，如果线里有相同坐标的重点就出现错误~求修改

香田里浪人

陈亚娣 发表于 2014-3-21 14:24
测试过，如果线里有相同坐标的重点就出现错误~求修改

请阁下把图上传。

陈亚娣

香田里浪人 发表于 2014-3-21 20:52
请阁下把图上传。

老师，不用上图也行吧！就是复合线有重点就会有错误~老师你可以试试处理有重点的多段线

陈亚娣

香田里浪人 发表于 2014-3-21 20:52
请阁下把图上传。

;;164.9 [功能] 去除多段线重点(没写作者名所以没法说出出处)
;;示例(HH:Remove (car (entsel)))
(defun HH:Remove (en / NEWDATA)
  (foreach e (entget en)
    (if (and (member e newdata) (= 10 (car e)))
      nil
      (setq newdata (cons e newdata))
    )
  )
  (entmod (reverse newdata))
)
我加了这个去除多段线重点函数

香田里浪人

有重点也是可以标注，只是距离为0.00

香田里浪人

有重点也是可以标注，只是距离为0.00