闭合多线段边长面积标注，请高手修改
闭合多线段边长面积标注，请高手修改;;边长面积
(defun c:bcmj(/ ACADDOC ACADSPC OBJAREA OBJLLPOINT OBJRUPOINT SELECTIONSET TEXTBASEPOINT TEXTHEIGHT TEXTINDEX TEXTOBJ)
(command "layer" "M" "边长面积" "C" "4" "" "LT" "CONTINUOUS" "" "");设置一个标注图层
(command "style" "tukou" "黑体" "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))))
(setqTextHeight (getdist "\n输入标注边长文字高度:")
kgb 0.60 ; 宽高比
DimScale 1 ; 边长尺度，若单位为mm,该值为1000
flag T;nil标注在多段线走向的右侧,T 左侧
) ;_ setq
(setq pen-n 0)
(if (setq pen-all (ssget '((0 . "*polyline"))))
(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 (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 bczjpTextHeight 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 bczjpTextHeight ang1 kgb 0 acAlignmentMiddle Style)
);progn
) ;结束if
(setq n (1+ n))
) ; 结束while
(setq pen-n (1+ pen-n)))
)
(princ "边长标注完毕，要标注面积请继续，不标注请按esc")
(vl-load-com)
(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
TextIndex (getint "\n输入起始编号:")
)
(ssget '((0 . "CIRCLE,LWPOLYLINE")))
(defun maketext (txt pt) ; 生成文字子函数
(entmake (list '(0 . "TEXT") (cons 10 pt) (cons 40 TextHeight) (cons 1 txt) '(41 . 0.6)'(7 . "BG_ST")))
)
(setq Selectionset (vla-get-activeselectionset AcadDoc))
(if (and TextHeight Selectionset TextIndex)
(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"(itoa TextIndex) "=" (rtos (/ ObjArea 1)2 2) "㎡") (vlax-3d-point TextBasePoint) TextHeight)
)
(vla-put-alignment TextObj acAlignmentCenter)
(vla-put-TextAlignmentPoint TextObj (vlax-3d-point TextBasePoint))
(setq TextIndex (1+ TextIndex))
) )
(princ)
) 这么简单的功能需要写这么长的代码???? 这么长，看不完 错误: *error* 函数中出错参数类型错误: lselsetp nil
怎么解决 支持一下！
页:
[1]