网格编号

fxlt619

哪位高手能编一个格子编号并能提取宽度，长度及面积等休息的lisp程序

newbuser

哥们发个测试图上来，看你要求是什么样的啊？以前我搞过一个类似的程序，或许能帮上你呢。

1291500406

(vl-load-com)(defun c:mj( / ent ob S L A d H xy xzz old)(setq old (getvar "osmode") ent (entlast))(mapcar '(lambda(x)(setvar x 0))(list "cmdecho" "osmode" "delobj"))(vl-cmdf "_region" (ssget "") "")(while (setq ent (entnext ent))
(setq ob (vlax-ename->vla-object ent) L (vla-get-perimeter ob) A (vla-get-Area ob) H (/ (sqrt A) 12.0) S (cdr (assoc 5 (entget ent))) d (cons (list S L A) d)xy (vlax-safearray->list (vlax-variant-value (vla-get-centroid ob)))xy (polar xy 0 (* -4.0 H))xzz (cons (list (list S (list (car xy)(+ (cadr xy) (* 1.5 H))) H)
(list (strcat "长度= " (rtos L 2)) xy H)(list (strcat "面积= " (rtos A 2))(list (car xy)(- (cadr xy)(* 1.5 H))) H)) xzz))(entdel ent))(foreach x xzz (foreach y x (apply 'MxTxt y)))(if d (SaveExcel (cons '("编号" "长度" "面积") (reverse d))))(setvar "osmode" old)(princ))
(defun SaveExcel( Lit / a r c d)(if (null *appxls*) (princ "\n程序首次运行需要打开 excel 程序，请耐心等候..."))(setq *appxls* (vlax-get-or-create-object "excel.application"))
(setq a (vl-catch-all-error-p (vl-catch-all-apply 'vlax-get-property (list *appxls* "sheets"))))(vlax-invoke-method (vlax-get-property *appxls*(if a "workbooks" "sheets")) "add")(setq newite (vlax-get-property (vlax-get-property *appxls* "sheets") "item" 1)
xlscells (vlax-get-property newite "cells")r 0 c 0)(vla-put-visible *appxls* 1)(repeat (length Lit)(setq d (nth r Lit) r (1+ r))(repeat (length d)(vlax-put-property xlscells "item" r (1+ c)(vl-princ-to-string (nth c d)))(setq c (1+ c)))(setq c 0))
(vlax-release-object xlscells)(vlax-release-object newite)(vlax-release-object *appxls*))(defun MxTxt(s p H)(entmake (list '(0 . "TEXT")(cons 1 s)(cons 10 p)(cons 40 H))))