tryhi 发表于 2015-3-15 11:33:57

求一个简单的多边形边长快速标注



求一个这个样的标注，不带箭头的，就简单的保留两位数字的标注

香田里浪人 发表于 2015-3-15 11:33:58

看看这个是否满足楼主要求
;;;多段线边长标注
(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))
)
(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" "6" "" "LT" "CONTINUOUS" "" "");设置一个标注图层
(command "style" "hz" "宋体" "0" "" "0" "" "")
(setvar"dimzin"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.60 ; 宽高比
      DimScale 1 ; 边长尺度，若单位为mm,该值为1000
      flag      nil;nil标注在多段线走向的右侧,T 左侧
) ;_ setq
(while
(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 2)
            )
       (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 2)
            )
      (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)
))

zzyong00 发表于 2015-3-15 12:31:05

http://bbs.mjtd.com/forum.php?mod=redirect&goto=findpost&ptid=111783&pid=656515
是不是这个意思？

tryhi 发表于 2015-3-15 12:58:42

zzyong00 发表于 2015-3-15 12:31 static/image/common/back.gif
http://bbs.mjtd.com/forum.php?mod=redirect&goto=findpost&ptid=111783&pid=656515
是不是这个意思？

是的，就是这样，一直用lsp没用过VB，不知道怎么加载

cable2004 发表于 2015-3-15 18:52:32

试试 ，kk

zhaoxt 发表于 2023-11-9 18:51:26

如果是cass的话，有个命令"bianchang",边长的拼音,就可以标注。其实不但cass，只要是在cad里注册过的命令，好像都可以用arx命令，选择命令查看里面有什么命令。我就是这样发现这个命令的
页: [1]
查看完整版本: 求一个简单的多边形边长快速标注