明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 686|回复: 1

[讨论] 不知错在哪里,请高手帮忙修改

[复制链接]
发表于 2015-6-18 17:51 | 显示全部楼层 |阅读模式
现有程序一次选择即可标注多边形的边长及其面积,第一次运行会出现错误: ActiveX 服务器返回错误: 未知名称: Area,面积无法标注程序就结束。第二次运行可以标注边长及其面积,不知如何修改,请高手抽空帮忙修改。谢谢!
;;边长面积标注
(defun c:bcmj(/ ACADDOC ACADSPC OBJAREA OBJLLPOINT OBJRUPOINT SELECTIONSET TEXTBASEPOINT TEXTHEIGHT TEXTINDEX TEXTOBJ Area)
(command "layer" "M" "边长标注" "C" "4" "" "LT" "CONTINUOUS" "" "");设置一个标注图层
(command "style" "tukou" "宋体" "0" "0.7" "0" "" "")
(setvar"dimzin"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  TextHeight (getdist "\n输入标注文字高度(默认0.9):")
        kgb         0.60 ; 宽高比
      DimScale 1 ; 边长尺度,若单位为mm,该值为1000
        flag        T;nil标注在多段线走向的右侧,T 左侧
) ;_ setq
(if (= TextHeight nil)(setq TextHeight 0.9))
(setq pen-n 0)
(if (setq pen-all (ssget '((0 . "*polyline,LWPOLYLINE"))))
    (repeat (sslength pen-all)
            (setq pianju (* TextHeight 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 (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  TextHeight 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 bc  zjp  TextHeight ang1 kgb 0 acAlignmentMiddle Style)
      );progn
    ) ;结束if
    (setq n (1+ n))
  ) ; 结束while
  (setq pen-n (1+ pen-n)))


)
(vl-load-com)
(command "layer" "M" "面积标注" "C" "6" "" "LT" "CONTINUOUS" "" "");设置一个面积标注图层
   (setq AcadDoc (vla-get-activedocument (vlax-get-acad-object)))
   (if (= (getvar "TILEMODE") 1)(setq AcadSpc (vla-get-modelspace AcadDoc))(setq AcadSpc (vla-get-paperspace AcadDoc)))
   (setq TextHeight TextHeight)
   
(if (not ss)
(setq ss (ssget "x"))
)
   (setq Selectionset (vla-get-activeselectionset AcadDoc))
   (if (and TextHeight Selectionset )
     (vlax-for Obj Selectionset
       (setq ObjArea (vla-get-area obj)
      ObjLlPoint nil
      ObjRuPoint nil
      )
       (vla-GetBoundingBox Obj 'ObjLlPoint 'ObjRuPoint)
       (setq TextBasePoint (mapcar '(lambda(x y) (/ (+ x y) 2)) (vlax-safearray->list ObjLlPoint)(vlax-safearray->list ObjRuPoint))
      TextObj (vla-addtext AcadSpc (strcat "S"  "=" (rtos (/ ObjArea 1)2 2) "㎡") (vlax-3d-point TextBasePoint) TextHeight)
      )
       (vla-put-alignment TextObj acAlignmentCenter)
       (vla-put-TextAlignmentPoint TextObj (vlax-3d-point TextBasePoint))   
        
       )     
)
  (setvar "cmdecho" 1)
  (prin1)
)
"觉得好,就打赏"
还没有人打赏,支持一下
 楼主| 发表于 2015-6-22 01:54 | 显示全部楼层
已明白了。pen-all 改为ss即可
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-5-8 13:11 , Processed in 1.257927 second(s), 26 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表