有木有能计算重量的LISP.材质与密度需可修改。有木有啊！

preone · 发表于 2012-8-15 17:59:39

chlh_jd 发表于 2012-8-14 22:00

学习~~

preone · 发表于 2012-8-15 18:03:45

lohas1118 发表于 2012-8-14 16:38
你好，我用的是2004版的CAD，输入的参数都是反着的。
第一个数值会跑到最后面，7.85变成.857,20变成了02 ...

在上次发的那个程序里更新了~

preone · 发表于 2012-8-15 18:09:59

lohas1118 发表于 2012-8-15 17:17
请教下像这种图形，用这个怎么算不出来。

因为图形不是面域或者多段线~~
需要 pe 做成多段线或者 reg 做成面域就可以了~~

lohas1118 · 发表于 2012-8-16 16:48:15

本帖最后由 lohas1118 于 2012-8-16 16:52 编辑

preone 发表于 2012-8-15 18:09
因为图形不是面域或者多段线~~
需要 pe 做成多段线或者 reg 做成面域就可以了~~

试过了，但算出来答案是0.000 kg。是不是太小了算不出来。

材料是C2680,厚度0.2 您试下。

preone · 发表于 2012-8-16 17:12:21

lohas1118 发表于 2012-8-16 16:48
试过了，但算出来答案是0.000 kg。是不是太小了算不出来。

材料是C2680,厚度0.2 您试下。

恩我试过了，是太小了呵呵
我把小数位数调到6位，就可以显示出来了~~
上面的程序已经改过来了你更新一下~~

chlh_jd · 发表于 2012-8-17 08:26:53

如果是这种方式，可以通过面域求解，以下简单写了个示意；
您可以根据需要自己修改调整下，比如可以采用人工控制是否采用面域算法（例中采用了图元数大于10为界）

