设为首页收藏本站

晓东CAD家园-论坛

 找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 6621|回复: 34

[源码] 最近无聊写的一些函数。对新人也许有帮助!

  [复制链接]
发表于 2013-7-26 10:38:20 | 显示全部楼层 |阅读模式

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

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

x
最近无聊写的一些函数。对新人也许有帮助! 函数都没怎么测试,仅供参考。
  1. ;============{ 在指定位置删除或插入元素 }===============
  2. ;nil表示要删除。如果有值为要插入的元素---by wowan1314
  3. ;(t11 '(1 2 3 4 5 6) 2 0);;->(1 2 0 3 4 5 6)
  4. ;(t11 '(1 2 3 4 5 6) 2 nil);;->(1 2 4 5 6)
  5. ;2013年7月20日 星期六
  6. (defun t11 (lst pos mod / qlst a hlst)
  7.     (setq a -1)
  8.     (setq hlst (vl-member-if-not
  9.             '(lambda(x)
  10.                 (setq a (1+ a))
  11.                 (if (= a pos) nil
  12.                     (setq qlst (cons x qlst))
  13.                 )
  14.             )
  15.             lst
  16.         )
  17.     )
  18.     (if mod
  19.         (apply 'append (list (reverse(cons mod qlst)) hlst))
  20.         (apply 'append (list (reverse qlst) (cdr hlst))
  21.         )
  22.     )
  23. )
  24. ;按新的点对表修改组码表更新图元
  25. (defun t1 (en xin / enb)
  26.     (setq enb (entget en))
  27.     (mapcar '(lambda(x)
  28.             (entmod(subst x (assoc (car x) enb)enb))
  29.         )
  30.         xin
  31.     )
  32. )
  33. ;表中两个两个配对后的表
  34. (defun t3 (lst / a)
  35.     (setq a 0)
  36.     (vl-remove-if '(lambda(x)(= (rem (setq a (1+ a))2)0))
  37.         (mapcar 'cons lst (cdr lst))
  38.     )
  39. )
  40. ;得到表的奇偶项
  41. ;(T2 LST T)奇数项。(T2 LST NIL)为偶数
  42. (defun t2 (lst b / a)
  43.     (setq a 0
  44.         c '(lambda(x)(= (rem (setq a (1+ a))2)0))
  45.     )
  46.     (if b
  47.         (vl-remove-if c lst)
  48.         (vl-remove-if-not c lst)
  49.     )
  50. )
  51. ;选择集变图元名表
  52. (defun t1 (ss)
  53.     (cdr(reverse(mapcar 'cadr (ssnamex (ssget))
  54.             )
  55.         )
  56.     )
  57. )
  58. ;选择集变图元名表
  59. (defun t2 (ss / a en lst)
  60.     (setq a -1)
  61.     (while (setq en (ssname ss (setq a (1+ a))
  62.             )
  63.         )
  64.         (setq lst (cons en lst))
  65.     )
  66.     lst
  67. )
  68. ;图元名表变选择集
  69. (defun t3 (lst / ss)
  70.     (setq ss (ssadd))
  71.     (mapcar '(lambda(x)(setq ss (cons x ss)))lst)
  72.     ss
  73. )
  74. ;dxf_read 按值或值表读取组码表
  75. (defun dxf_read (a en / enb)
  76.     (setq enb (entget en))
  77.     (if (= 'list (type a))
  78.         (mapcar '(lambda(x)(cdr(assoc x enb))) a)
  79.         (cdr(assoc a enb))
  80.     )
  81. )
  82. ;单个图元包围盒
  83. (defun enbox (ename / ll ur)
  84.     (vla-getboundingbox (vlax-ename->vla-object ename) 'll 'ur)
  85.     (mapcar 'vlax-safearray->list (list ll ur))
  86. )
  87. ;选择集包围盒1
  88. (defun t12 (ss / enma enmi a en ll ur)
  89.     (setq a -1)
  90.     (while
  91.         (setq en (ssname ss (setq a (1+ a))
  92.             )
  93.         )
  94.         (setq entb (enbox en)
  95.             enma (cons (car entb) enma)
  96.             enmi (cons (cadr entb) enmi)
  97.         )
  98.     )
  99.     (mapcar '(lambda(a b)(apply 'mapcar (cons a b))) '(max min) (list enma enmi))
  100. )
  101. ;选择集包围盒2
  102. (defun t11 (ss / a en enma enmi ll ur)
  103.     (setq a -1)
  104.     (while
  105.         (setq en (ssname ss (setq a (1+ a))
  106.             )
  107.         )
  108.         (vla-getboundingbox (vlax-ename->vla-object en) 'll 'ur)
  109.         (setq enma (cons (vlax-safearray->list ll) enma)
  110.             enmi (cons (vlax-safearray->list ur) enmi)
  111.         )
  112.     )
  113.     (mapcar '(lambda(a b)(apply 'mapcar (cons a b))) '(max min) (list enma enmi))
  114. )
  115. ;图元名表包围盒
  116. (defun t13 (sslst / enma enmi ll ur)
  117.     (mapcar
  118.         '(lambda(x)
  119.             (vla-getboundingbox (vlax-ename->vla-object x) 'll 'ur)
  120.             (setq enma (cons (vlax-safearray->list ll) enma)
  121.                 enmi (cons (vlax-safearray->list ur) enmi)
  122.             )
  123.         )
  124.         sslst
  125.     )
  126.     (mapcar '(lambda(a b)(apply 'mapcar (cons a b))) '(max min) (list enma enmi))
  127. )
  128. ;按分隔符分解字符串成表.
  129. (defun t11 (str del / pos lst)
  130.     (while
  131.         (setq pos (vl-string-search del str))
  132.         (setq lst (cons (substr str 1 pos) lst)
  133.             str (substr str (+ 1 pos (strlen del))
  134.             )
  135.         )
  136.     )
  137.     (reverse(cons str lst))
  138. )
  139. ;三点求圆弧圆心半径
  140. (defun yy-3arc (p1 p2 p3 / z1 z2 yxin)
  141.     (setq z1 (car (yy-np1p2 p1 p2 2))
  142.         z2 (car (yy-np1p2 p1 p3 2))
  143.     )
  144.     (if
  145.         (setq yxin (inters
  146.                 z1 (polar z1 (+ (angle p1 p2)(* pi 0.5)) 0.1)
  147.                 z2 (polar z2 (+ (angle p1 p3)(* pi 0.5)) 0.1)
  148.                 nil
  149.             )
  150.         )
  151.         (list yxin (distance yxin p1))
  152.     )
  153. )
  154. ;删除相应组码
  155. (defun t1 (lst1 lst)
  156.     (vl-remove-if '(lambda(x)(member x lst1)) lst)
  157. )
  158. ;删除相应组码只删第一个
  159. (defun t2 (lst1 lst / lst2)
  160.     (vl-remove-if '(lambda(x)
  161.             (if
  162.                 (and(member x lst1)(not(member x lst2))
  163.                 )
  164.                 (setq lst2 (cons x lst2))
  165.             )
  166.         )
  167.         lst
  168.     )
  169. )
  170. ;替换组码表,如果没有就加到最后
  171. (defun t3 (lst1 lst / old)
  172.     (mapcar
  173.         '(lambda(x)
  174.             (if (setq old (assoc (car x) lst))
  175.                 (setq lst (subst x old lst))
  176.                 (setq lst (cons x (reverse lst))
  177.                 )
  178.             )
  179.         )
  180.         lst1
  181.     )
  182.     lst
  183. )
  184. ;从指定位置a截取指定长度b的表
  185. (defun t4 (lst a b / i c xlst)
  186.     (setq i -1 c (1-(+ a b))
  187.     )
  188.     (vl-member-if
  189.         '(lambda(x)
  190.             (setq i (1+ i))
  191.             (if (<= a i c)
  192.                 (setq xlst (cons x xlst))
  193.             )
  194.             (if (> i c)
  195.                 t
  196.             )
  197.         )
  198.         lst
  199.     )
  200.     xlst
  201. )
  202. ;分解表内套的表
  203. (defun t5 (lst )
  204.     (mapcar '(lambda(x)(if (listp x)(setq lst2 (t5 x))(setq lst2 (cons x lst2))))lst)
  205.     lst2
  206. )
  207. ;;消除字符串中的空格
  208. (defun t11 (str)
  209.     (apply
  210.         'strcat
  211.         (mapcar
  212.             'vl-princ-to-string
  213.             (read
  214.                 (strcat "(" str ")")
  215.             )
  216.         )
  217.     )
  218. )
  219. ;;消除字符串中的空格
  220. (defun t12 (str)
  221.     (while
  222.         (> (strlen str)
  223.             (strlen
  224.                 (setq str (vl-string-subst "" " " str))
  225.             )
  226.         )
  227.     )
  228.     str
  229. )
  230. ;求字符串表 或 数表中 最大的数 或最长的字符串
  231. (defun t11 (lst)
  232.     (if (= (type (car lst)) 'str)
  233.         (cdr
  234.             (assoc
  235.                 (apply
  236.                     'max
  237.                     (mapcar
  238.                         '(lambda(x)
  239.                             (strlen x)
  240.                         )
  241.                         lst
  242.                     )
  243.                 )
  244.                 (mapcar
  245.                     '(lambda(x)
  246.                         (list (strlen x) x)
  247.                     )
  248.                     lst
  249.                 )
  250.             )
  251.         )
  252.         (apply 'max lst)
  253.     )
  254. )
  255. ;图元之后所有图元组成的选择集
  256. (defun t12 (en / ss)
  257.     (setq ss (ssadd))
  258.     (while
  259.         (setq en (entnext en))
  260.         (if (member
  261.                 (cdr (assoc 0 (entget en))
  262.                 )
  263.                 '("attrib" "vertex" "seqend")
  264.             )
  265.             nil
  266.             (setq ss (ssadd en ss))
  267.         )
  268.     )
  269.     ss
  270. )
  271. ;;图元之后所有图元的表
  272. (defun t11 (en / lst)
  273.     (while
  274.         (setq en (entnext en))
  275.         (if (member
  276.                 (cdr (assoc 0 (entget en))
  277.                 )
  278.                 '("attrib" "vertex" "seqend")
  279.             )
  280.             nil
  281.             (setq lst (cons en lst))
  282.         )
  283.     )
  284.     lst
  285. )
  286. ;将字符串表合并为按指定分隔符分隔的字符串
  287. ; (t11 '("1" "2" "3" "4" "5" "6") ":")
  288. ;==> "1:2:3:4:5:6"
  289. (defun t11 (lst del / ss lst p1 p2 p3)
  290.     (vl-string-right-trim
  291.         del
  292.         (eval
  293.             (cons 'strcat
  294.                 (mapcar
  295.                     '(lambda(x)
  296.                         (strcat x del)
  297.                     )
  298.                     lst
  299.                 )
  300.             )
  301.         )
  302.     )
  303. )
  304. ; (t11 '("1" "2" "3" "4" "5" "6") ":")
  305. ;==> "1:2:3:4:5:6"
  306. (defun t11 (lst del)
  307.     (vl-string-right-trim
  308.         del
  309.         (apply
  310.             'strcat
  311.             (mapcar
  312.                 '(lambda
  313.                     (
  314.                         x
  315.                     )
  316.                     (strcat
  317.                         x
  318.                         del
  319.                     )
  320.                 )
  321.                 lst
  322.             )
  323.         )
  324.     )
  325. )
  326. ;计算点集中距离原点 (最大 最小)
  327. (defun t11 (plst)
  328.     (setq lst (vl-sort lst '(lambda(a b) (> (distance a '(0 0 0)) (distance b '(0 0 0)) ))
  329.         )
  330.     )
  331.     (list (car lst)(last lst))
  332. )
  333. ;计算点集围成的包围盒的 对角点
  334. (defun t12 (plst)
  335.     (mapcar '(lambda(a b)(apply 'mapcar (cons a b))) '(min max) (list lst lst))
  336. )
  337. ;计算实数表中 最大 最小值
  338. (defun t13 (plst)
  339.     (mapcar '(lambda(a b)(apply 'mapcar (cons a b))) '(min max) (list lst lst))
  340. )
  341. ;;等分表,没考虑表的顺序。
  342. (defun t1 (n lst / a ll zll)
  343.     (setq a 1)
  344.     (mapcar
  345.         '(lambda(x)
  346.             (if (< a n)
  347.                 (setq ll (cons x ll) a (1+ a))
  348.                 (setq zll (cons (cons x a) zll)
  349.                     ll nil
  350.                     a 1
  351.                 )
  352.             )
  353.         )
  354.         lst
  355.     )
  356.     (if ll (cons ll zll) zll)
  357. )
  358. ;;用新项替换表中的旧项,只替换第一个。
  359. (defun t2 (new old lst)
  360.     (read(apply 'vl-string-subst (mapcar 'vl-princ-to-string (list new old lst)))
  361.     )
  362. )
  363. ;;点集按pl线的pl起点到点到曲线的最近点的距离排序
  364. ;;pl为vla实体. 返回排序后的点表
  365. (defun t11 (pl pts)
  366.     (mapcar
  367.         'cadr
  368.         (vl-sort
  369.             (mapcar
  370.                 '(lambda (x)
  371.                     (list (vlax-curve-getdistatpoint
  372.                             pl
  373.                             (vlax-curve-getclosestpointto pl x)
  374.                         )
  375.                         x
  376.                     )
  377.                 )
  378.                 pts
  379.             )
  380.             '(lambda (a b)
  381.                 (< (car a) (car b))
  382.             )
  383.         )
  384.     )
  385. )
  386. ;;得到表中重复次数 及 删除重复后的表
  387. ;; (t1 '(1 2 1 2 (1 1) (1 2) (1 2) 1 2))
  388. (defun t1 (lst / lst1 lst2)
  389.     (mapcar
  390.         '(lambda(x)
  391.             (if (member x lst2)
  392.                 (setq lst1 (cons x lst1))
  393.                 (setq lst2 (cons x lst2))
  394.             )
  395.         )
  396.         lst
  397.     )
  398.     (list (length lst1) lst2)
  399. )
  400. ;vl-position返回第一个元素出现的索引位置
  401. ;这个函数返回元素出现的所有索引位置
  402. (defun t11 (at lst / a nlst)
  403.     (setq a 0)
  404.     (mapcar '(lambda(x)(and(eq x at)(setq nlst(cons a nlst)))(setq a(1+ a))) lst)
  405.     (reverse nlst)
  406. )
  407. ;TEXT的四个交点坐标
  408. (defun t11 (ent / p0 p12 ang lst)
  409.     (setq ent (entget ent)
  410.         p0 (cdr (assoc 10 ent))
  411.         ang (cdr (assoc 50 ent))
  412.         p12 (textbox ent)
  413.         lst
  414.         (list
  415.             (car p12)
  416.             (list (caar p12)(cadadr p12))
  417.             (cadr p12)
  418.             (list (caadr p12)(cadar p12))
  419.         )
  420.     )
  421.     (mapcar '(lambda(x)(polar p0 (+ ang (angle '(0 0) x)) (distance '(0 0) x))) lst)
  422. )
  423. ;得到文字内容
  424. (defun gps->txt-getvalue1 (ename)
  425.     (cdr(assoc 1 (entget enmae))
  426.     )
  427. )
  428. ;设置文字内容
  429. (defun gps->txt-setvalue1 (ename val)
  430.     (entmod(subst (cons 1 val)(assoc 1 (entget enmae)) (entget enmae))
  431.     )
  432. )
  433. ; 得到带数字后缀的字符串的 (文字前缀、数字后缀、小数点位数)
  434. (defun t11 (txt1 / nums lop a1 txt len a2)
  435.     (setq nums '(49 50 51 52 53 54 55 56 57 48 43 45 46)
  436.         lop t
  437.         a1 0
  438.         txt (reverse(vl-string->list txt1))
  439.     )
  440.     (while lop
  441.         (if (member (car txt) nums)
  442.             (progn
  443.                 (if (= (car txt) 46) (setq a2 a1))
  444.                 (setq a1 (1+ a1) txt (cdr txt))
  445.             )
  446.             (setq lop nil)
  447.         )
  448.     )
  449.     (if (/= a1 0)
  450.         (progn
  451.             (setq len (- (strlen txt1) a1))
  452.             (list (substr txt1 1 len) (substr txt1 (1+ len)) a2)
  453.         )
  454.     )
  455. )

评分

参与人数 7D豆 +36 贡献 +3 收起 理由
bzhjl + 1
yularna + 5 很给力!经验;技术要点;资料分享奖!
spp_wall + 5 很给力!经验;技术要点;资料分享奖!
XDSoft + 10 + 2 很给力!经验;技术要点;资料分享奖!
仲文玉 + 5 很给力!经验;技术要点;资料分享奖!
xshrimp + 5 + 1 很给力!经验;技术要点;资料分享奖!
Lispboy + 5 很给力!经验;技术要点;资料分享奖!

查看全部评分

本帖被以下淘专辑推荐:

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

点击这里给我发消息

发表于 2014-3-19 16:12:35 | 显示全部楼层
收下 学习   支持葛老
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 1 反对 0

使用道具 举报

 楼主| 发表于 2013-7-26 10:46:28 | 显示全部楼层
本帖最后由 wowan1314 于 2013-8-28 12:14 编辑

A  A
  1. (defun c:t11 nil
  2.     (mapcar''((x)
  3.             (mapcar''((x)
  4.                     (mapcar''((y)(vl-cmdf ".break" y "f" x "@"))
  5.                         (cdr(reverse(mapcar 'cadr (ssnamex (ssget "_c" x x)))))
  6.                     )
  7.                 )
  8.                 x
  9.             )
  10.         )
  11.         (mapcar''((x)(list (vlax-curve-getendpoint x)(vlax-curve-getstartpoint x)))
  12.             ('((x)(if (= 1 (length x))x(cdr(reverse x))))
  13.                 (mapcar 'cadr (ssnamex (ssget '((0 . "L*LINE")))))
  14.             )
  15.         )
  16.     )
  17. )
  1. ;;构建锁定图层过滤表
  2. (defun t11 ( / lays lst)
  3.     (setq lst (list (cons -4 "OR>"))
  4.         lays (vla-get-layers (vla-get-activedocument (vlax-get-acad-object)))
  5.     )
  6.     (vlax-map-collection
  7.         lays
  8.         '(lambda (x)
  9.             (if (= (vla-get-lock x) :vlax-true)
  10.                 nil
  11.                 (setq lst (cons (cons 8 (vla-get-name x) ) lst))
  12.             )
  13.         )
  14.     )
  15.     (cons (cons -4 "<OR") lst)
  16. )
  1. ;;构建锁定图层过滤表
  2. ;;用法 (ssget (t12))
  3. (defun t12 ( / lay lst)
  4.     (setq lay (tblnext "LAYER" t))
  5.     (if (= (cdr (assoc 70 lay)) 0)
  6.         (setq lst (list (cons 8 (cdr(assoc 2 lay))) (cons -4 "OR>")))
  7.         (setq lst (list (cons -4 "OR>")))
  8.     )
  9.     (while (setq lay (tblnext "LAYER"))
  10.         (if (= (cdr (assoc 70 lay)) 0)
  11.             (setq lst (cons (cons 8 (cdr(assoc 2 lay))) lst))
  12.         )
  13.     )
  14.     (cons (cons -4 "<OR") lst)
  15. )
  1. ;;CAD2004得到填充面积(CAD06以上版本 已经有面积的属性了)
  2. (defun c:t11 (/ e s)
  3.     (if (setq e (entget(car(entsel))
  4.             )
  5.         )
  6.         (progn
  7.             (setq s (cdr(reverse(mapcar 'cdr (cdr(vl-remove-if '(lambda(x)(/= 10 (car x)))e))
  8.                         )
  9.                     )
  10.                 )
  11.             )
  12.             (apply 'command (cons "pline" s))(command "C")
  13.             (rtos (vla-get-area(vlax-ename->vla-object(entlast)))2))
  14.     )
  15. )
  1. ;;多段线顶点表
  2. (defun t1 (e)
  3.     (mapcar
  4.         'cdr(vl-remove-if
  5.             '(lambda(x)(/= (car x) 10))
  6.             (entget e)
  7.         )
  8.     )
  9. )
  10. ;;包围盒四角点坐标(左下逆时针)
  11. (defun t2 (e / ll ur p2 p4)
  12.     (vla-getboundingbox (vlax-ename->vla-object e) 'll 'ur)
  13.     (setq ll(mapcar 'vlax-safearray->list (list ll ur))
  14.         p2 (list (caadr ll) (cadar ll))
  15.         p4 (list (caar ll) (cadadr ll))
  16.     )
  17.     (list (car ll) p2 (cadr ll) p4)
  18. )
  1. ;求表的交集(t1 (list l1 l2 . . .))
  2. (defun t1 (lst)
  3.     (setq l1 (car lst) ll (cdr lst))
  4.     (mapcar
  5.         '(lambda(a)
  6.             (mapcar
  7.                 '(lambda(b)
  8.                     (if (member b a) nil (setq l1 (vl-remove b l1))
  9.                     )
  10.                 )
  11.                 l1
  12.             )
  13.         )
  14.         ll
  15.     )
  16.     l1
  17. )
