设为首页收藏本站转
发帖领奖家园QQ群申请版主版主评价切换到宽版

 找回密码
 立即注册

QQ登录

只需一步，快速开始

扫一扫，访问微社区

晓东CAD家园-论坛»论坛 › ╃CAD编程开发 › A/VLISP › 统计面积求修改
返回列表 发新帖
查看: 3123|回复: 8

[求助] 统计面积求修改

[复制链接]
长风（龙少）
发表于 2014-5-11 20:13:15 | 显示全部楼层 |阅读模式
【广而告之】积分规则、D豆获取攻略       窝窝空间装扮攻略

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要 登录 才可以下载或查看，没有账号？立即注册

×
以下是网上找的，首先感谢作者，但是不太适合我，我想做以下修改，但又不会，所以在此请求高手帮忙，感谢
1、将小数点向左移6位，小数位只留2位呢？
2、取消前辍
3、输出设一个开关，需要则输出，不需要则不输出
(defun c:mjjstj(/ ACADDOC ACADSPC OBJAREA OBJLLPOINT OBJRUPOINT SELECTIONSET TEXTBASEPOINT TEXTHEIGHT TEXTINDEX TEXTOBJ)
   (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 (getdist "\n输入标注文字高度:")
Textbh (getstring "\n输入编号前缀:")
TextIndex 1
)
    (setq f (getfiled "指定输出文件路径" "" "xls" 1) f (open f "a"));;;指定输出文件路径
  (write-line "编号\t面积(㎡)" f)
  (setq ss (ssget '((0 . "CIRCLE,LWPOLYLINE,ELLIPSE"))))
(command "layer" "M" "计算面积" "C" "6" "" "LT" "CONTINUOUS" "" "");设置一个标注图层
(command "style" "tukou" "黑体" "0" "0.7" "0" "" "")
(setvar"dimzin"0);;保留小数位数时如果位数不足可以补零
   (setq Selectionset (vla-get-activeselectionset AcadDoc))
   (setq tarea 0 )
   (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 Textbh (itoa TextIndex) "=" (rtos (/ ObjArea 1)2 2) "㎡") (vlax-3d-point TextBasePoint) TextHeight)
      )
(write-line (strcat (strcat Textbh (itoa TextIndex)) "\t" (rtos (/ ObjArea 1)2 2) ) f)
       (vla-put-alignment TextObj acAlignmentCenter)
       (vla-put-TextAlignmentPoint TextObj (vlax-3d-point TextBasePoint))
       (setq tarea (+ ObjArea tarea))
       (setq TextIndex (1+ TextIndex))      
       )     
)
(close f)
(setq l (sslength ss))
(setq insPt0 (getpoint "\n请输入文字插入点: "))            
(setq tarea (/ tarea 1))
(setq bb (strcat Textbh"="Textbh"1+"Textbh"2+...+"Textbh (itoa l)"="(rtos tarea 2 2)"㎡"))
(command "_text" insPt0 TextHeight "" bb 0)
  (setvar "cmdecho" 1)
  (prin1)
)
统计

相关帖子

论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复

使用道具 举报

dnbcgrass

已领礼包: 3752个