(defun c:test (/ ss ssen wk a0 l0 a1 l1 str del l p h z en ent is ptl c pt en ssobj )
;;by GSLS(SS) 2012-8-14
;;图形面积相减并设置密度和厚度,输出文字
(if (and (setq ss (ssget '((0 . "LWPOLYLINE,ELLIPSE,CIRCLE,SPLINE,LINE,ARC")))) ;_选择对象
(setq ssen (ss2lst ss nil)))
(progn
(if (< (length ssen) 10) ;_如果对象数量多于10 按面域计算,这里您可以自己设定
(if (setq
ssen
(vl-remove-if-not
(function
(lambda (x)
(or (vlax-curve-isclosed x)
(equal (vlax-curve-getstartpoint x)
(vlax-curve-getendpoint x)
1e-8))))
ssen)) ;_过滤非封闭曲线
(progn
(setq ssen
(mapcar
(function
(lambda (x / l)
(setq l (SS:ClosedCurve:GetPoints x 10))
(if (equal (car l) (last l) 1e-8)
(setq l (cdr l)))
(list (vlax-curve-getarea x) l)))
ssen)) ;_计算曲线面积和坐标表
(setq ssen
(vl-sort ssen
(function (lambda (e1 e2)
(> (car e1) (car e2)))))) ;_排序
(setq wk (car ssen)
ssen (cdr ssen)
a0 (car wk)
l0 (cadr wk))
;_减法计算
(if ssen
(foreach a ssen
(setq a1 (car a)
l1 (cadr a))
(if
(not (vl-some
(function (lambda (x)
(< (pipl? x l0 1e-8) 0)))
l1))
(setq a0 (- a0 a1)))))
;_if
) ;_progn
(princ "\n选择对象类型错误,未包含封闭曲线。")
) ;_if
(progn
(setq en (entlast))
(if (not (vl-catch-all-error-p
(vl-catch-all-apply
(function
vl-cmdf)
(list
"_Region"
ss ""))))
(progn
(setq ssen nil)
(while (setq en (entnext en))
(setq ssen (cons en ssen)))
(setq ssobj (mapcar 'vlax-ename->vla-object ssen))
(setq ssobj
(vl-remove-if-not
(function (lambda (x)
(eq (vla-get-objectname x)
"AcDbRegion")))
ssobj))
(setq
ssobj (vl-sort
ssobj
(function (lambda (e1 e2)
(> (vla-get-area e1)
(vla-get-area e2)))))) (while (cadr ssobj)
(vla-boolean
(car ssobj)
acSubtraction
(cadr ssobj)
)
(setq ssobj (cons (car ssobj) (cddr ssobj)))
)
(setq a0 (vla-get-area (car ssobj)))
(vl-cmdf "_EXPLODE"
(vlax-vla-object->ename (car ssobj)))
))))
(if
(and
a0
(not (minusp a0))
(not (prompt
"\n输入密度kg/m^3和厚度mm(空格或分号逗号隔开):"))
(setq str (lm:getstring "7850 20"))
(cond ((wcmatch str "* *")
(setq del " "))
((wcmatch str "*;*")
(setq del ";"))
((wcmatch str ",")
)
((setq del "-")))
(setq l (mapcar 'atof (string->strlst str del)))
(setq p (car l))
(setq h (cadr l))
) ;_条件输入
(progn
(setq z (* a0 h p 1e-9))
(setq str (strcat (rtos z 2 3) " kg"))
(setq en (my_entsel "\n选择要修改的文字对象或点:"
(list (cons 0 "TEXT"))
nil))
(setq p (car en))
(if (cadr en)
(entmod (setq ent (entget (cadr en))
ent (subst (cons 1 str) (assoc 1 ent) ent)))
(if (and (setq en
(entmakex (list (cons 0 "TEXT")
(cons 1 str) ;_文字内容
(cons 10 (trans p 1 0)) ;_插入点
(cons 72 0) ;_
(cons 73 1) ;_72 73对正样式,左对齐
(cons 62 256) ;_文字颜色,随层
(cons 40 3.) ;_文字高度
(cons 41 0.7) ;_文字宽度
(cons 50 0.0) ;_文字旋转角度
(cons 7 "STANDARD") ;_文字样式
)))
(setq ent (entget en))
(setq is t))
(while is
(setq ptl (grread t 15 0))
(setq c (car ptl))
(cond
((= c 5)
(setq pt (cadr ptl))
(setq ent (subst (cons 11 pt)
(assoc 11 ent)
ent))
(entmod ent)
(entupd en)
)
((= c 3)
(setq is nil)
)
) ;_cond
) ;_while
) ;_if
) ;_if
(princ (strcat "\n面积与密度换算重量为" str "。"))
) ;_progn
(princ "\n未输入密度和厚度。")
)
)
(princ "\n未选择对象,请重新执行命令。")
) ;_if
(princ)
) ;_defun
;;;配套函数;;;转换选择集为表
(defun ss2lst (ss vla / a e i)
(if (= (type ss) (quote PICKSET))
(progn
(setq i -1)
(while (setq e (ssname ss (setq i (1+ i))))
(if vla
(setq e (vlax-ename->vla-object e))
nil)
(setq a (cons e a))))
nil))
;;;判断点是否在封闭多边形内 .
;;;Function : judge a point location with polygon
;;;Arg : pt -- a point
;;; pts -- points of polygon
;;; eps -- allowance
;;;return :
;;; -1 -- out of polygon , 0 -- at , 1 -- in
(defun pipl? (pt pts eps / is at a)
;; by 狂刀
;; Edit by GSLS(SS) 2011.03.28
;; Solved the problem : if a point at the given polygon , it perhap return T or NIL .
(if (vl-some (function (lambda (x) (equal x pt eps))) pts)
0
(progn (setq is
(equal
PI
(abs
(apply
(function +)
(mapcar
(function (lambda (x y / a)
(setq a
(rem (- (angle pt x) (angle pt y))
PI))
(if (equal (+ (distance pt x)
(distance pt y))
(distance x y)
Eps)
(setq at T))
a))
(cons (last pts) pts)
pts)))
eps))
(cond (at 0)
(is 1)
(T -1)))))
;;字符串转为表
(defun string->strlst (str del / lst a s1 cha pos i)
(setq s1 ""
i 0
a (ascii del))
(while (setq pos (vl-string-position a str i))
(setq s1 (substr str (1+ i) (- pos i)))
(if (/= s1 "")
(setq lst (cons s1 lst)))
(setq i (1+ pos)))
(setq s1 (substr str (1+ i)))
(if (/= s1 "")
(setq lst (cons s1 lst)))
(reverse lst))
;;封闭曲线取点函数
(defun SS:ClosedCurve:GetPoints (en acc / ent et)
;;by GSLS(SS)
(setq
ent (entget en)
et (cdr (assoc 0 ent)))
(cond
((= et "LWPOLYLINE")
((lambda (/ a b vetex bu p1 p2 l r ang an1 N)
(while (setq ent (member (assoc 10 ent) ent))
(setq b (cons (cdar ent) b)
ent (member (assoc 42 ent) ent)
b (cons (cdar ent) b)
ent (cdr ent)
vetex (cons b vetex)
b nil))
(while vetex
(setq a (car vetex)
vetex (cdr vetex)
bu (car a)
p1 (cadr a))
(if l
(setq p2 (car l))
(setq p2 (cadr (last vetex))))
(if (equal bu 0 1e-6)
(setq l (cons p1 l))
(progn
(setq ang (* 2 (atan bu))
r (/ (distance p1 p2) (* 2 (sin ang)))
c (polar p1 (+ (angle p1 p2) (- (/ pi 2) ang)) r)
r (abs r)
ang (abs (* ang 2.0))
N (abs (fix (/ ang 0.0174532925199433)))
N (min N (1+ Acc)))
(if (= N 0)
(setq l (cons p1 l))
(progn
(setq an1 (/ ang N)
ang (angle c p2))
(if (not (minusp bu))
(setq an1 (- an1)))
(repeat (1- N)
(setq ang (+ ang an1)
l (cons (polar c ang r) l)))
(setq l (cons p1 l)))))))
l)))
((= et "CIRCLE")
((lambda (c R / sa l)
(setq sa 0.0)
(repeat 180
(setq l (cons (polar c sa R) l)
sa (+ sa 0.0174532925199433)))
(setq l (reverse l))
(append
l
(mapcar
(function
(lambda (p)
(mapcar (function +) c (mapcar (function -) c p))))
l)))
(cdr (assoc 10 ent))
(cdr (assoc 40 ent))))
((= et "SPLINE")
((lambda (/ r _oce)
(setq _oce (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(if (vl-catch-all-apply
(function vl-cmdf)
(list "_PEDIT"
(vlax-vla-object->ename
(vla-copy (vlax-ename->vla-object en))
)
""
acc
""))
(progn
(setq l (ss-assoc 10 (entget (setq r (entlast)))))
(if (vlax-curve-isClosed r)
(setq l (append l (list (car l)))))
(entdel r)))
(setvar "CMDECHO" _oce)
l)))
((= et "ELLIPSE")
((lambda (/ e l _os)
(setq _os (getvar "OSMODE"))
(setvar "OSMODE" 0)
(vl-catch-all-apply
(function vla-offset)
(list (vlax-ename->vla-object en) 0.1))
(setq e (entlast))
(vl-catch-all-apply
(function vla-offset)
(list (vlax-ename->vla-object (entlast)) -0.1))
(entdel e)
(setq e (entlast))
(setq l (ss-assoc 10 (entget e)))
(entdel e)
(setvar "OSMODE" _os)
l)))))
;;
;;;by Lee Mac
(defun LM:GetString (#Default / dcTag result)
(cond ((<= (setq dcTag (load_dialog "ACAD")) 0))
((not (new_dialog "acad_txtedit" dcTag)))
(t
(set_tile "text_edit" #Default)
(action_tile
"accept"
"(setq result (get_tile "text_edit")) (done_dialog)")
(action_tile "cancel" "(done_dialog)")
(start_dialog)
(unload_dialog dcTag)))
result)
;; 【索引表查找】全部
;;;获取表中索引码相同的所有元素
;;;ss-assoc 最快
(defun ss-assoc (a lst / b res)
(while (setq b (assoc a lst))
(setq lst (cdr (member b lst))
res (cons (cdr b) res)))
(reverse res))
;;
(defun my_entsel
(STR FILTER PRO / PT SS_NAME SS old_modemacro)
(setq old_modemacro (getvar "MODEMACRO"))
(if (/= (type STR) (quote STR))
(progn
(princ "\n变量类型不对，STR应为字符串。\n")
(eval NIL))
(progn
(if (/= (type FILTER) (quote list))
(progn
(princ "\n变量类型不对，FILTER应为表。\n")
(eval NIL))
(progn
(princ STR)
(setvar "MODEMACRO" STR) ;_这里添加选择修改
(setq PT (grread t 4 2)
is_go_on t)
(while (and (/= 3 (car PT))
(/= 11 (car PT))
(/= 25 (car pt))
is_go_on)
(cond
((and (= 2 (car pt))
(or (= 13 (cadr pt)) (= 32 (cadr pt)))) ;_Enter,Space.
(setq is_go_on nil))
((and (= 2 (car pt))
(or (= 115 (cadr pt)) (= 83 (cadr pt)))) ;_S set arg.
(eval pro)
(princ STR))
((and (= 5 (car PT)) (vl-consp (cadr PT)))
(setq SS (ssget (cadr PT) FILTER))
(if SS_NAME
(redraw SS_NAME 4))
(setq SS_NAME NIL)
(if SS
(progn
(setq SS_NAME (ssname SS 0))
(redraw SS_NAME 3))
(setvar "MODEMACRO" old_modemacro)))
) ;_cond
(setq PT (grread t 4 2))
) ;_while
(setvar "MODEMACRO" old_modemacro)
(if (and (/= 11 (car pt)) (/= 25 (car pt)))
(progn
(setq PT (cadr PT))
(setq SS (ssget PT FILTER))
(setvar "LASTPOINT" PT)
(if SS_NAME
(redraw SS_NAME 4)
)
(setq SS_NAME NIL)
(if SS
(progn
(setq SS_NAME (ssname SS 0))
(list (trans PT 1 0) SS_NAME))
(list (trans PT 1 0))))
(if ss_name
(redraw ss_name 4))))))))

(defun c:test  (/ ss ssen wk a0 l0 a1 l1 str del l p h z en ent is ptl c pt en ssobj ) 
  ;;by GSLS(SS) 2012-8-14 
  ;;图形面积相减并设置密度和厚度,输出文字 
  (if (and (setq ss (ssget '((0 . "LWPOLYLINE,ELLIPSE,CIRCLE,SPLINE,LINE,ARC")))) ;_选择对象 
    (setq ssen (ss2lst ss nil))) 
    (progn 
      (if (< (length ssen) 10) ;_如果对象数量多于10 按面域计算,这里您可以自己设定 
 (if (setq 
       ssen 
        (vl-remove-if-not 
   (function 
     (lambda (x) 
       (or (vlax-curve-isclosed x) 
    (equal (vlax-curve-getstartpoint x) 
    (vlax-curve-getendpoint x) 
    1e-8)))) 
   ssen)) ;_过滤非封闭曲线 
   (progn 
     (setq ssen 
     (mapcar 
       (function 
         (lambda (x / l) 
    (setq l (SS:ClosedCurve:GetPoints x 10)) 
    (if (equal (car l) (last l) 1e-8) 
      (setq l (cdr l))) 
    (list (vlax-curve-getarea x) l))) 
       ssen)) ;_计算曲线面积和坐标表 
     (setq ssen 
     (vl-sort ssen 
       (function (lambda (e1 e2) 
     (> (car e1) (car e2)))))) ;_排序 
     (setq wk   (car ssen) 
    ssen (cdr ssen) 
    a0   (car wk) 
    l0   (cadr wk)) 
 ;_减法计算 
     (if ssen 
       (foreach a  ssen 
  (setq a1 (car a) 
        l1 (cadr a)) 
  (if 
    (not (vl-some 
    (function (lambda (x) 
         (< (pipl? x l0 1e-8) 0))) 
    l1)) 
     (setq a0 (- a0 a1))))) 
 ;_if 
     ) ;_progn 
   (princ "\n选择对象类型错误,未包含封闭曲线。") 
   ) ;_if 
 (progn 
   (setq en (entlast)) 
   (if (not (vl-catch-all-error-p 
       (vl-catch-all-apply 
         (function 
    vl-cmdf) 
      (list 
        "_Region" 
        ss "")))) 
     (progn 
       (setq ssen nil) 
       (while (setq en (entnext en)) 
  (setq ssen (cons en ssen))) 
       (setq ssobj (mapcar 'vlax-ename->vla-object ssen)) 
       (setq ssobj 
       (vl-remove-if-not 
         (function (lambda (x) 
       (eq (vla-get-objectname x) 
          "AcDbRegion"))) 
         ssobj)) 
       (setq 
  ssobj (vl-sort 
   ssobj 
   (function (lambda (e1 e2) 
        (> (vla-get-area e1) 
           (vla-get-area e2))))))       (while (cadr ssobj) 
  (vla-boolean 
    (car ssobj) 
    acSubtraction 
    (cadr ssobj) 
    ) 
  (setq ssobj (cons (car ssobj) (cddr ssobj))) 
  ) 
       (setq a0 (vla-get-area (car ssobj))) 
       (vl-cmdf "_EXPLODE" 
         (vlax-vla-object->ename (car ssobj))) 
       )))) 
      (if 
 (and 
   a0 
   (not (minusp a0)) 
   (not (prompt 
   "\n输入密度kg/m^3和厚度mm(空格或分号逗号隔开):")) 
   (setq str (lm:getstring "7850 20")) 
   (cond ((wcmatch str "* *") 
   (setq del " ")) 
  ((wcmatch str "*;*") 
   (setq del ";")) 
  ((wcmatch str ",") 
   ) 
  ((setq del "-"))) 
   (setq l (mapcar 'atof (string->strlst str del))) 
   (setq p (car l)) 
   (setq h (cadr l)) 
   ) ;_条件输入 
  (progn 
    (setq z (* a0 h p 1e-9)) 
    (setq str (strcat (rtos z 2 3) " kg")) 
    (setq en (my_entsel "\n选择要修改的文字对象或点:" 
          (list (cons 0 "TEXT")) 
          nil)) 
    (setq p (car en)) 
    (if (cadr en) 
      (entmod (setq ent (entget (cadr en)) 
      ent (subst (cons 1 str) (assoc 1 ent) ent))) 
      (if (and (setq en 
        (entmakex (list (cons 0 "TEXT") 
          (cons 1 str) ;_文字内容 
          (cons 10 (trans p 1 0)) ;_插入点 
          (cons 72 0) ;_ 
          (cons 73 1) ;_72 73对正样式,左对齐 
          (cons 62 256) ;_文字颜色,随层 
          (cons 40 3.) ;_文字高度 
          (cons 41 0.7) ;_文字宽度 
          (cons 50 0.0) ;_文字旋转角度 
          (cons 7 "STANDARD") ;_文字样式 
          ))) 
        (setq ent (entget en)) 
        (setq is t)) 
        (while is 
   (setq ptl (grread t 15 0)) 
   (setq c (car ptl)) 
   (cond 
     ((= c 5) 
      (setq pt (cadr ptl)) 
      (setq ent (subst (cons 11 pt) 
         (assoc 11 ent) 
         ent)) 
      (entmod ent) 
      (entupd en) 
      ) 
     ((= c 3) 
      (setq is nil) 
      ) 
     ) ;_cond 
   ) ;_while 
        ) ;_if 
      ) ;_if 
    (princ (strcat "\n面积与密度换算重量为" str "。")) 
    ) ;_progn 
  (princ "\n未输入密度和厚度。") 
  ) 
      ) 
    (princ "\n未选择对象,请重新执行命令。") 
    ) ;_if 
  (princ) 
  ) ;_defun 
;;;配套函数;;;转换选择集为表 
(defun ss2lst  (ss vla / a e i) 
  (if (= (type ss) (quote PICKSET)) 
    (progn 
      (setq i -1) 
      (while (setq e (ssname ss (setq i (1+ i)))) 
 (if vla 
   (setq e (vlax-ename->vla-object e)) 
   nil) 
 (setq a (cons e a)))) 
    nil)) 
;;;判断点是否在封闭多边形内 . 
;;;Function : judge a point location with polygon 
;;;Arg : pt -- a point 
;;;      pts -- points of polygon 
;;;      eps -- allowance 
;;;return : 
;;;     -1 -- out of polygon , 0 -- at , 1 -- in 
(defun pipl?  (pt pts eps / is at a) 
  ;; by 狂刀   
  ;; Edit by GSLS(SS) 2011.03.28 
  ;; Solved the problem : if a point at the given polygon , it perhap return T or NIL .   
  (if (vl-some (function (lambda (x) (equal x pt eps))) pts) 
    0 
    (progn (setq is 
    (equal 
      PI 
      (abs 
        (apply 
   (function +) 
   (mapcar 
     (function (lambda (x y / a) 
          (setq a 
          (rem (- (angle pt x) (angle pt y)) 
        PI)) 
          (if (equal (+ (distance pt x) 
          (distance pt y)) 
       (distance x y) 
       Eps) 
     (setq at T)) 
          a)) 
     (cons (last pts) pts) 
     pts))) 
      eps)) 
    (cond (at 0) 
   (is 1) 
   (T -1))))) 
;;字符串转为表 
(defun string->strlst  (str del / lst a s1 cha pos i) 
  (setq s1 "" 
 i  0 
 a  (ascii del)) 
  (while (setq pos (vl-string-position a str i)) 
    (setq s1 (substr str (1+ i) (- pos i))) 
    (if (/= s1 "") 
      (setq lst (cons s1 lst))) 
    (setq i (1+ pos))) 
  (setq s1 (substr str (1+ i))) 
  (if (/= s1 "") 
    (setq lst (cons s1 lst))) 
  (reverse lst)) 
;;封闭曲线取点函数 
(defun SS:ClosedCurve:GetPoints  (en acc / ent et) 
  ;;by GSLS(SS) 
  (setq 
    ent (entget en) 
    et (cdr (assoc 0 ent))) 
  (cond 
    ((= et "LWPOLYLINE") 
     ((lambda (/ a b vetex bu p1 p2 l r ang an1 N) 
 (while (setq ent (member (assoc 10 ent) ent)) 
   (setq b     (cons (cdar ent) b) 
  ent   (member (assoc 42 ent) ent) 
  b     (cons (cdar ent) b) 
  ent   (cdr ent) 
  vetex (cons b vetex) 
  b     nil)) 
 (while vetex 
   (setq a     (car vetex) 
  vetex (cdr vetex) 
  bu    (car a) 
  p1    (cadr a)) 
   (if l 
     (setq p2 (car l)) 
     (setq p2 (cadr (last vetex)))) 
   (if (equal bu 0 1e-6) 
     (setq l (cons p1 l)) 
     (progn 
       (setq ang (* 2 (atan bu)) 
      r (/ (distance p1 p2) (* 2 (sin ang))) 
      c (polar p1 (+ (angle p1 p2) (- (/ pi 2) ang)) r) 
      r (abs r) 
      ang (abs (* ang 2.0)) 
      N (abs (fix (/ ang 0.0174532925199433))) 
      N (min N (1+ Acc))) 
       (if (= N 0) 
  (setq l (cons p1 l)) 
  (progn 
    (setq an1 (/ ang N) 
   ang (angle c p2)) 
    (if (not (minusp bu)) 
      (setq an1 (- an1))) 
    (repeat (1- N) 
      (setq ang (+ ang an1) 
     l   (cons (polar c ang r) l))) 
    (setq l (cons p1 l))))))) 
 l))) 
    ((= et "CIRCLE") 
     ((lambda (c R / sa l) 
 (setq sa 0.0) 
 (repeat 180 
   (setq l  (cons (polar c sa R) l) 
  sa (+ sa 0.0174532925199433))) 
 (setq l (reverse l)) 
 (append 
   l 
   (mapcar 
     (function 
       (lambda (p) 
  (mapcar (function +) c (mapcar (function -) c p)))) 
     l))) 
       (cdr (assoc 10 ent)) 
       (cdr (assoc 40 ent)))) 
    ((= et "SPLINE") 
     ((lambda (/ r _oce) 
 (setq _oce (getvar "CMDECHO")) 
 (setvar "CMDECHO" 0) 
 (if (vl-catch-all-apply 
       (function vl-cmdf) 
       (list "_PEDIT" 
      (vlax-vla-object->ename 
        (vla-copy (vlax-ename->vla-object en)) 
        ) 
      "" 
      acc 
      "")) 
   (progn 
     (setq l (ss-assoc 10 (entget (setq r (entlast))))) 
     (if (vlax-curve-isClosed r) 
       (setq l (append l (list (car l))))) 
     (entdel r))) 
 (setvar "CMDECHO" _oce) 
 l))) 
    ((= et "ELLIPSE") 
     ((lambda (/ e l _os) 
 (setq _os (getvar "OSMODE")) 
 (setvar "OSMODE" 0) 
 (vl-catch-all-apply 
   (function vla-offset) 
   (list (vlax-ename->vla-object en) 0.1)) 
 (setq e (entlast)) 
 (vl-catch-all-apply 
   (function vla-offset) 
   (list (vlax-ename->vla-object (entlast)) -0.1)) 
 (entdel e) 
 (setq e (entlast)) 
 (setq l (ss-assoc 10 (entget e))) 
 (entdel e) 
 (setvar "OSMODE" _os) 
 l))))) 
;; 
;;;by Lee Mac 
(defun LM:GetString  (#Default / dcTag result) 
  (cond ((<= (setq dcTag (load_dialog "ACAD")) 0)) 
 ((not (new_dialog "acad_txtedit" dcTag))) 
 (t 
  (set_tile "text_edit" #Default) 
  (action_tile 
    "accept" 
    "(setq result (get_tile "text_edit")) (done_dialog)") 
  (action_tile "cancel" "(done_dialog)") 
  (start_dialog) 
  (unload_dialog dcTag))) 
  result) 
;; 【索引表查找】全部 
;;;获取表中索引码相同的所有元素 
;;;ss-assoc 最快 
(defun ss-assoc  (a lst / b res) 
  (while (setq b (assoc a lst)) 
    (setq lst (cdr (member b lst)) 
   res (cons (cdr b) res))) 
  (reverse res)) 
;; 
(defun my_entsel 
    (STR FILTER PRO / PT SS_NAME SS old_modemacro) 
  (setq old_modemacro (getvar "MODEMACRO")) 
  (if (/= (type STR) (quote STR)) 
    (progn 
      (princ "\n变量类型不对，STR应为字符串。\n") 
      (eval NIL)) 
    (progn 
      (if (/= (type FILTER) (quote list)) 
 (progn 
   (princ "\n变量类型不对，FILTER应为表。\n") 
   (eval NIL)) 
 (progn 
   (princ STR) 
   (setvar "MODEMACRO" STR) ;_这里添加选择修改 
   (setq PT  (grread t 4 2) 
  is_go_on t) 
   (while (and (/= 3 (car PT)) 
        (/= 11 (car PT)) 
        (/= 25 (car pt)) 
        is_go_on) 
     (cond 
       ((and (= 2 (car pt)) 
      (or (= 13 (cadr pt)) (= 32 (cadr pt)))) ;_Enter,Space. 
        (setq is_go_on nil)) 
       ((and (= 2 (car pt)) 
      (or (= 115 (cadr pt)) (= 83 (cadr pt)))) ;_S set arg. 
        (eval pro) 
        (princ STR)) 
       ((and (= 5 (car PT)) (vl-consp (cadr PT))) 
        (setq SS (ssget (cadr PT) FILTER)) 
        (if SS_NAME 
   (redraw SS_NAME 4)) 
        (setq SS_NAME NIL) 
        (if SS 
   (progn 
     (setq SS_NAME (ssname SS 0)) 
     (redraw SS_NAME 3)) 
   (setvar "MODEMACRO" old_modemacro))) 
       ) ;_cond 
     (setq PT (grread t 4 2)) 
     ) ;_while 
   (setvar "MODEMACRO" old_modemacro) 
   (if (and (/= 11 (car pt)) (/= 25 (car pt))) 
     (progn 
       (setq PT (cadr PT)) 
       (setq SS (ssget PT FILTER)) 
       (setvar "LASTPOINT" PT) 
       (if SS_NAME 
  (redraw SS_NAME 4) 
  ) 
       (setq SS_NAME NIL) 
       (if SS 
  (progn 
    (setq SS_NAME (ssname SS 0)) 
    (list (trans PT 1 0) SS_NAME)) 
  (list (trans PT 1 0)))) 
     (if ss_name 
       (redraw ss_name 4))))))))

lohas1118 · 发表于 2012-8-17 13:55:41

preone 发表于 2012-8-16 17:12
恩我试过了，是太小了呵呵
我把小数位数调到6位，就可以显示出来了~~
上面的程序已经改过来了你更新 ...

万分感谢

preone · 发表于 2012-8-17 19:29:20

本帖最后由 preone 于 2012-8-17 19:30 编辑

lohas1118 发表于 2012-8-17 13:55
万分感谢

(defun c:tts (/ osold midu changdu wks nbsh ssn scha tg pt dj zl zj)
 (setvar "cmdecho" 0)
 (setq osold (getvar "osmode"))
 (setvar "osmode" 0)
 (setq midu (getreal "输入材料密度(kg/m^3)："))
 (setq changdu (getreal "输入计算长度或厚度(mm)："))
 ;下部分为求面积部分
 (if (null (setq scha (getreal "输入计算面积(mm^2):")))
(progn
 (prompt "选择外框面域或多段线:")
 (command "area" "e" (ssget '((0 . "REGION,LWPOLYLINE,CIRCLE"))))
 (setq wks (getvar "area"))
 (prompt "逐一选择内部面域或多段线:")
 (setq nbsh 0)
 (while
(setq ssn (ssget '((0 . "REGION,LWPOLYLINE,CIRCLE"))))
(command "area" "e" ssn)
(setq nbsh (+ (getvar "area") nbsh))
 )
 (setq scha (- wks nbsh))
)
 )
 ;end求面积部分
 (or (setq tg (getreal "指定输出字高<空格跳过>:")) (setq tg (* (getvar "dimscale") 1.6)))
 (or (setq dj (getreal "\n输入材料单价<默认1,空格跳过>:")) (setq dj 1))
 (setq zl (/ (* scha changdu midu) 1000000)
zj (* dj zl))
 (setq pt (getpoint"\n指定插入点:"))
 (command "text" "s" "宋体" (polar pt (/ pi 2) (* tg 1.6)) tg "0" (strcat "重量=" (rtos zl 2 6) "kg"))
 (command "text" "s" "宋体" pt tg "0" (strcat "单价=" (rtos dj 2 6) "元/kg"))
 (command "text" "s" "宋体" (polar pt (/ pi -2) (* tg 1.6)) tg "0" (strcat "总价=重量x单价=" (rtos zj 2 6) "元"))
 (setvar "osmode" osold)
 (prin1)
)

加上材料单价输入项目，另外因为原来的字体识别不了汉字，所以我把字体改成了 “宋体” 不知道你的cad能不能识别..
程序默认的单价是1，你使用时注意一下~~

挪威的森林 · 发表于 2012-8-18 08:34:11

真的太好了

皇上快溜 · 发表于 2016-7-3 00:45:09

chlh_jd 发表于 2012-8-14 22:00

老大你这个程序可不可以帮我改组一下，用来计算钢板重量
1框选图形
2输入密度（这时程序有选项可供选择，ABAD,,,分别代表不同的密度值）设这么个选项架构即可，具体的选项内容我来填冲
3输入厚度
4计算（计算时加个倍率乘法，例如乘以1.2 或乘以1.5，具体多少由人工输入）
5程序结束，在屏幕上插入文本（文本最好含密度，厚度倍率数值和作为计算结果的重量数值）

账号		自动登录	找回密码
密码			注册

有木有能计算重量的LISP.材质与密度需可修改。有木有啊！

本帖子中包含更多资源

点评

评分

本帖子中包含更多资源

评分