明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 1564|回复: 7

一些函数,别人的

[复制链接]
发表于 2015-11-18 14:21:39 | 显示全部楼层 |阅读模式
  1. (DEFUN C:TEST1(/ ENT LST SS)
  2.   (SETQ ENT(ENTGET(CAR(ENTSEL))))
  3.   (SETQ LST(MAPCAR'CDR(VL-REMOVE-IF-NOT'(LAMBDA(X)(= 10 (CAR X)))ENT)))
  4.   (SETQ SS(SSGET "WP" LST))
  5.   (SSSETFIRST nil SS)
  6.   )

  7. (defun plinexy(e)
  8.   (mapcar'cdr(vl-remove-if'(lambda(x)(/=(car x)10))(entget e)))
  9.   )

  10. (setq pzx (ssget "wp" (plinexy (car (entsel))) '((0 . "polyline") (8 . "sjw") ) ));选择多段线内实体

  11. (sssetfirst nil pzx)


  12. (vla-ScaleEntity (vlax-ename->vla-object ss_name) (vla-get-InsertionPoint (vlax-ename->vla-object ss_name)) beishu) ;块原地缩小
  13.      ;(setq ss (ssdel ss_name ss))


  14. (entmod (append (vl-remove-if '(lambda(x) (member (car x) '(41 42 43))) pzx121)  (list '(41 . 0.02) '(42 . 0.02) '(43 . 0.02) )));替换多项

评分

参与人数 1明经币 +3 金钱 +30 收起 理由
yfy2003 + 3 + 30 赞一个!

查看全部评分

 楼主| 发表于 2015-11-18 14:33:50 | 显示全部楼层
  1. (defun xyp-SS2List (ss / i s1 lst)
  2.   (cond        ((= (type ss) 'PICKSET)
  3.          (setq lst (reverse (ssnamex ss))
  4.                lst (vl-remove-if-not
  5.                      '(lambda (x) (equal (type (cadr x)) 'ENAME))
  6.                      lst
  7.                    )
  8.                lst (mapcar 'cadr lst)
  9.          )
  10.         )
  11.         ((= (type ss) 'ENAME) (setq lst (list ss)))
  12.         ((= (type ss) 'LIST)
  13.          (foreach s1 ss (setq lst (append (xyp-SS2List s1) lst)))
  14.         )
  15.   )
  16. )



  17. ;; tt(删除重复直线)
  18. ;; 重复定义:起点、终点、图层
  19. (defun c:tt ()
  20.   (setq        ss   (ssget '((0 . "line")))
  21.         lst  (xyp-ss2list ss)
  22.         lst  (mapcar '(lambda (x)
  23.                         (list
  24.                           (vl-remove-if-not
  25.                             '(lambda (y) (member (car y) '(10 11 8)))
  26.                             (entget x)
  27.                           )
  28.                           x
  29.                         )
  30.                       )
  31.                      lst
  32.              )
  33.         lst1 '()
  34.   )
  35.   (foreach a lst
  36.     (setq b (car a))
  37.     (if        (not (member b lst1))
  38.       (setq lst1 (cons b lst1))
  39.       (entdel (cadr a))
  40.     )
  41.   )
  42.   (princ)
  43. );;;院长的
 楼主| 发表于 2015-11-18 14:44:35 | 显示全部楼层
  1. ..论坛里面没有吗
  2. ;释放所有obj对象
  3. (defun cx-ReleaseObject ( obj )
  4.         (and obj (eq 'VLA-OBJECT (type obj)) (not (vlax-object-released-p obj))
  5.                 (not
  6.                         (vl-catch-all-error-p
  7.                                 (vl-catch-all-apply 'vlax-release-object (list obj))
  8.                         )
  9.                 )
  10.         )
  11. )
发表于 2015-12-8 17:25:53 | 显示全部楼层
hao a ,人才辈出 。
发表于 2015-12-27 09:55:03 | 显示全部楼层
谢谢………………
 楼主| 发表于 2023-6-6 10:15:54 | 显示全部楼层
  1. (defun everyposition(lst / n l2);;;lst表内各元素在表内所有出现位置,可进一步用于去重、频数统计等
  2.   (setq n(length lst)m -1)
  3.   (vl-every(function(lambda(x / i l l1 )
  4.           (or(assoc x l2)
  5.        (progn
  6.          (setq l lst)
  7.          (while(setq i(vl-position x l))
  8.            (setq l1(cons(+ i n(-(length l)))l1)
  9.            l(nthcdr(1+ i)l)))
  10.          (setq l2(cons(cons x(reverse l1))l2))))))lst)
  11.   (reverse l2))
  12. EVERYPOSITION
  13. _$ (EVERYPOSITION'(a b e f c d a h c f b d h i))
  14. ((A 0 6) (B 1 10) (E 2) (F 3 9) (C 4 8) (D 5 11) (H 7 12) (I 13))

 楼主| 发表于 2023-6-8 11:10:17 | 显示全部楼层
本帖最后由 树櫴希德 于 2023-6-8 11:55 编辑

  1. (defun plxyz(e fun / pt p n);多段线节点三维坐标,连续重合点只取一个,根据fuz阀值过滤接近点
  2.   (or(=(type e)'vla-object)(setq e(vlax-ename->vla-object e)))
  3.   (cond((=(setq n(vlax-get-property e'objectname))"AcDbLine")
  4.         (list(vlax-curve-getstartpoint e)(vlax-curve-getendpoint e)))
  5.        ((WCMATCH n"*Polyline")
  6.         (repeat(setq n(fix(+(vlax-curve-getendparam e)(if(=(vlax-get-property e'Closed):vlax-true)0 1))))
  7.     (or(equal(setq n(1- n)p(vlax-curve-getpointatparam e n))(car pt)fun)
  8.        (setq pt(cons p pt))))
  9.         (if(equal(car pt)(last pt)fun)
  10.     (butlast pt)pt))))
  11. (defun nodekill(e fuz / area pt p1 p2 mj p a b c i l n 1-N Ntriangle);;;控制面积变化率精简多段线节点
  12.   (defun 1-N(fun i n / a);;;第i点的前一个(fun -)或后一个(fun +)有效点
  13.     (while(not(nth(setq i(cond((<= 0(setq a(fun i 1))n)a)((> a n)0)((MINUSP A)N)))pt)))i)
  14.   (defun Ntriangle(i n / a b c d p1 p2 p3 p4 area);去掉第i点,重组相邻三角形数据
  15.     (setq b(1-n - i n)a(1-n - b n)
  16.     c(1-n + i n)d(1-n + c n)
  17.     p1(nth a pt)p2(nth b pt)p3(nth c pt)p4(nth d pt)
  18.     pt(subst nil(nth i pt)pt))
  19.     (list(List b a c(setq area(2area(List p2 p1 p3)))(/(abs area)(distance p1 p3)))
  20.    (List c b d(setq area(2area(List p3 p2 p4)))(/(abs area)(distance p2 p4)))))
  21.   (setq pt(plxyz e 1e-8)area(vlax-curve-getarea e)darea(* area fuz 2)mj 0 n(1-(length pt))
  22.   p1(vl-sort(mapcar(function(lambda(x / i j k a b c)
  23.           (setq i(vl-position x pt)j(1-N - i n)k(1-N + i n)
  24.           b(nth j pt)c(nth k pt)a(2area(List x b c)))
  25.           (List i j k a(/(abs a)(distance b c)))))pt)
  26.       (function(lambda(x y)(<(last x)(last y))))))
  27.   (while(equal mj 0 darea)
  28.     (if(equal(setq a(car p1)mj(+ mj(cadddr a)))0 darea)
  29.       (setq b(assoc(cadr a)p1)p1(vl-remove a p1)p1(vl-remove b p1)
  30.       p1(vl-sort(append(Ntriangle(car a)n)(vl-remove(assoc(caddr a)p1)p1))(function(lambda(x y)(<(last x)(last y))))))))
  31.   (vl-remove 'nil pt))
  1. (defun 2area(pt)(apply'+(mapcar'(lambda(x y)(-(*(car x)(cadr y))(*(car y)(cadr x))))(cons(last pt)pt)pt)))
 楼主| 发表于 2023-6-12 17:07:58 | 显示全部楼层
  1. (defun plputCoordinates(e pt / n arr p1 p2);三维坐标更新多段线
  2.   (or(=(type e)'vla-object)(setq e(vlax-ename->vla-object e)))
  3.   (setq n(if(WCMATCH(vlax-get-property e'objectname)"AcDb#dPolyline")3 2)
  4.   p1(car pt)p2(cadr pt)
  5.   pt(apply'append(if(= n 2)(mapcar(function(lambda(x)(list(car x)(cadr x))))pt)pt))
  6.   arr(vlax-make-safearray vlax-vbDouble(cons 0(1-(length pt)))))
  7.   (vlax-safearray-fill arr pt)
  8.   (vlax-put-property e'Coordinates arr)
  9.   )

  10. (defun plxyz(e fun / pt p n);多段线节点三维坐标,连续重合点只取一个,根据fuz阀值过滤接近点
  11.   (or(=(type e)'vla-object)(setq e(vlax-ename->vla-object e)))
  12.   (cond((=(setq n(vlax-get-property e'objectname))"AcDbLine")
  13.         (list(vlax-curve-getstartpoint e)(vlax-curve-getendpoint e)))
  14.        ((WCMATCH n"*Polyline")
  15.         (repeat(setq n(fix(+(vlax-curve-getendparam e)(if(=(vlax-get-property e'Closed):vlax-true)0 1))))
  16.     (or(equal(setq n(1- n)p(vlax-curve-getpointatparam e n))(car pt)fun)
  17.        (setq pt(cons p pt))))
  18.         (if(equal(car pt)(last pt)fun)
  19.     (butlast pt)pt))))

  20.   (setq e (car (entsel "\n选择多段线:")))   (plputCoordinates e (plxyz e 0.001 ))

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

本版积分规则

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

GMT+8, 2024-11-6 03:43 , Processed in 0.198027 second(s), 30 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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