明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 2716|回复: 21

[提问] 【已解决】互换图元位置源程序

[复制链接]
发表于 2018-11-4 23:13:51 | 显示全部楼层 |阅读模式
本帖最后由 20060510412 于 2018-11-5 09:10 编辑

在cad绘图中,经常会用新编辑的某块图形去替换旧的图形,此时我一般会使用贱人工具箱的“替换块”功能,使用这个功能的好处是可以维持替换前后图块位置不变,从而保证布局空间中的视口不需要再更新。
但是使用“替换块”功能,必须首先将两个图形设置为块。所以我在想,是否可以编程,直接互换这两块图形呢?这样效率会更高一些。

"觉得好,就打赏"
还没有人打赏,支持一下
发表于 2018-11-5 08:33:20 | 显示全部楼层
试试这个行不行:
  1. (defun c:tt (/ *error* 4ptlst1 4ptlst2 midpt1 midpt2 os sourceobjs1 sourceobjs2 ss1 ss2 tmat1 tmat2)
  2.   (defun *error* ( msg )
  3.     (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
  4.       (progn (princ (strcat "\n错误:" msg)) (vl-cmdf "_undo" "e") (vl-cmdf "_undo" 1))
  5.     )
  6.     (princ)
  7.   )
  8.   (vl-cmdf "_undo" "be")
  9.   (setq os (getvar "OSMODE"))
  10.   (setvar "OSMODE" 16384)
  11.   (princ "\n>>>>>>选择对象一:")
  12.   (setq ss1 (ssget))
  13.   (princ "\n>>>>>>选择对象二:")
  14.   (setq ss2 (ssget))
  15.   (setq 4ptlst1 (LM:MinBoundingBox ss1 1)
  16.     4ptlst2 (LM:MinBoundingBox ss2 1)
  17.     midpt1 (sf-midpt (car 4ptlst1) (caddr 4ptlst1))
  18.     midpt2 (sf-midpt (car 4ptlst2) (caddr 4ptlst2))
  19.   )
  20.   (setq SourceObjs1
  21.     (gxl-SEL-MAPCAR
  22.       ss1
  23.       '(lambda (x) (vlax-ename->vla-object x))
  24.     )
  25.   )
  26.   (setq SourceObjs2
  27.     (gxl-SEL-MAPCAR
  28.       ss2
  29.       '(lambda (x) (vlax-ename->vla-object x))
  30.     )
  31.   )
  32.   (setq tmat1 (vlax-tmatrix (gxl-Mat-TranslateBy2P midpt1 midpt2)))
  33.   (mapcar '(lambda (x) (vla-TransformBy x tmat1)) SourceObjs1)
  34.   (setq tmat2 (vlax-tmatrix (gxl-Mat-TranslateBy2P midpt2 midpt1)))
  35.   (mapcar '(lambda (x) (vla-TransformBy x tmat2)) SourceObjs2)
  36.   (setvar "OSMODE" os)
  37.   (vl-cmdf "_undo" "e")
  38.   (princ)
  39. )
  40. ;;;======================================
  41. ;;;===========以下为内裤部分=============
  42. ;;;======================================
  43. (defun LM:MinBoundingBox ( ss pr / an ba bb bm cn cv i l mb )
  44.   (if ss
  45.     (progn
  46.       (setq bb
  47.         (LM:ListBoundingBox
  48.           (repeat (setq i (sslength ss))
  49.             (setq l (cons (vla-copy (vlax-ename->vla-object (ssname ss (setq i (1- i))))) l))
  50.           )
  51.         )
  52.       )
  53.       (setq pr (* pr pi)
  54.         cn (apply 'mapcar (cons (function (lambda ( a b ) (/ (+ a b) 2.0))) bb))
  55.         cv (vlax-3D-point cn)
  56.         bm (* (- (caadr bb) (caar bb)) (- (cadadr bb) (cadar bb)))
  57.         mb (cons 0.0 bb)
  58.         an 0
  59.       )
  60.       (while (< (setq an (+ an pr)) pi)
  61.         (foreach x l (vla-rotate x cv pr))
  62.         (setq bb (LM:ListBoundingBox l)
  63.           ba (* (- (caadr bb) (caar bb)) (- (cadadr bb) (cadar bb)))
  64.         )
  65.         (if (< ba bm) (setq bm ba mb (cons an bb)))
  66.       )
  67.       (foreach x l (vla-delete x))
  68.       (LM:RotatePointsByMatrix
  69.         (mapcar
  70.           (function
  71.             (lambda ( a )
  72.               (mapcar (function (lambda ( b ) ((eval b) (cdr mb)))) a)
  73.             )
  74.           )
  75.           '((caar cadar) (caadr cadar) (caadr cadadr) (caar cadadr))
  76.         )
  77.         cn (- (car mb))
  78.       )
  79.     )
  80.   )
  81. )
  82. (defun sf-midpt (pt1 pt2)
  83.   (mapcar '(lambda (x) (/ x 2)) (mapcar '+ pt1 pt2))
  84. )
  85. (defun gxl-Sel-Mapcar (ss Fun / nn rtn)
  86.   (if ss
  87.     (repeat (setq nn (sslength ss))
  88.       (setq rtn
  89.         (cons (apply Fun (list (ssname ss (setq nn (1- nn))))) rtn)
  90.       )
  91.     )
  92.   )
  93. )
  94. (defun gxl-Mat-TranslateBy2P ( p1 p2 )
  95.   (gxl-Mat-Translation (mapcar '- p2 p1))
  96. )
  97. (defun LM:ListBoundingBox ( lst / l1 l2 ll ur )
  98.   (foreach obj lst
  99.     (vla-getboundingbox obj 'll 'ur)
  100.     (setq l1 (cons (vlax-safearray->list ll) l1)
  101.       l2 (cons (vlax-safearray->list ur) l2)
  102.     )
  103.   )
  104.   (mapcar
  105.     (function (lambda ( a b ) (apply 'mapcar (cons a b))))
  106.     '(min max) (list l1 l2)
  107.   )
  108. )
  109. (defun LM:RotatePointsByMatrix ( l p a / m )
  110.   (setq m
  111.     (list
  112.       (list (cos a) (sin (- a)) 0.0)
  113.       (list (sin a) (cos a)     0.0)
  114.       (list   0.0     0.0       1.0)
  115.     )
  116.   )
  117.   (setq p (mapcar '- p (mxv m p)))
  118.   (mapcar (function (lambda ( x ) (mapcar '+ (mxv m x) p))) l)
  119. )
  120. (defun gxl-Mat-Translation ( v )
  121.   (list
  122.     (list 1. 0. 0. (car v))
  123.     (list 0. 1. 0. (cadr v))
  124.     (list 0. 0. 1. (caddr v))
  125.     (list 0. 0. 0. 1.)
  126.   )
  127. )
  128. (defun mxv ( m v )
  129.   (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
  130. )


回复 支持 2 反对 0

使用道具 举报

 楼主| 发表于 2018-11-6 19:04:21 | 显示全部楼层
bai0379 发表于 2018-11-6 18:57
选择一个图元,再选择一个需要被替换的图元样板,框选范围内所有和将被替换的图元相同的东西,全替换成第一 ...

这个是应用在什么场景下呢?
而且,程序如何知道什么是相同的图元?因为框选的都是选择集,而非单个的图元哦
 楼主| 发表于 2018-11-5 08:42:24 | 显示全部楼层
ssyfeng 发表于 2018-11-5 08:33
试试这个行不行:

太谢谢您了,正是我想要的效果
发表于 2018-11-5 11:46:42 | 显示全部楼层
谢谢! ssyfeng 分享实用程序!!!!!
 楼主| 发表于 2018-11-5 12:40:01 | 显示全部楼层
yoyoho 发表于 2018-11-5 11:46
谢谢! ssyfeng 分享实用程序!!!!!

我一直认为明经通道比晓东论坛气氛更好一些,学术氛围更浓厚,大家相互之间都会无私地帮助其他人。
像我这种lisp菜鸟,求过好几次源代码,问题基本都能解决,十分感激。
发表于 2018-11-5 12:43:14 | 显示全部楼层
20060510412 发表于 2018-11-5 12:40
我一直认为明经通道比晓东论坛气氛更好一些,学术氛围更浓厚,大家相互之间都会无私地帮助其他人。
像我 ...

是的 晓东论坛 我现在基本不去 它上面其实也有不少好的程序 但是都需要安装晓东工具箱 局限性比较大
 楼主| 发表于 2018-11-5 12:54:15 | 显示全部楼层
依然小小鸟 发表于 2018-11-5 12:43
是的 晓东论坛 我现在基本不去 它上面其实也有不少好的程序 但是都需要安装晓东工具箱 局限性比较大

对,受制于人的感觉,很不爽。
如果函数库升级了,是不是还得去跟着升级,多累。
发表于 2018-11-5 22:00:49 | 显示全部楼层
能不能改下:框选查找替换相同的图元?
发表于 2018-11-6 08:34:59 | 显示全部楼层
bai0379 发表于 2018-11-5 22:00
能不能改下:框选查找替换相同的图元?

希望能支持框选
 楼主| 发表于 2018-11-6 08:39:33 | 显示全部楼层
就是框选的啊,您所指的框选是什么意思呢
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-11-25 11:55 , Processed in 0.179896 second(s), 28 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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