财富等级: 富可敌国
发表于 2014-5-11 21:35:13 | 显示全部楼层
  2. (defun c:mjjstj(/ ACADDOC ACADSPC OBJAREA OBJLLPOINT OBJRUPOINT SELECTIONSET TEXTBASEPOINT TEXTHEIGHT TEXTINDEX TEXTOBJ)
  3.     (vl-load-com)
  4.     (setvar "cmdecho" 0)
  5.     (setq AcadDoc (vla-get-activedocument (vlax-get-acad-object)))
  6.     (if (= (getvar "TILEMODE") 1)
  7.         (setq AcadSpc (vla-get-modelspace AcadDoc))
  8.         (setq AcadSpc (vla-get-paperspace AcadDoc))
  9.     )
  10.     (if (= (setq TextHeight (getdist "\n输入标注文字高度<2.5>:")) nil)
  11.         (setq TextHeight 2.5) ;默认标注文字高度2.5
  12.     )
  13.     (setq ;Textbh (getstring "\n输入编号前缀:")
  14.           Textbh  "" ;取消前辍
  15.           TextIndex 1
  16.     )
  17.    
  18.     (if (not (setq f (getfiled "指定输出文件路径" "" "xls" 1)))
  19.         (vl-exit-with-error (alert "没有指定输出文件，程序自动结束!"))
  20.         (if (setq ss (ssget '((0 . "CIRCLE,LWPOLYLINE,ELLIPSE"))))
  21.             (progn
  22.                 (setq f (open f "a"));;;指定输出文件路径
  23.                 (write-line "编号\t面积(㎡)" f)
  24.                 (command "layer" "M" "计算面积" "C" "6" "" "LT" "CONTINUOUS" "" "");设置一个标注图层
  25.                 (command "style" "tukou" "黑体" "0" "0.7" "0" "" "")
  26.                 (setvar"dimzin"0);;保留小数位数时如果位数不足可以补零
  27.                 (setq Selectionset (vla-get-activeselectionset AcadDoc))
  28.                 (setq tarea 0 )
  29.                 (vlax-for Obj Selectionset
  30.                     (setq ObjArea (vla-get-area obj)
  31.                           ObjLlPoint nil
  32.                           ObjRuPoint nil
  33.                     )
  34.                     (vla-GetBoundingBox Obj 'ObjLlPoint 'ObjRuPoint)
  35.                     (setq TextBasePoint (mapcar '(lambda(x y) (/ (+ x y) 2)) (vlax-safearray->list ObjLlPoint)(vlax-safearray->list ObjRuPoint))
  36.                           TextObj (vla-addtext AcadSpc ;(strcat Textbh (itoa TextIndex) "=" (rtos (/ ObjArea 1) 2 2) "㎡")
  37.                                                        (strcat Textbh (itoa TextIndex) "=" (rtos (/ ObjArea 1e6) 2 2) "拾万㎡");小数点向左移6位
  38.                                                        (vlax-3d-point TextBasePoint)
  39.                                                        TextHeight
  40.                                    )
  41.                     )
  42.                     ;(write-line (strcat (strcat Textbh (itoa TextIndex)) "\t" (rtos (/ ObjArea 1)2 2) ) f)
  43.                     (write-line (strcat (strcat Textbh (itoa TextIndex)) "\t" (rtos (/ ObjArea 1e6)2 2) ) f);小数点向左移6位
  44.                     (vla-put-alignment TextObj acAlignmentCenter)
  45.                     (vla-put-TextAlignmentPoint TextObj (vlax-3d-point TextBasePoint))
  46.                     ;(setq tarea (+ ObjArea tarea))
  47.                     (setq tarea (+ (/ ObjArea 1e6) tarea));小数点向左移6位
  48.                     (setq TextIndex (1+ TextIndex))
  49.                 )
  50.                 (close f)

  52.                 (if (setq insPt0 (getpoint "\n请输入文字插入点<回车则不写入>:"))
  53.                     (progn
  54.                         (setq l (sslength ss))
  55.                         (setq tarea (/ tarea 1))
  56.                         (setq bb (strcat Textbh "=" Textbh "1+" Textbh "2+...+" Textbh (itoa l) "=" (rtos tarea 2 2) "拾万㎡"))
  57.                         (command "_text" insPt0 TextHeight "" bb 0)
  58.                     )
  59.                 )
  60.             )
  61.          
  62.             (vl-exit-with-error (alert "没有选取任何要算面积的图元，程序自动结束!"))
  63.         )

  65.     )
  66.    
  67.     (setvar "cmdecho" 1)
  68.     (prin1)
  69. )
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 1 反对 0

使用道具 举报

长风（龙少）
 楼主| 发表于 2014-5-11 21:51:42 | 显示全部楼层
【广而告之】积分规则、D豆获取攻略       窝窝空间装扮攻略
dnbcgrass 发表于 2014-5-11 21:35

非常感谢，但是输出还是必须的，能否改一个需要时按Y输出，不想输出则用N，就不用输出呢？
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

hzj268

已领礼包: 1371个

财富等级: 财源广进
发表于 2014-6-9 10:02:21 | 显示全部楼层
{:soso_e100:}顶一下。。。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

14702470

已领礼包: 1个

财富等级: 恭喜发财
发表于 2014-9-3 07:30:03 来自手机 | 显示全部楼层
【广而告之】积分规则、D豆获取攻略       窝窝空间装扮攻略
收藏了，正需要
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

yoyoho

已领礼包: 8734个

财富等级: 富甲天下
发表于 2017-4-22 10:21:57 | 显示全部楼层
感谢分享程序!!!!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

daisyzxcv
发表于 2020-9-7 15:19:00 | 显示全部楼层
【广而告之】积分规则、D豆获取攻略       窝窝空间装扮攻略
dnbcgrass 发表于 2014-5-11 21:35

感谢分享，非常好用
但能不能麻烦优化下排序功能，增加从左到右，从上到下的排序功能，非常感谢！！
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|申请友链|Archiver|手机版|小黑屋|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )

GMT+8, 2024-5-15 01:32 , Processed in 0.423941 second(s), 47 queries , Gzip On.

Powered by Discuz! X3.5

© 2001-2024 Discuz! Team.

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