wxa123wl 发表于 2014-8-7 22:27:20

求一个改进的移动拉伸命令

本帖最后由 wxa123wl 于 2014-8-7 22:32 编辑

工作中很多时候需要把很多图对齐与一条线，大概如图的工作过程，所以希望大神些一个，，先选择一条线，然后框选对象，再指定对象上的一点，就可以以这点垂直移动到线上！，还有拉伸，，

lyqiezi 发表于 2014-8-7 22:27:21

本帖最后由 lyqiezi 于 2014-8-12 00:56 编辑

刚发现需要连续执行，改进如下

(vl-load-com)
(defun c:t1( / e1 ss pt1 obj pt2)
    (setq e1 (cdr (assoc -1 (entget (car (entsel "\n select line:"))))))
    (while(setq ss (ssget))
    (setq pt1 (getpoint "\对齐点:"))
    (setq obj (vlax-ename->vla-object e1))
    (setq pt2 (vlax-curve-getClosestPointTo obj pt1 T));求垂足
    (command "move" ss "" pt1 pt2)
    )
   
)

对应一条直线，只需要点一次，后面只要选对齐的物体就可以了

lyqiezi 发表于 2014-8-12 00:51:34

(vl-load-com)
(defun c:t1( / e1 ss pt1 obj pt2)
    (setq e1 (cdr (assoc -1 (entget (car (entsel "\n select line:"))))))
    (setq ss (ssget))
    (setq pt1 (getpoint "\对齐点:"))
    (setq obj (vlax-ename->vla-object e1))
    (setq pt2 (vlax-curve-getClosestPointTo obj pt1 T));求垂足
    (command "move" ss "" pt1 pt2)
   
)

试一下，拉伸的我没弄出来，不知道什么地方有问题

lyqiezi 发表于 2014-8-12 01:05:36

(defun c:t2( / e1 ss pt1 obj pt2)
    (setq e1 (cdr (assoc -1 (entget (car (entsel "\n select line:"))))))
    (while(setq ss (ssget))
    (setq pt1 (getpoint "\对齐点:"))
    (setq obj (vlax-ename->vla-object e1))
    (setq pt2 (vlax-curve-getClosestPointTo obj pt1 T));求垂足
    (command "stretch" ss "" pt1 pt2)

    )
   
)
拉伸的，不知道怎么回事，从别的程序复制粘贴命令过来就可以，没觉得跟开始的有什么不同

断箭 发表于 2018-4-23 13:53:24

lyqiezi 发表于 2014-8-7 22:27
刚发现需要连续执行，改进如下

(vl-load-com)


这个小程序对我很有用，谢谢啦

1152213153 发表于 2018-5-14 13:12:54

跪看大神们交流

sdls 发表于 2019-3-23 23:37:38

感谢楼上的大神们分享！谢谢
页: [1]
查看完整版本: 求一个改进的移动拉伸命令