明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
楼主: lohas1118

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

  [复制链接]
发表于 2012-8-15 17:59 | 显示全部楼层
chlh_jd 发表于 2012-8-14 22:00

学习~~
回复

使用道具 举报

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

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

使用道具 举报

发表于 2012-8-15 18:09 | 显示全部楼层
lohas1118 发表于 2012-8-15 17:17
请教下像这种图形,用这个怎么算不出来。

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

使用道具 举报

 楼主| 发表于 2012-8-16 16:48 | 显示全部楼层
本帖最后由 lohas1118 于 2012-8-16 16:52 编辑




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

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


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

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

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
回复

使用道具 举报

发表于 2012-8-16 17:12 | 显示全部楼层
lohas1118 发表于 2012-8-16 16:48
试过了,但算出来答案是0.000 kg。是不是太小了算不出来。

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

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

点评

可不可以再输入每KG材料的价格,得出此材料的价格呢。  发表于 2012-8-17 14:01

评分

参与人数 1金钱 +20 收起 理由
lohas1118 + 20 赞一个!

查看全部评分

回复

使用道具 举报

发表于 2012-8-17 08:26 | 显示全部楼层
如果是这种方式,可以通过面域求解,以下简单写了个示意;
您可以根据需要自己修改调整下,比如可以采用人工控制是否采用面域算法(例中采用了图元数大于10为界)
  1. (defun c:test  (/ ss ssen wk a0 l0 a1 l1 str del l p h z en ent is ptl c pt en ssobj )
  2.   ;;by GSLS(SS) 2012-8-14
  3.   ;;图形面积相减并设置密度和厚度,输出文字
  4.   (if (and (setq ss (ssget '((0 . "LWPOLYLINE,ELLIPSE,CIRCLE,SPLINE,LINE,ARC")))) ;_选择对象
  5.     (setq ssen (ss2lst ss nil)))
  6.     (progn
  7.       (if (< (length ssen) 10) ;_如果对象数量多于10 按面域计算,这里您可以自己设定
  8. (if (setq
  9.        ssen
  10.         (vl-remove-if-not
  11.    (function
  12.      (lambda (x)
  13.        (or (vlax-curve-isclosed x)
  14.     (equal (vlax-curve-getstartpoint x)
  15.     (vlax-curve-getendpoint x)
  16.     1e-8))))
  17.    ssen)) ;_过滤非封闭曲线
  18.    (progn
  19.      (setq ssen
  20.      (mapcar
  21.        (function
  22.          (lambda (x / l)
  23.     (setq l (SS:ClosedCurve:GetPoints x 10))
  24.     (if (equal (car l) (last l) 1e-8)
  25.       (setq l (cdr l)))
  26.     (list (vlax-curve-getarea x) l)))
  27.        ssen)) ;_计算曲线面积和坐标表
  28.      (setq ssen
  29.      (vl-sort ssen
  30.        (function (lambda (e1 e2)
  31.      (> (car e1) (car e2)))))) ;_排序
  32.      (setq wk   (car ssen)
  33.     ssen (cdr ssen)
  34.     a0   (car wk)
  35.     l0   (cadr wk))
  36. ;_减法计算
  37.      (if ssen
  38.        (foreach a  ssen
  39.   (setq a1 (car a)
  40.         l1 (cadr a))
  41.   (if
  42.     (not (vl-some
  43.     (function (lambda (x)
  44.          (< (pipl? x l0 1e-8) 0)))
  45.     l1))
  46.      (setq a0 (- a0 a1)))))
  47. ;_if
  48.      ) ;_progn
  49.    (princ "\n选择对象类型错误,未包含封闭曲线。")
  50.    ) ;_if
  51. (progn
  52.    (setq en (entlast))
  53.    (if (not (vl-catch-all-error-p
  54.        (vl-catch-all-apply
  55.          (function
  56.     vl-cmdf)
  57.       (list
  58.         "_Region"
  59.         ss ""))))
  60.      (progn
  61.        (setq ssen nil)
  62.        (while (setq en (entnext en))
  63.   (setq ssen (cons en ssen)))
  64.        (setq ssobj (mapcar 'vlax-ename->vla-object ssen))
  65.        (setq ssobj
  66.        (vl-remove-if-not
  67.          (function (lambda (x)
  68.        (eq (vla-get-objectname x)
  69.           "AcDbRegion")))
  70.          ssobj))
  71.        (setq
  72.   ssobj (vl-sort
  73.    ssobj
  74.    (function (lambda (e1 e2)
  75.         (> (vla-get-area e1)
  76.            (vla-get-area e2))))))       (while (cadr ssobj)
  77.   (vla-boolean
  78.     (car ssobj)
  79.     acSubtraction
  80.     (cadr ssobj)
  81.     )
  82.   (setq ssobj (cons (car ssobj) (cddr ssobj)))
  83.   )
  84.        (setq a0 (vla-get-area (car ssobj)))
  85.        (vl-cmdf "_EXPLODE"
  86.          (vlax-vla-object->ename (car ssobj)))
  87.        ))))
  88.       (if
  89. (and
  90.    a0
  91.    (not (minusp a0))
  92.    (not (prompt
  93.    "\n输入密度kg/m^3和厚度mm(空格或分号逗号隔开):"))
  94.    (setq str (lm:getstring "7850 20"))
  95.    (cond ((wcmatch str "* *")
  96.    (setq del " "))
  97.   ((wcmatch str "*;*")
  98.    (setq del ";"))
  99.   ((wcmatch str ",")
  100.    )
  101.   ((setq del "-")))
  102.    (setq l (mapcar 'atof (string->strlst str del)))
  103.    (setq p (car l))
  104.    (setq h (cadr l))
  105.    ) ;_条件输入
  106.   (progn
  107.     (setq z (* a0 h p 1e-9))
  108.     (setq str (strcat (rtos z 2 3) " kg"))
  109.     (setq en (my_entsel "\n选择要修改的文字对象或点:"
  110.           (list (cons 0 "TEXT"))
  111.           nil))
  112.     (setq p (car en))
  113.     (if (cadr en)
  114.       (entmod (setq ent (entget (cadr en))
  115.       ent (subst (cons 1 str) (assoc 1 ent) ent)))
  116.       (if (and (setq en
  117.         (entmakex (list (cons 0 "TEXT")
  118.           (cons 1 str) ;_文字内容
  119.           (cons 10 (trans p 1 0)) ;_插入点
  120.           (cons 72 0) ;_
  121.           (cons 73 1) ;_72 73对正样式,左对齐
  122.           (cons 62 256) ;_文字颜色,随层
  123.           (cons 40 3.) ;_文字高度
  124.           (cons 41 0.7) ;_文字宽度
  125.           (cons 50 0.0) ;_文字旋转角度
  126.           (cons 7 "STANDARD") ;_文字样式
  127.           )))
  128.         (setq ent (entget en))
  129.         (setq is t))
  130.         (while is
  131.    (setq ptl (grread t 15 0))
  132.    (setq c (car ptl))
  133.    (cond
  134.      ((= c 5)
  135.       (setq pt (cadr ptl))
  136.       (setq ent (subst (cons 11 pt)
  137.          (assoc 11 ent)
  138.          ent))
  139.       (entmod ent)
  140.       (entupd en)
  141.       )
  142.      ((= c 3)
  143.       (setq is nil)
  144.       )
  145.      ) ;_cond
  146.    ) ;_while
  147.         ) ;_if
  148.       ) ;_if
  149.     (princ (strcat "\n面积与密度换算重量为" str "。"))
  150.     ) ;_progn
  151.   (princ "\n未输入密度和厚度。")
  152.   )
  153.       )
  154.     (princ "\n未选择对象,请重新执行命令。")
  155.     ) ;_if
  156.   (princ)
  157.   ) ;_defun
  158. ;;;配套函数;;;转换选择集为表
  159. (defun ss2lst  (ss vla / a e i)
  160.   (if (= (type ss) (quote PICKSET))
  161.     (progn
  162.       (setq i -1)
  163.       (while (setq e (ssname ss (setq i (1+ i))))
  164. (if vla
  165.    (setq e (vlax-ename->vla-object e))
  166.    nil)
  167. (setq a (cons e a))))
  168.     nil))
  169. ;;;判断点是否在封闭多边形内 .
  170. ;;;Function : judge a point location with polygon
  171. ;;;Arg : pt -- a point
  172. ;;;      pts -- points of polygon
  173. ;;;      eps -- allowance
  174. ;;;return :
  175. ;;;     -1 -- out of polygon , 0 -- at , 1 -- in
  176. (defun pipl?  (pt pts eps / is at a)
  177.   ;; by 狂刀  
  178.   ;; Edit by GSLS(SS) 2011.03.28
  179.   ;; Solved the problem : if a point at the given polygon , it perhap return T or NIL .  
  180.   (if (vl-some (function (lambda (x) (equal x pt eps))) pts)
  181.     0
  182.     (progn (setq is
  183.     (equal
  184.       PI
  185.       (abs
  186.         (apply
  187.    (function +)
  188.    (mapcar
  189.      (function (lambda (x y / a)
  190.           (setq a
  191.           (rem (- (angle pt x) (angle pt y))
  192.         PI))
  193.           (if (equal (+ (distance pt x)
  194.           (distance pt y))
  195.        (distance x y)
  196.        Eps)
  197.      (setq at T))
  198.           a))
  199.      (cons (last pts) pts)
  200.      pts)))
  201.       eps))
  202.     (cond (at 0)
  203.    (is 1)
  204.    (T -1)))))
  205. ;;字符串转为表
  206. (defun string->strlst  (str del / lst a s1 cha pos i)
  207.   (setq s1 ""
  208. i  0
  209. a  (ascii del))
  210.   (while (setq pos (vl-string-position a str i))
  211.     (setq s1 (substr str (1+ i) (- pos i)))
  212.     (if (/= s1 "")
  213.       (setq lst (cons s1 lst)))
  214.     (setq i (1+ pos)))
  215.   (setq s1 (substr str (1+ i)))
  216.   (if (/= s1 "")
  217.     (setq lst (cons s1 lst)))
  218.   (reverse lst))
  219. ;;封闭曲线取点函数
  220. (defun SS:ClosedCurve:GetPoints  (en acc / ent et)
  221.   ;;by GSLS(SS)
  222.   (setq
  223.     ent (entget en)
  224.     et (cdr (assoc 0 ent)))
  225.   (cond
  226.     ((= et "LWPOLYLINE")
  227.      ((lambda (/ a b vetex bu p1 p2 l r ang an1 N)
  228. (while (setq ent (member (assoc 10 ent) ent))
  229.    (setq b     (cons (cdar ent) b)
  230.   ent   (member (assoc 42 ent) ent)
  231.   b     (cons (cdar ent) b)
  232.   ent   (cdr ent)
  233.   vetex (cons b vetex)
  234.   b     nil))
  235. (while vetex
  236.    (setq a     (car vetex)
  237.   vetex (cdr vetex)
  238.   bu    (car a)
  239.   p1    (cadr a))
  240.    (if l
  241.      (setq p2 (car l))
  242.      (setq p2 (cadr (last vetex))))
  243.    (if (equal bu 0 1e-6)
  244.      (setq l (cons p1 l))
  245.      (progn
  246.        (setq ang (* 2 (atan bu))
  247.       r (/ (distance p1 p2) (* 2 (sin ang)))
  248.       c (polar p1 (+ (angle p1 p2) (- (/ pi 2) ang)) r)
  249.       r (abs r)
  250.       ang (abs (* ang 2.0))
  251.       N (abs (fix (/ ang 0.0174532925199433)))
  252.       N (min N (1+ Acc)))
  253.        (if (= N 0)
  254.   (setq l (cons p1 l))
  255.   (progn
  256.     (setq an1 (/ ang N)
  257.    ang (angle c p2))
  258.     (if (not (minusp bu))
  259.       (setq an1 (- an1)))
  260.     (repeat (1- N)
  261.       (setq ang (+ ang an1)
  262.      l   (cons (polar c ang r) l)))
  263.     (setq l (cons p1 l)))))))
  264. l)))
  265.     ((= et "CIRCLE")
  266.      ((lambda (c R / sa l)
  267. (setq sa 0.0)
  268. (repeat 180
  269.    (setq l  (cons (polar c sa R) l)
  270.   sa (+ sa 0.0174532925199433)))
  271. (setq l (reverse l))
  272. (append
  273.    l
  274.    (mapcar
  275.      (function
  276.        (lambda (p)
  277.   (mapcar (function +) c (mapcar (function -) c p))))
  278.      l)))
  279.        (cdr (assoc 10 ent))
  280.        (cdr (assoc 40 ent))))
  281.     ((= et "SPLINE")
  282.      ((lambda (/ r _oce)
  283. (setq _oce (getvar "CMDECHO"))
  284. (setvar "CMDECHO" 0)
  285. (if (vl-catch-all-apply
  286.        (function vl-cmdf)
  287.        (list "_PEDIT"
  288.       (vlax-vla-object->ename
  289.         (vla-copy (vlax-ename->vla-object en))
  290.         )
  291.       ""
  292.       acc
  293.       ""))
  294.    (progn
  295.      (setq l (ss-assoc 10 (entget (setq r (entlast)))))
  296.      (if (vlax-curve-isClosed r)
  297.        (setq l (append l (list (car l)))))
  298.      (entdel r)))
  299. (setvar "CMDECHO" _oce)
  300. l)))
  301.     ((= et "ELLIPSE")
  302.      ((lambda (/ e l _os)
  303. (setq _os (getvar "OSMODE"))
  304. (setvar "OSMODE" 0)
  305. (vl-catch-all-apply
  306.    (function vla-offset)
  307.    (list (vlax-ename->vla-object en) 0.1))
  308. (setq e (entlast))
  309. (vl-catch-all-apply
  310.    (function vla-offset)
  311.    (list (vlax-ename->vla-object (entlast)) -0.1))
  312. (entdel e)
  313. (setq e (entlast))
  314. (setq l (ss-assoc 10 (entget e)))
  315. (entdel e)
  316. (setvar "OSMODE" _os)
  317. l)))))
  318. ;;
  319. ;;;by Lee Mac
  320. (defun LM:GetString  (#Default / dcTag result)
  321.   (cond ((<= (setq dcTag (load_dialog "ACAD")) 0))
  322. ((not (new_dialog "acad_txtedit" dcTag)))
  323. (t
  324.   (set_tile "text_edit" #Default)
  325.   (action_tile
  326.     "accept"
  327.     "(setq result (get_tile "text_edit")) (done_dialog)")
  328.   (action_tile "cancel" "(done_dialog)")
  329.   (start_dialog)
  330.   (unload_dialog dcTag)))
  331.   result)
  332. ;; 【索引表查找】全部
  333. ;;;获取表中索引码相同的所有元素
  334. ;;;ss-assoc 最快
  335. (defun ss-assoc  (a lst / b res)
  336.   (while (setq b (assoc a lst))
  337.     (setq lst (cdr (member b lst))
  338.    res (cons (cdr b) res)))
  339.   (reverse res))
  340. ;;
  341. (defun my_entsel
  342.     (STR FILTER PRO / PT SS_NAME SS old_modemacro)
  343.   (setq old_modemacro (getvar "MODEMACRO"))
  344.   (if (/= (type STR) (quote STR))
  345.     (progn
  346.       (princ "\n变量类型不对,STR应为字符串。\n")
  347.       (eval NIL))
  348.     (progn
  349.       (if (/= (type FILTER) (quote list))
  350. (progn
  351.    (princ "\n变量类型不对,FILTER应为表。\n")
  352.    (eval NIL))
  353. (progn
  354.    (princ STR)
  355.    (setvar "MODEMACRO" STR) ;_这里添加选择修改
  356.    (setq PT  (grread t 4 2)
  357.   is_go_on t)
  358.    (while (and (/= 3 (car PT))
  359.         (/= 11 (car PT))
  360.         (/= 25 (car pt))
  361.         is_go_on)
  362.      (cond
  363.        ((and (= 2 (car pt))
  364.       (or (= 13 (cadr pt)) (= 32 (cadr pt)))) ;_Enter,Space.
  365.         (setq is_go_on nil))
  366.        ((and (= 2 (car pt))
  367.       (or (= 115 (cadr pt)) (= 83 (cadr pt)))) ;_S set arg.
  368.         (eval pro)
  369.         (princ STR))
  370.        ((and (= 5 (car PT)) (vl-consp (cadr PT)))
  371.         (setq SS (ssget (cadr PT) FILTER))
  372.         (if SS_NAME
  373.    (redraw SS_NAME 4))
  374.         (setq SS_NAME NIL)
  375.         (if SS
  376.    (progn
  377.      (setq SS_NAME (ssname SS 0))
  378.      (redraw SS_NAME 3))
  379.    (setvar "MODEMACRO" old_modemacro)))
  380.        ) ;_cond
  381.      (setq PT (grread t 4 2))
  382.      ) ;_while
  383.    (setvar "MODEMACRO" old_modemacro)
  384.    (if (and (/= 11 (car pt)) (/= 25 (car pt)))
  385.      (progn
  386.        (setq PT (cadr PT))
  387.        (setq SS (ssget PT FILTER))
  388.        (setvar "LASTPOINT" PT)
  389.        (if SS_NAME
  390.   (redraw SS_NAME 4)
  391.   )
  392.        (setq SS_NAME NIL)
  393.        (if SS
  394.   (progn
  395.     (setq SS_NAME (ssname SS 0))
  396.     (list (trans PT 1 0) SS_NAME))
  397.   (list (trans PT 1 0))))
  398.      (if ss_name
  399.        (redraw ss_name 4))))))))

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x

评分

参与人数 1明经币 +1 金钱 +20 收起 理由
lohas1118 + 1 + 20 很给力!多谢了。

查看全部评分

回复

使用道具 举报

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

万分感谢
回复

使用道具 举报

发表于 2012-8-17 19:29 | 显示全部楼层
本帖最后由 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 | 显示全部楼层
真的太好了
回复

使用道具 举报

发表于 2016-7-3 00:45 | 显示全部楼层
chlh_jd 发表于 2012-8-14 22:00

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

回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-3-29 14:21 , Processed in 0.265554 second(s), 23 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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