多义线边长标注
有人编过多义线边长标注，程序如下，标注单个多义线是没问题，可惜不能批量标注，如何修改，使之能够批量标注多义线。;;;;多义线边长标注
(defun c:bcbz (/ obj pianju sHandlept np gx bj np xcrrcp n ang1 zjp ms AddText)
;;;构造text
(command "layer" "M" "边长标注" "C" "3" "" "LT" "CONTINUOUS" "" "");设置一个标注图层
(command "style" "tukou" "宋体" "0" "" "0" "" "")
(defun AddText (obj TextStringInsertionPointHeight 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))))
(setqbcHeight (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 (anglecp midpt))) pianju))
(setq zjp(polar midpt (cond ((> bugle 0)(anglecp 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 bczjpbcHeight 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 bczjpbcHeight ang1 kgb 0 acAlignmentMiddle Style)
);progn
) ;结束if
(setq n (1+ n))
) ; 结束while
)
(princ)
)
也看过一些楼主发的帖子，我想这应该不能难倒楼主啊，如下是帮你改了以后的程序，试试看看是否是你想要的结果。;;;多义线边长标注
(defun c:bcbz (/ obj pianju sHandlept np gx bj np xcrrcp n ang1 zjp ms AddText pen-n pen-all)
;;;构造text
(command "layer" "M" "边长标注" "C" "3" "" "LT" "CONTINUOUS" "" "");设置一个标注图层
(command "style" "tukou" "宋体" "0" "" "0" "" "")
(defun AddText (obj TextStringInsertionPointHeight 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))))
(setqbcHeight (getdist "\n输入标注文字高度:");文字高度
kgb 0.8 ; 宽高比
Style "BG_ST" ; 字体
ZJWS 2 ;_ 注记位数
DimScale 1 ; 边长尺度，若单位为mm,该值为1000
flag nil ;标注在多段线走向的右侧,T 左侧
) ;_ setq
(setq pen-n 0)
(if (setq pen-all (ssget '((0 . "*polyline"))))
(repeat (sslength pen-all)
(setq pianju (* bcHeight 0.7)) ;边长离线距离
(setq pen-en (ssname pen-all pen-n))
(setq obj (vlax-ename->vla-object pen-en)
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 (anglecp midpt))) pianju))
(setq zjp(polar midpt (cond ((> bugle 0)(anglecp 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 bczjpbcHeight 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 bczjpbcHeight ang1 kgb 0 acAlignmentMiddle Style)
);progn
) ;结束if
(setq n (1+ n))
) ; 结束while
(setq pen-n (1+ pen-n)))
)
(princ)
) @2006
(command "style" "tukou" "宋体" "0" "" "0" "" "")
==>
(command "style" "tukou" "宋体" "0" "" "0" "" "" "") zyhandw 发表于 2014-1-18 09:09 static/image/common/back.gif
也看过一些楼主发的帖子，我想这应该不能难倒楼主啊，如下是帮你改了以后的程序，试试看看是否是你想要的结 ...
很好！谢谢您！满足我的要求。 测试过，如果线里有相同坐标的重点就出现错误~求修改 陈亚娣 发表于 2014-3-21 14:24 static/image/common/back.gif
测试过，如果线里有相同坐标的重点就出现错误~求修改
请阁下把图上传。 香田里浪人 发表于 2014-3-21 20:52 static/image/common/back.gif
请阁下把图上传。
老师，不用上图也行吧！就是复合线有重点就会有错误~老师你可以试试处理有重点的多段线 香田里浪人 发表于 2014-3-21 20:52 static/image/common/back.gif
请阁下把图上传。
;;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
页:
[1]
2