【已解决】互换图元位置源程序
本帖最后由 20060510412 于 2018-11-5 09:10 编辑在cad绘图中，经常会用新编辑的某块图形去替换旧的图形，此时我一般会使用贱人工具箱的“替换块”功能，使用这个功能的好处是可以维持替换前后图块位置不变，从而保证布局空间中的视口不需要再更新。
但是使用“替换块”功能，必须首先将两个图形设置为块。所以我在想，是否可以编程，直接互换这两块图形呢？这样效率会更高一些。
试试这个行不行：
(defun c:tt (/ *error* 4ptlst1 4ptlst2 midpt1 midpt2 os sourceobjs1 sourceobjs2 ss1 ss2 tmat1 tmat2)
(defun *error* ( msg )
(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(progn (princ (strcat "\n错误：" msg)) (vl-cmdf "_undo" "e") (vl-cmdf "_undo" 1))
)
(princ)
)
(vl-cmdf "_undo" "be")
(setq os (getvar "OSMODE"))
(setvar "OSMODE" 16384)
(princ "\n>>>>>>选择对象一：")
(setq ss1 (ssget))
(princ "\n>>>>>>选择对象二：")
(setq ss2 (ssget))
(setq 4ptlst1 (LM:MinBoundingBox ss1 1)
4ptlst2 (LM:MinBoundingBox ss2 1)
midpt1 (sf-midpt (car 4ptlst1) (caddr 4ptlst1))
midpt2 (sf-midpt (car 4ptlst2) (caddr 4ptlst2))
)
(setq SourceObjs1
(gxl-SEL-MAPCAR
ss1
'(lambda (x) (vlax-ename->vla-object x))
)
)
(setq SourceObjs2
(gxl-SEL-MAPCAR
ss2
'(lambda (x) (vlax-ename->vla-object x))
)
)
(setq tmat1 (vlax-tmatrix (gxl-Mat-TranslateBy2P midpt1 midpt2)))
(mapcar '(lambda (x) (vla-TransformBy x tmat1)) SourceObjs1)
(setq tmat2 (vlax-tmatrix (gxl-Mat-TranslateBy2P midpt2 midpt1)))
(mapcar '(lambda (x) (vla-TransformBy x tmat2)) SourceObjs2)
(setvar "OSMODE" os)
(vl-cmdf "_undo" "e")
(princ)
)
;;;======================================
;;;===========以下为内裤部分=============
;;;======================================
(defun LM:MinBoundingBox ( ss pr / an ba bb bm cn cv i l mb )
(if ss
(progn
(setq bb
(LM:ListBoundingBox
(repeat (setq i (sslength ss))
(setq l (cons (vla-copy (vlax-ename->vla-object (ssname ss (setq i (1- i))))) l))
)
)
)
(setq pr (* pr pi)
cn (apply 'mapcar (cons (function (lambda ( a b ) (/ (+ a b) 2.0))) bb))
cv (vlax-3D-point cn)
bm (* (- (caadr bb) (caar bb)) (- (cadadr bb) (cadar bb)))
mb (cons 0.0 bb)
an 0
)
(while (< (setq an (+ an pr)) pi)
(foreach x l (vla-rotate x cv pr))
(setq bb (LM:ListBoundingBox l)
ba (* (- (caadr bb) (caar bb)) (- (cadadr bb) (cadar bb)))
)
(if (< ba bm) (setq bm ba mb (cons an bb)))
)
(foreach x l (vla-delete x))
(LM:RotatePointsByMatrix
(mapcar
(function
(lambda ( a )
(mapcar (function (lambda ( b ) ((eval b) (cdr mb)))) a)
)
)
'((caar cadar) (caadr cadar) (caadr cadadr) (caar cadadr))
)
cn (- (car mb))
)
)
)
)
(defun sf-midpt (pt1 pt2)
(mapcar '(lambda (x) (/ x 2)) (mapcar '+ pt1 pt2))
)
(defun gxl-Sel-Mapcar (ss Fun / nn rtn)
(if ss
(repeat (setq nn (sslength ss))
(setq rtn
(cons (apply Fun (list (ssname ss (setq nn (1- nn))))) rtn)
)
)
)
)
(defun gxl-Mat-TranslateBy2P ( p1 p2 )
(gxl-Mat-Translation (mapcar '- p2 p1))
)
(defun LM:ListBoundingBox ( lst / l1 l2 ll ur )
(foreach obj lst
(vla-getboundingbox obj 'll 'ur)
(setq l1 (cons (vlax-safearray->list ll) l1)
l2 (cons (vlax-safearray->list ur) l2)
)
)
(mapcar
(function (lambda ( a b ) (apply 'mapcar (cons a b))))
'(min max) (list l1 l2)
)
)
(defun LM:RotatePointsByMatrix ( l p a / m )
(setq m
(list
(list (cos a) (sin (- a)) 0.0)
(list (sin a) (cos a) 0.0)
(list 0.0 0.0 1.0)
)
)
(setq p (mapcar '- p (mxv m p)))
(mapcar (function (lambda ( x ) (mapcar '+ (mxv m x) p))) l)
)
(defun gxl-Mat-Translation ( v )
(list
(list 1. 0. 0. (car v))
(list 0. 1. 0. (cadr v))
(list 0. 0. 1. (caddr v))
(list 0. 0. 0. 1.)
)
)
(defun mxv ( m v )
(mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)
bai0379 发表于 2018-11-6 18:57
选择一个图元，再选择一个需要被替换的图元样板，框选范围内所有和将被替换的图元相同的东西，全替换成第一 ...
这个是应用在什么场景下呢？
而且，程序如何知道什么是相同的图元？因为框选的都是选择集，而非单个的图元哦 ssyfeng 发表于 2018-11-5 08:33
试试这个行不行：
太谢谢您了，正是我想要的效果{:1_1:} 谢谢! ssyfeng 分享实用程序!!!!! yoyoho 发表于 2018-11-5 11:46
谢谢! ssyfeng 分享实用程序!!!!!
我一直认为明经通道比晓东论坛气氛更好一些，学术氛围更浓厚，大家相互之间都会无私地帮助其他人。
像我这种lisp菜鸟，求过好几次源代码，问题基本都能解决，十分感激。 20060510412 发表于 2018-11-5 12:40
我一直认为明经通道比晓东论坛气氛更好一些，学术氛围更浓厚，大家相互之间都会无私地帮助其他人。
像我 ...
是的 晓东论坛 我现在基本不去 它上面其实也有不少好的程序 但是都需要安装晓东工具箱 局限性比较大 依然小小鸟 发表于 2018-11-5 12:43
是的 晓东论坛 我现在基本不去 它上面其实也有不少好的程序 但是都需要安装晓东工具箱 局限性比较大
对，受制于人的感觉，很不爽。
如果函数库升级了，是不是还得去跟着升级，多累。 能不能改下：框选查找替换相同的图元？ bai0379 发表于 2018-11-5 22:00
能不能改下：框选查找替换相同的图元？
希望能支持框选 就是框选的啊，您所指的框选是什么意思呢