设为首页收藏本站

晓东CAD家园-论坛

 找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

楼主: Free-Lancer

[他山之石] 一些随手写的小工具(慢慢更新)

   关闭 [复制链接]
 楼主| 发表于 2013-5-26 19:42:58 | 显示全部楼层
47 导出 Pline  信息
不知道和前面是否有重复
  1. (defun c:ptoxls (/ ss fl ename n i pts tpy epam v p)
  2.   (if (setq ss (ssget '((0 . "*polyline"))))
  3.     (progn
  4.       (setq fl (open "f:\dddd.txt" "a"))
  5.       (setq ssl (sslength ss))
  6.       (while (> ssl 0)
  7. (setq ename (ssname ss (setq ssl (1- ssl))))
  8. (setq typ (cdr (assoc 0 (entget ename))))
  9. (setq n (1+ (/ (fix (setq epam (vlax-curve-getendparam ename))) 2))
  10.        i 0
  11. )
  12. (repeat n
  13.    (setq p (vlax-curve-getpointatparam ename i))
  14.    (if (wcmatch typ "LWPOLYLINE")
  15.      (progn
  16.        (setq v (cdr (assoc 39 el)))
  17.        (setq pts (cons (list (car p) (cadr p) v) pts))
  18.      )
  19.      (setq pts (cons p pts)
  20.     i   (+ 2 i)
  21.      )
  22.    )
  23.    (if (> i epam)
  24.      (setq i epam)
  25.    )
  26. )
  27.       )
  28.       (foreach x pts
  29. (if (and (< (last x) 900)
  30.    (> (last x) 100)
  31.      )
  32.    (write-line
  33.      (strcat (rtos (car x) 2 3)
  34.       ","
  35.       (rtos (cadr x) 2 3)
  36.       ","
  37.       (rtos (last x) 2 3)
  38.      )
  39.      fl
  40.    )
  41. )
  42.       )
  43.       (close fl)
  44.     )
  45.   )
  46.   (princ)
  47. )
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

 楼主| 发表于 2013-5-26 19:46:14 | 显示全部楼层
48 一个重新插入属性块并修改属性(没有用修改属性的方法)
  1. (defun c:rfl (/ ss sl i e el p xscl yscl an bn fl)
  2.   (setq fl (getstring "\nInput Floor: "))
  3.   (if (setq ss (ssget '((0 . "insert"))))
  4.     (progn
  5.       (setq sl (sslength ss)
  6.      i  -1
  7.       )
  8.       (repeat sl
  9. (setq e    (ssname ss (setq i (1+ i)))
  10.        el   (entget e)
  11.        p    (cdr (assoc 10 el))
  12.        xscl (cdr (assoc 41 el))
  13.        yscl (cdr (assoc 42 el))
  14.        an   (cdr (assoc 50 el))
  15.        bn (cdr (assoc 2 el))
  16. )
  17. (vl-cmdf ".insert" bn p xscl yscl an fl)
  18. (entdel e)
  19.       )
  20.     )
  21.   )
  22.   (princ)
  23. )
  24. (princ "****** Start Command with RFL . ******")
  25. (princ)

评分

参与人数 1D豆 +5 收起 理由
牢固 + 5 技术引导讨论和指点奖!

查看全部评分

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

使用道具 举报

 楼主| 发表于 2013-5-26 19:51:25 | 显示全部楼层
本帖最后由 Free-Lancer 于 2013-10-20 13:18 编辑

49 对Pline增加一个带字段的引线标注面积、周长
  1. (defun C:FA  (/ acsp adoc cpt elist en ent fld lead_obj lpt mtx oid osm)
  2.   (vl-load-com)
  3.   (or adoc
  4.       (setq adoc
  5.       (vla-get-activedocument
  6.         (vlax-get-acad-object)
  7.         )
  8.      )
  9.       )
  10.   (if (and
  11. (= (getvar "tilemode") 0)
  12. (= (getvar "cvport") 1)
  13. )
  14.     (setq acsp (vla-get-paperspace adoc))
  15.     (setq acsp (vla-get-modelspace adoc))
  16.     )
  17. (setq osm (getvar "osmode"))
  18.   (setvar "osmode" 0)
  19.   (while
  20.     (setq ent (entsel "\nSelect pline or hit Enter to exit"))
  21.      (setq en (car ent))
  22.      (if (wcmatch (cdr (assoc 0 (setq elist (entget en)))) "*POLYLINE")
  23.        (progn
  24.   (setq cpt (trans (cadr ent)1 0)
  25.         lpt (trans (getpoint cpt "\nPick the ending point of leader:") 1 0)
  26.         )
  27.   (setq oID (vla-get-objectid (vlax-ename->vla-object en)))
  28.   (setq fld
  29.   (strcat
  30.     (strcat "Area = " "%<\\AcObjProp Object(%<\\_ObjId "
  31.      (itoa oID)
  32.      ">%).Area \\f "%lu2%pr2">%"
  33.      "\\P")
  34.     (strcat "Perimeter = " "%<\\AcObjProp Object(%<\\_ObjId "
  35.      (itoa oID)
  36.      ">%).Length \\f "%lu2%pr2">%"))
  37.         )
  38.   (setq mtx (vlax-invoke
  39.        acsp 'AddMText lpt 0.0 fld)
  40.         )
  41.   (vlax-put mtx
  42.      'AttachmentPoint
  43.      (cond ((> (car cpt) (car lpt))
  44.      6
  45.      )
  46.     ((< (car cpt) (car lpt))
  47.      4
  48.      )
  49.     (T 4)
  50.     )
  51.      )
  52.   (vlax-put mtx 'Height (getvar "textsize"))
  53.   (setq lead_obj (vlax-invoke
  54.      acsp
  55.      'Addleader
  56.      (apply 'append (list cpt lpt))
  57.      mtx
  58.      acLineWithArrow
  59.      )
  60.         )
  61.   (vlax-put lead_obj 'VerticalTextPosition 0);1
  62.   )
  63.        )
  64.      )
  65.   (setvar "osmode" osm)
  66.   (princ)
  67.   )
  68. (princ "\n Start command with FA ...")
  69. (princ)
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

 楼主| 发表于 2013-5-26 19:53:37 | 显示全部楼层
给大家一个编程建议,如果需要什么样的结果,自己先用CAD命令画出来,然后把这个结果用Lisp写出来(比如Leader+字段)

点评

多谢指点  发表于 2013-6-9 10:45
如果有个工具,把画的过程记下并转化成lisp就强大了,...呵呵  详情 回复 发表于 2013-6-6 10:06
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

点击这里给我发消息

发表于 2013-5-31 16:04:13 | 显示全部楼层
楼主太给力了,无私奉献这么多!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

点击这里给我发消息

已领礼包: 394个

财富等级: 日进斗金

发表于 2013-6-6 10:06:28 | 显示全部楼层
Free-Lancer 发表于 2013-5-26 19:53
给大家一个编程建议,如果需要什么样的结果,自己先用CAD命令画出来,然后把这个结果用Lisp写出来(比如Lea ...

如果有个工具,把画的过程记下并转化成lisp就强大了,...呵呵

点评

这个功能早就有了,呵呵  详情 回复 发表于 2013-6-6 10:22
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

 楼主| 发表于 2013-6-6 10:22:28 | 显示全部楼层
kwok 发表于 2013-6-6 10:06
如果有个工具,把画的过程记下并转化成lisp就强大了,...呵呵

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

使用道具 举报

发表于 2013-6-7 09:32:57 | 显示全部楼层
一直没有见过这个功能。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2013-6-7 09:33:33 | 显示全部楼层
要是能共享出来那真是太好了。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

点击这里给我发消息

已领礼包: 342个

财富等级: 日进斗金

发表于 2013-6-7 22:02:56 | 显示全部楼层
楼主发了那么多程序,竟然没几个我用得上的,可能是有了

点评

把你有的也发上来和大家共享啊  详情 回复 发表于 2013-6-7 22:57
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

 楼主| 发表于 2013-6-7 22:57:25 | 显示全部楼层
429014673 发表于 2013-6-7 22:02
楼主发了那么多程序,竟然没几个我用得上的,可能是有了

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

使用道具 举报

发表于 2013-6-9 22:21:51 | 显示全部楼层
好东西,很多很实用啊,
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 2619个

财富等级: 家财万贯

发表于 2013-6-11 11:09:31 | 显示全部楼层
哇 这么多啊,楼主真厉害  值得学习
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 2226个

财富等级: 金玉满堂

发表于 2013-6-13 12:04:47 | 显示全部楼层
非常实用的工具,谢谢版主!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

点击这里给我发消息

发表于 2013-6-13 21:11:52 | 显示全部楼层
好东西就应该顶。谢谢分享
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

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

本版积分规则

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

GMT+8, 2020-12-6 01:35 , Processed in 0.223249 second(s), 94 queries , Gzip On, WinCache On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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