;;变量监视用以简单的定位函数出错的位置.
  1. ;;变量监视函数,如果出错。则输出->出错信息及各变量的赋值情况。
  2. ;;用法 在程序开始处(aa:ever-err '(各个变量名。。))即可.
  3. ;;程序不出错就没有变量赋值情况。
  4. (defun aa:ever-err (lst )
  5.     (setq *olderr* *error* *error* aa:evererr1 *监视变量表* lst)
  6. )
  7. (defun aa:evererr1 (x )
  8.     (princ x)
  9.     (aa:ever-err2 *监视变量表*)
  10.     (setq *error* *olderr* *olderr* nil *监视变量表* nil)
  11. )
  12. (defun aa:ever-err2 (*监视变量表*)
  13.     (mapcar
  14.         '(lambda(e1 e2)
  15.             (princ (strcat "\n" e1 " = "))
  16.             (prin1 (eval e2))
  17.         )
  18.         (mapcar 'vl-princ-to-string *监视变量表*)
  19.         *监视变量表*
  20.     )
  21. )
  22. ;; 1/监视变量
  23. (defun c:t11 ( / a b c d e f)
  24.     (aa:ever-err '(a b c d e f))
  25.     (setq a 1 b 2 c "3" d 4 e 5 )
  26.     (exit)
  27.     (setq f '(1 2 34))
  28. )
  1. ;;标注的两边长
  2. (defun c:t11 nil
  3.     (mapcar
  4.         '(lambda(x)
  5.             (entmake
  6.                 (list '(0 . "DIMENSION") '(100 . "AcDbEntity") '(100 . "AcDbDimension")
  7.                     (cons 10 (car x))
  8.                     '(70 . 33) '(1 . "") '(100 . "AcDbAlignedDimension")
  9.                     (cons 13 (car x)) (cons 14 (cadr x))
  10.                 )
  11.             )
  12.             (entmake
  13.                 (list '(0 . "DIMENSION") '(100 . "AcDbEntity") '(100 . "AcDbDimension")
  14.                     (cons 10 (cadr x))
  15.                     '(70 . 33) '(1 . "") '(100 . "AcDbAlignedDimension")
  16.                     (cons 13 (cadr x)) (cons 14 (caddr x))
  17.                 )
  18.             )
  19.         )
  20.         (mapcar
  21.             '(lambda(a)
  22.                 (mapcar 'cdr
  23.                     (vl-remove-if
  24.                         '(lambda (b)
  25.                             (/= (car b) 10)
  26.                         )
  27.                         (entget a)
  28.                     )
  29.                 )
  30.             )
  31.             (vl-remove-if-not
  32.                 '(lambda(c) (= (type c) 'ename))
  33.                 (mapcar
  34.                     'cadr
  35.                     (ssnamex (ssget '((0 . "LWPOLYLINE")(70 . 1))
  36.                         )
  37.                     )
  38.                 )
  39.             )
  40.         )
  41.     )
  42. )
  1. (defun c:t11 (/ PP P1 P2 SS EN ENO I A)
  2.   (princ "\n选择矩形")
  3.   (setq ss (ssget ":l:s" '((0 . "*lwpolyline"))))
  4.   (if ss
  5.     (progn
  6.       (setq i -1)
  7.       (while (setq en (ssname ss (setq i (1+ i))))
  8.         (vla-offset (vlax-ename->vla-object en) 100)
  9.         (setq eno (entlast)
  10.               A          1
  11.         )
  12.         (repeat        2
  13.           (set (read (strcat "P" (itoa A)))
  14.                (mapcar 'cdr
  15.                        (vl-remove-if
  16.                          '(lambda (b)
  17.                             (/= (car b) 10)
  18.                           )
  19.                          (entget (if (= A 1)
  20.                                    en
  21.                                    eno
  22.                                  )
  23.                          )
  24.                        )
  25.                )
  26.           )
  27.           (setq A (1+ A))
  28.         )
  29.         (mapcar
  30.           '(lambda (a b)
  31.              (entmake (list '(0 . "line") (cons 10 a) (cons 11 b)))
  32.            )
  33.           P1
  34.           P2
  35.         )
  36.       )
  37.     )
  38.   )
  39.   (princ)
  40. )
  1. ;;提取属性块指定属性值
  2. ;(T12 '("日期" "你妈" "项目负责人") EN)
  3. ;用vla-GetAttributes
  4. ;(vlax-safearray->list(vlax-variant-value(vla-GetAttributes (vlax-ename->vla-object (car(entsel))))))
  5. (defun t12 (lst en / att atlst)
  6.     ;(if (= :vlax-true (vla-get-hasattributes VLA)) );检查EN合法性
  7.     (setq
  8.         att
  9.         (mapcar
  10.             '(lambda(x)
  11.                 (cons (vla-get-tagstring x)(vla-get-textstring x))
  12.             )
  13.             (vlax-invoke (vlax-ename->vla-object en) 'getattributes)
  14.         )
  15.         atlst
  16.         (cons
  17.             (apply
  18.                 'list
  19.                 (mapcar
  20.                     '(lambda(x)
  21.                         (assoc x att)
  22.                     )
  23.                     lst
  24.                 )
  25.             )
  26.             atlst
  27.         )
  28.     )
  29. )
  30. ;图签为属性块的提取目录程序
  31. (defun c:t11 (/ ss a en att th tm mllst)
  32.     (setq ss (ssget '((0 . "INSERT") (66 . 1))) a -1);选中属性块,可再加块名区别
  33.     (if ss
  34.         (while (setq en (ssname ss (setq a (1+ a))
  35.                 )
  36.             )
  37.             (setq
  38.                 att
  39.                 (mapcar
  40.                     '(lambda(x) (cons (vla-get-tagstring x)(vla-get-textstring x))
  41.                     )
  42.                     (vlax-invoke (vlax-ename->vla-object en) 'getattributes)
  43.                 )
  44.             )
  45.             (if (and (setq th(assoc "图号" att))(setq tm(assoc "图名" att))
  46.                 )
  47.                 (setq mllst (cons (cons th tm) mllst))
  48.             )
  49.         )
  50.     )
  51.     ;(if mllst (排序后写出目录))
  52. )
  1. ;;=============={ 返回表m-n之间的所有元素 }===============
  2. ;;测试: (T66 3 5 '(2334 556 33 44 66 77 22))==> (33 44 66)
  3. (defun t66 (n m lst / a lst1)
  4.     (setq a 0)
  5.     (vl-member-if
  6.         '(lambda(x) (if (<= n (setq a (1+ a)) m)
  7.                 (setq lst1 (cons x lst1))
  8.             )
  9.             (if (> a m) t)
  10.         )
  11.         lst
  12.     )
  13.     (reverse lst1)
  14. )
  15. ;;=============={ 返回表第N个元素之后的所有元素 }=================
  16. ;;测试: (T6 3 '(2334 556 33 44 66 77 22))==> (44 66 77 22)
  17. (defun t6 (n lst / a nlst l)
  18.     (setq a 0 l (length lst))
  19.     (if (< n (* l 0.65))
  20.         (setq nlst (vl-member-if '(lambda(x)(setq a (1+ a)) (< n a) ) lst))
  21.         (vl-member-if '(lambda(x)(setq l (1- l) nlst (cons x nlst)) (<= l n) ) (reverse lst))
  22.     )
  23.     nlst
  24. )
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 1 反对 0

使用道具 举报

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

使用道具 举报

已领礼包: 849个

财富等级: 财运亨通

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

使用道具 举报

发表于 2013-7-26 12:01:37 | 显示全部楼层
什么时候能像葛老一样,悠闲的吃着黄瓜,玩着LISP就好了:lol
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 2599个

财富等级: 家财万贯

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

使用道具 举报

点击这里给我发消息

已领礼包: 685个

财富等级: 财运亨通

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

使用道具 举报

已领礼包: 51个

财富等级: 招财进宝

发表于 2013-7-26 14:02:11 | 显示全部楼层
阁老,这个是不是不太对

  1. ;图元名表变选择集
  2. (defun t3 (lst / ss)
  3.     (setq ss (ssadd))
  4.     (mapcar '(lambda(x)(setq ss (cons x ss)))lst)
  5.     ss
  6. )

点评

得用ssadd。。最近用cons用惯了.  发表于 2013-7-26 20:26

评分

参与人数 1D豆 +5 收起 理由
wowan1314 + 5

查看全部评分

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

使用道具 举报

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

使用道具 举报

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

使用道具 举报

已领礼包: 196个

财富等级: 日进斗金

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

使用道具 举报

已领礼包: 11个

财富等级: 恭喜发财

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

使用道具 举报

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

使用道具 举报

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

使用道具 举报

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

本版积分规则

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

GMT+8, 2020-11-24 23:41 , Processed in 0.135026 second(s), 94 queries , Gzip On, WinCache On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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