画一条多段线在它的子段注记长度

郭文姬happy

求解lisp编程，画一条多段线在它的子段注记长度

香田里浪人

论坛里有了，找一下就是。

newbuser

2. ;多段线边长标注.lsp
   
3. ;本源代码由 Gu_xl 编写发布！ 联系方式: Email: Gu_xl@sohu.com
   
4. ;;多段线边长标注2011.4
   
5. (defun c:tt (/ obj pianju sHandle  pt np gx bj np xc  rr  cp n ang1 zjp ms AddText)
   
6. ;;;构造text
   
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. (while (setq pen (car (entsel "\n选择多段线：")))
    
23.   (setq        bcHeight 0.28 ;_ 字高
    
24.         kgb         0.8 ;_ 宽高比
    
25.         Style         "standard" ;_ 字体
    
26.         ZJWS         2 ;_ 注记位数
    
27.         DimScale 1 ;_ 边长尺度，若单位为mm,该值为1000
    
28.         flag         nil ;_ 标注在多段线走向的右侧,T 左侧
    
29.   ) ;_ setq
    
30.   (setq pianju (* bcHeight 0.7)) ;_ 边长离线距离
    
31.   (setq obj (vlax-ename->vla-object pen)
    
32.         n 0)
    
33.   (while (and (setq pt (vlax-curve-getPointAtParam obj n))
    
34.               (setq np (vlax-curve-getPointAtParam obj (1+ n)))
    
35.          ) ;_ 结束and
    
36.     (if        (/= 0.0 (setq bugle (vla-GetBulge obj n)))
    
37.       (progn
    
38.         (setq midpt (vlax-curve-getPointAtParam obj (+ 0.5 n))
    
39.              bj (* (atan (abs bugle)) 4)
    
40.             xc (* 0.5 (distance Pt np))
    
41.             gg (abs (* bugle xc))
    
42.             rr (/ (+ (* xc xc) (* gg gg)) (* 2 gg))
    
43.             ang1 (angle pt np)
    
44.             cp (polar Pt ang1 xc)
    
45.             cp (polar midpt (angle midpt cp) rr)
    
46.             bc (rtos (/ (- (vlax-curve-getDistAtParam obj (1+ n)) (vlax-curve-getDistAtParam obj n)) DimScale) 2 ZJWS)
    
47.               )
    
48.         (if flag
    
49.             (setq zjp (polar midpt (cond ((> bugle 0)(angle midpt cp))(t (angle  cp midpt))) pianju))
    
50.             (setq zjp  (polar midpt (cond ((> bugle 0)(angle  cp midpt))(t (angle midpt cp))) pianju))
    
51.       )
    
52.         (if (not (or (and (>= ang1 0) (< ang1 (* 0.666666 pi))) (and (> ang1 (* 1.666666 pi)) (< ang1 (* 2.0 pi)))))
    
53.           (setq ang1 (- ang1 pi))
    
54.           )
    
55.         (AddText ms bc  zjp  bcHeight ang1 kgb 0 acAlignmentMiddle Style)
    
56.       );progn
    
57.       (progn
    
58.         (setq midpt (vlax-curve-getPointAtParam obj (+ 0.5 n))
    
59.               ang1 (angle pt np)
    
60.               bc (rtos (/ (- (vlax-curve-getDistAtParam obj (1+ n)) (vlax-curve-getDistAtParam obj n)) DimScale)  2 ZJWS)
    
61.               )
    
62.         (if flag
    
63.             (setq zjp (polar midpt (+ pi2 ang1) pianju))
    
64.           (setq zjp (polar midpt (- ang1 pi2) pianju))
    
65.                )
    
66.         (if (not (or (and (>= ang1 0) (< ang1 (* 0.666666 pi))) (and (> ang1 (* 1.666666 pi)) (<= ang1 (* 2.0 pi)))))
    
67.           (setq ang1 (- ang1 pi))
    
68.           )
    
69.         (AddText ms bc  zjp  bcHeight ang1 kgb 0 acAlignmentMiddle Style)
    
70.       );progn
    
71.     ) ;_ 结束if
    
72.     (setq n (1+ n))
    
73.   ) ;_ 结束while
    
74. )
    
75.   (princ)
    
76.   )

;多段线边长标注.lsp<br /> ;本源代码由 Gu_xl 编写发布！ 联系方式: Email: Gu_xl@sohu.com<br /> ;;多段线边长标注2011.4<br /> (defun c:tt (/ obj pianju sHandle  pt np gx bj np xc  rr  cp n ang1 zjp ms AddText)<br /> ;;;构造text<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 /> (while (setq pen (car (entsel "\n选择多段线：")))<br />   (setq        bcHeight 0.28 ;_ 字高<br />         kgb         0.8 ;_ 宽高比<br />         Style         "standard" ;_ 字体<br />         ZJWS         2 ;_ 注记位数<br />         DimScale 1 ;_ 边长尺度，若单位为mm,该值为1000<br />         flag         nil ;_ 标注在多段线走向的右侧,T 左侧<br />   ) ;_ setq<br />   (setq pianju (* bcHeight 0.7)) ;_ 边长离线距离<br />   (setq obj (vlax-ename->vla-object pen)<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 /> )<br />   (princ)<br />   )

看看这个gu版的是不是您想要的。

郭文姬happy

newbuser 发表于 2014-12-21 08:49
看看这个gu版的是不是您想要的。

可能没有你找的好，不过你可以看看
(defun pline-text (ent-nume / ent i pline-lst text-ang text-dis text-pt)
        (setq ent(entget ent-nume))
        (setq pline-lst '())
        (foreach key ent
                (if (= (car key) 10)
                          (setq pline-lst (append pline-lst (list (cdr key))))
          )
        )
        (setq i 0)
        (repeat (1- (length pline-lst))
                (setq text-pt(mid-pt (nth i pline-lst) (nth (1+ i) pline-lst)))
                (setq text-dis (distance (nth i pline-lst) (nth (1+ i) pline-lst)))
                (setq text-ang (angle (nth i pline-lst) (nth (1+ i) pline-lst)))
          (entmakex (list '(0 . "TEXT") '(100 . "AcDbEntity") '
    (100 . "AcDbText") (cons 1 (rtos text-dis 2 3))
    (cons 10 text-pt)'(62 . 5)(cons 40 100)(cons 50 text-ang)
     ))
                (setq i (1+ i))                 
)
        )

(defun mid-pt (pt1 pt2)
        (mapcar '(lambda (pt1 pt2)
                (/ (+ pt1 pt2) 2)       
        )
        pt1 pt2
)
)
(defun c:5()
        (pline-text (car (entsel)))
)