感谢版主们的鼓励，新手写了个小程序望指点

st788796 · 发表于 2013-9-14 15:30:36

本帖最后由 st788796 于 2013-9-14 15:44 编辑

ysq101 发表于 2013-9-14 15:23
请教一下，如何才能达到按面积的大小的来排列呢？？

前提：不用API 不是不给力，是太给力，还没 ...

先将选择集转换为实体列表
(setq entlst (xdrx_pickset->ents ss))
(vl-sort '(lambda (e1 e1) (> (vlax-curve-getarea e1) (vlax-curve-getarea e2))) entlst)
这个排序和api无关，api中的函数和用 car cdr 一样，没必要排斥

ysq101 · 发表于 2013-9-14 15:53:45

st788796 发表于 2013-9-14 15:30
先将选择集转换为实体列表
(setq entlst (xdrx_pickset->ents ss))
(vl-sort '(lambda (e1 e1) (> (vla ...

不敢说排斥哦。。。只是新手还没学会而已，，，
到时学会了一定要多加练习

ysq101 · 发表于 2013-10-18 13:35:00

Free-Lancer 发表于 2013-9-12 19:41
照猫画虎不一定容易，也需要积淀，不说代码（没细看），先要把猫看懂懂

大师~~~~~~关于这个LISP可以以面积来排序吗??从小到大或相反都可以

ysq101 · 发表于 2013-10-18 13:36:54

newer 发表于 2013-9-12 20:56
在那个帖子里面，我都把程序给你写完了，建议也给你了，要想快，用矩阵变换，你在仔细看看那个程序，就简 ...

NEWER版主~~~~~~请问关于这个LISP可以以面积来排序吗??从小到大或相反都可以

选择集都是按图元生成的顺序来排列的
有什么方法吗?

st788796 · 发表于 2013-10-18 13:39:11

ysq101 发表于 2013-10-18 13:36
NEWER版主~~~~~~请问关于这个LISP可以以面积来排序吗??从小到大或相反都可以

选择集都是按图元生 ...

(vl-sort '(lambda (e1 e1) (> (vlax-curve-getarea e1) (vlax-curve-getarea e2))) entlst)

这句就是按面积由大到小排序啊！

ysq101 · 发表于 2013-10-18 14:03:39

(vl-sort '(lambda (e1 e1) (> (vlax-curve-getarea e1) (vlax-curve-getarea e2))) entlst)
(vl-sort '(lambda (e1 e1) 虽然我没学会这些函数,,,,,但你这里是不是写错了??应该是e1 e2吗?
谢谢你的热心回答...我再去查查vlax-curve-getarea函数

st788796 · 发表于 2013-10-18 14:05:58

ysq101 发表于 2013-10-18 14:03
(vl-sort '(lambda (e1 e1) (> (vlax-curve-getarea e1) (vlax-curve-getarea e2))) entlst)
(vl-sort '(l ...

写错了, 应该是 e1 e2

ysq101 · 发表于 2013-10-18 14:24:15

st788796 发表于 2013-10-18 14:05
写错了, 应该是 e1 e2

entlst 这个是VLA 对角表的意思吗??

ysq101 · 发表于 2013-10-18 14:26:37

st788796 发表于 2013-10-18 14:05
写错了, 应该是 e1 e2

(defun c:111 ()
;;; (/ ss i sl e pl bp)
;;获取实体的左下角点、右下角点
(setvar "cmdecho" 0)
(defun GetEntBox (e / obj p1 p2)
(setq obj (vlax-ename->vla-object e))
(vla-getboundingbox obj 'p1 'p2)
(setq p1 (safearray-value p1)
p2 (safearray-value p2)
)d
(list p1 (list (car p2) (cadr p1) 0.))
)
(if (setq ss (ssget '((0 . "LWPOLYLINE"))))
(progn
(setq i -1
sl (sslength ss)
)
(command ".UNDO" "be")
(repeat sl
(setq e (ssname ss (setq i (1+ i))))
(setq pl (getentbox e))
(if (not bp)
(setq bp (cadr pl));_第一次基点
(progn
(vl-cmdf
".move"
(list e (car pl));_拾取实体表
""
"_none"
(car pl)
"_none"
bp
)
(setq bp (mapcar '+ bp (mapcar '- (cadr pl) (car pl))));_设置下一次的目标点
)
)
);end repeat
(command ".UNDO" "e")
)
)
(princ)
)

(defun c:111 () 
;;;       (/ ss i sl e pl bp) 
  ;;获取实体的左下角点、右下角点 
  (setvar "cmdecho" 0) 
  (defun GetEntBox (e / obj p1 p2) 
    (setq obj (vlax-ename->vla-object e)) 
    (vla-getboundingbox obj 'p1 'p2) 
    (setq p1 (safearray-value p1) 
          p2 (safearray-value p2) 
    )d 
    (list p1 (list (car p2) (cadr p1) 0.)) 
  ) 
 
   
  (if (setq ss (ssget '((0 . "LWPOLYLINE")))) 
    (progn 
      (setq i  -1 
            sl (sslength ss) 
      ) 
      (command ".UNDO" "be") 
      (repeat sl 
        (setq e (ssname ss (setq i (1+ i)))) 
        (setq pl (getentbox e)) 
        (if (not bp) 
          (setq bp (cadr pl));_第一次基点 
          (progn 
            (vl-cmdf 
              ".move" 
              (list e (car pl));_拾取实体表 
              "" 
              "_none" 
              (car pl) 
              "_none" 
              bp 
            ) 
            (setq bp (mapcar '+ bp (mapcar '- (cadr pl) (car pl))));_设置下一次的目标点 
          ) 
        ) 
      );end repeat 
      (command ".UNDO" "e") 
    ) 
  ) 
  (princ) 
)

能帮我完善一下吗??上班比较少时间研究LISP
感谢了~~~

st788796 · 发表于 2013-10-18 15:02:06

ysq101 发表于 2013-10-18 14:26
能帮我完善一下吗??上班比较少时间研究LISP
感谢了~~~

你这个用 API 写过吧

ysq101 · 发表于 2013-10-18 15:42:05

st788796 发表于 2013-10-18 15:02
你这个用 API 写过吧

没用到API 纯LISP的.....XD的API还没调试好...可能是我的CAD是精简版的吧...

st788796 · 发表于 2013-10-18 15:45:49

ysq101 发表于 2013-10-18 14:26
能帮我完善一下吗??上班比较少时间研究LISP
感谢了~~~

(defun c:111 (/ ss p lst mat)
(and (setq ss (ssget '((0 . "LWPOLYLINE"))))
(setq p (getpoint "\nBase Point: "))
(setq lst (mapcar '(lambda (x / box)
(setq box (xdrx_entity_box x))
(list (car box) (cadr box) x)
)
(xdrx_pickset->ents ss)
)
mat (xdrx_matrix_identity 3)
)
(foreach x lst
(xdrx_entity_transform
(last x)
(xdrx_matrix_settranslation mat (mapcar '- p (car x)))
)
(setq p (polar p 0. (distance (car x) (cadr x))))
)
)
(princ)
)

st788796 · 发表于 2013-10-18 16:03:41

ysq101 发表于 2013-10-18 15:42
没用到API 纯LISP的.....XD的API还没调试好...可能是我的CAD是精简版的吧...

纯Lisp, 按面积大小排

(defun c:111 (/ ss GetEntBox i sl e pl bp el)
(setvar "cmdecho" 0)
(defun GetEntBox (e / obj p1 p2)
(setq obj (vlax-ename->vla-object e))
(vla-getboundingbox obj 'p1 'p2)
(setq p1 (safearray-value p1)
p2 (safearray-value p2)
)
(list p1 (list (car p2) (cadr p1) 0.))
)
(if (setq ss (ssget '((0 . "LWPOLYLINE"))))
(progn
(setq i -1
sl (sslength ss)
)
(command ".UNDO" "be")
(repeat sl
(setq e (ssname ss (setq i (1+ i)))
pl (getentbox e)
el (cons (list pl e) el)
)
)
(setq el (vl-sort el
'(lambda (e1 e2)
(> (vlax-curve-getarea (cadr e1))
(vlax-curve-getarea (cadr e2))
)
)
)
)
(setq bp (cadaar el))
(foreach x (cdr el)
(vl-cmdf
".move"
(list (last x) (caar x)) ;_拾取实体表
""
"_none"
(caar x)
"_none"
bp
)
(setq bp (mapcar '+ bp (apply 'mapcar (cons '- (reverse (car x)))))) ;_设置下一次的目标点
)
(command ".UNDO" "e")
)
)
(princ)
)

(defun c:111 (/ ss GetEntBox i sl e pl bp el) 
  (setvar "cmdecho" 0) 
  (defun GetEntBox (e / obj p1 p2) 
    (setq obj (vlax-ename->vla-object e)) 
    (vla-getboundingbox obj 'p1 'p2) 
    (setq p1 (safearray-value p1) 
   p2 (safearray-value p2) 
    ) 
    (list p1 (list (car p2) (cadr p1) 0.)) 
  ) 
  (if (setq ss (ssget '((0 . "LWPOLYLINE")))) 
    (progn 
      (setq i  -1 
     sl (sslength ss) 
      ) 
      (command ".UNDO" "be") 
      (repeat sl 
 (setq e  (ssname ss (setq i (1+ i))) 
       pl (getentbox e) 
       el (cons (list pl e) el) 
 ) 
      ) 
      (setq el (vl-sort el 
   '(lambda (e1 e2) 
      (> (vlax-curve-getarea (cadr e1)) 
         (vlax-curve-getarea (cadr e2)) 
      ) 
    ) 
        ) 
      ) 
      (setq bp (cadaar el)) 
      (foreach x (cdr el) 
 (vl-cmdf 
   ".move" 
   (list (last x) (caar x)) ;_拾取实体表 
   "" 
   "_none" 
   (caar x) 
   "_none" 
   bp 
 ) 
 (setq bp (mapcar '+ bp (apply 'mapcar (cons '- (reverse (car x)))))) ;_设置下一次的目标点 
      ) 
      (command ".UNDO" "e") 
    ) 
  ) 
  (princ) 
)

ysq101 · 发表于 2013-10-19 11:22:00

st788796 发表于 2013-10-18 16:03
纯Lisp, 按面积大小排

谢谢你的帮助....有空我再发解你的LISP....看从中学到些什么...有看不懂的再请教你..

xvjiex · 发表于 2022-4-13 08:03:36

感谢楼主分享！

账号		自动登录	找回密码
密码			立即注册

[每日一码] 感谢版主们的鼓励，新手写了个小程序望指点

点评

点评

点评

点评

点评

点评

点评

点评