求大侠高手帮忙完成下周长源码不全 样条曲线椭圆与圆与弧都量不出来。
本帖最后由 tang87 于 2017-9-19 14:42 编辑求大侠高手帮忙完成下周长源码不全 样条曲线椭圆与圆与弧都量不出来。求帮助。(defun c:zc ( / a b1 box ee len ls1 lsn odlst p1 p2 pa sn ss sx th x y ebox ssbox new_ss lstcj ss2lst mkmtext qxcd);;周长
(progn
(defun qxcd (e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))
(defun ebox (ent / ll ur)
(vla-getboundingbox (vlax-ename->vla-object ent) 'll 'ur)
(mapcar 'safearray-value (list ll ur))
)
(defun new_ss (lastobj / ss obj)
(setq ss (ssadd))
(setq obj (entnext lastobj))
(while obj
(setq ss (ssadd obj ss))
(setq obj (entnext obj))
)
ss
)
(defun ssbox ( s / a b i m n o )
(repeat (setq i (sslength s))
(if
(and
(setq o (vlax-ename->vla-object (ssname s (setq i (1- i)))))
(vlax-method-applicable-p o 'getboundingbox)
(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list o 'a 'b))))
)
(setq m (cons (vlax-safearray->list a) m)
n (cons (vlax-safearray->list b) n)
)
)
)
(if (and m n)
(mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list m n))
)
)
(defun lstcj ( l1 l2 )
(vl-remove-if '(lambda ( x ) (member x l2)) l1)
)
(defun ss2lst ( ss / i l )
(if ss
(repeat (setq i (sslength ss))
(setq l (cons (ssname ss (setq i (1- i))) l))
)
)
)
(if (not (tblsearch "Style" "样式 1"))
(progn
;;;entmake *** "STYLE" *** object:
(entmake (list
'(0 . "STYLE")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbTextStyleTableRecord")
'(2 . "样式 1")
'(70 . 0)
'(40 . 0.0)
'(41 . 1.0)
'(50 . 0.0)
'(71 . 0)
'(42 . 20.0)
'(3 . "simkai.ttf")
'(4 . "")
)
)
);End Progn
)
(defun mkmtext (la str pt th a71 a72 a73)
(entmakex (list '(0 . "MTEXT")
'(100 . "AcDbEntity") '(100 . "AcDbMText")
(cons 8 la)
(cons 1 str)
(cons 10 (trans pt 1 0))
(cons 40 th)
(cons 11 (list 1.0 0.0 0.0))
(cons 7 "样式 1")
(cons 71 a71)
(cons 72 a72)
(cons 73 a73)
)
)
)
(vl-load-com)
(setq *acad(vlax-get-acad-object)
*doc (vla-get-ActiveDocument *acad)
)
(defun *error*(msg)
(mapcar 'setvar '("cmdecho" "osmode" "peditaccept") odlst)
(vlax-invoke-method *doc 'EndUndoMark)
(princ msg)
)
(vlax-invoke-method *doc 'StartUndoMark)
(setq odlst (mapcar 'getvar '("cmdecho" "osmode" "peditaccept")))
(mapcar 'setvar '("cmdecho" "osmode" "peditaccept") '(0 0 1))
)
(if (not *dw) (setq *dw "H"))
(initget 128 "H L M ")
(setq *dw (cond((getkword (strcat "\n选择单位 <" *dw ">: ")))(*dw)))
(princ "\n选择全部处理对象:")
(setq ss (ssget '((0 . "line,arc,LWPOLYLINE,ELLIPSE,spline"))))
(setq ee (entlast))
(vl-cmdf "_pedit" "_M" ss "" "_j" "0.001" "")
(setq sn (new_ss ee))
(vl-cmdf "select" ss sn "")
(setq sn (ssget "p"))
(setq lsn (ss2lst sn)
lsn (vl-sort lsn '(lambda (x y) (> (Vlax-Get (Vlax-Ename->Vla-Object x) 'Area ) (Vlax-Get (Vlax-Ename->Vla-Object y) 'Area )) ) )
)
(setq th 50)
(setq ls1 lsn)
(setq len (apply '+ (mapcar '(lambda(x) (qxcd x)) ls1))
len (cond ((= "H" *dw) (strcat (rtos len 2 2) "mm")) ((= "L" *dw) (strcat (rtos (/ len 10.) 2 2) "cm")) ((= "M" *dw) (strcat (rtos (/ len 1e3) 2 2) "m")))
)
(mkmtext "0" len (getpoint "\n点取文字左下角点:") 50 7 5 1)
(mapcar 'setvar '("cmdecho" "osmode" "peditaccept") odlst)
(vlax-invoke-method *doc 'EndUndoMark)
)
页:
[1]