直线变矩形源码

长风（尚品） · 发表于 2012-12-21 08:54:30

以下代码是将直线变为矩形，但只能点选和单选，那位高手能帮忙改为多选和框选。谢谢
;; 直线变矩形
(defun c:b1()
  (setvar "osmode" 0)
  (setq ww (getreal "\n请输入宽度: "))
  (prompt "\n框选欲变矩形的直线: ")
  (setq ss (ssget '((0 . "LINE")))
      d  (* ww 0.5)
         i  -1
  )
  (while (setq s1 (ssname ss (setq i (1+ i))))
(setq p1 (vlax-curve-getstartPoint s1)
      p2 (vlax-curve-getendPoint s1)
      r  (+ (angle p1 p2) (* pi 0.5))
)
(command "pline" (polar p1 r (- d)) (polar p2 r (- d)) (polar p2 r d) (polar p1 r d) "c")
  )
  (princ)
)

1028695446 · 发表于 2019-11-2 00:25:25

本帖最后由 1028695446 于 2019-11-2 00:27 编辑

ketxu 发表于 2019-11-1 11:30
Put (vl-load-com) at top or bottom of lisp ^^

我把他改成动态的了

(vl-load-com)
(defun c:rex ( / ss i e pts ob del-e a aa mouse elast)
(setq pac (getvar 'peditaccept))
(setvar 'peditaccept 1)
;(if (not width) (setq width 1.00))
;(setq width (cond
; ((getdist(strcat "\nEnter Width <"(rtos width 2 2)">: ")))
; (width)
; )
;)
(setq del-e nil)
(if (and
(setq ss (ssget ":E:S" '((0 . "LWPOLYLINE,LINE"))))
(setq pt0(getpoint "\n指定第一点:"))
;(setq pt0 (cadr(car(cdddar(ssnamex ss 0)))))
)
(progn
(setq elast(entlast))
(setq loop T)
(while loop
(setq mouse (grread T 12 0))
(setq a (car mouse) aa (cadr mouse))
(cond
((= a 5)
(redraw)
;(if (= elast(entlast))(princ)(entdel (entlast)))
(if del-e(entdel del-e)(princ))
(grdraw pt0 aa 1);画向量
(setq width(distance pt0 aa))
(if (> width 0.001)
(progn
(setq i 0)
(repeat (setq i (sslength ss))
(setq e (ssname ss (Setq i (1- i))) sss (ssadd))
(setq pts (mapcar
'(lambda (y)
(list (vlax-curve-getStartPoint y)
(vlax-curve-getEndPoint y)
)
)
(mapcar 'car
(mapcar
'(lambda (x)
(setq ob (vlax-invoke
(vlax-ename->vla-object e)
'Offset
x
)
)
(ssadd (entlast) sss)
ob
)
(list (setq h (* 0.5 width))
(- h)
)
)
)
)
)
(mapcar '(lambda (k l)
(entmakex (list (cons 0 "LINE") (cons 10 k) (cons 11 l)))
(ssadd (entlast) sss)
)
(car pts)(cadr pts)
)
(command "_.pedit" "_m" sss "" "_j" 0.0 "")
(setq del-e (entlast))
;(entdel e)
)
)
)
) ;;; 鼠标移动
( (or (= 25 a) (= 11 a) ;右键
(and (= a 2) (= aa 13));回车
(and (= a 2) (= aa 32));或空格
(= a 3);鼠标左键
)
(setq loop nil)
)
)
)
)
)
(redraw)
(setvar 'peditaccept pac)
(princ)
)

(vl-load-com) 
(defun c:rex ( /  ss i e pts ob del-e a aa mouse elast) 
  (setq pac (getvar 'peditaccept)) 
  (setvar 'peditaccept 1) 
  ;(if (not width) (setq width 1.00)) 
  ;(setq width (cond 
  ;              ((getdist(strcat "\nEnter Width <"(rtos width 2 2)">: "))) 
  ;              (width) 
  ;            ) 
  ;) 
  (setq del-e nil) 
  (if (and 
        (setq ss (ssget ":E:S" '((0 . "LWPOLYLINE,LINE")))) 
        (setq pt0(getpoint "\n指定第一点:")) 
        ;(setq pt0 (cadr(car(cdddar(ssnamex ss 0)))))         
      ) 
    (progn 
      (setq elast(entlast)) 
      (setq loop T) 
      (while loop 
        (setq mouse (grread T 12 0)) 
        (setq a (car mouse) aa (cadr mouse)) 
        (cond 
          ((= a 5) 
            (redraw) 
            ;(if (= elast(entlast))(princ)(entdel (entlast))) 
            (if del-e(entdel del-e)(princ)) 
            (grdraw pt0 aa 1);画向量 
            (setq width(distance pt0 aa)) 
            (if (> width 0.001) 
              (progn 
                (setq i 0) 
                (repeat (setq i (sslength ss)) 
                  (setq e (ssname ss (Setq i (1- i))) sss (ssadd)) 
                  (setq pts (mapcar 
                              '(lambda (y) 
                                 (list (vlax-curve-getStartPoint y) 
                                   (vlax-curve-getEndPoint y) 
                                 ) 
                               ) 
                              (mapcar 'car 
                                (mapcar 
                                  '(lambda (x) 
                                     (setq ob (vlax-invoke 
                                                (vlax-ename->vla-object e) 
                                                'Offset 
                                                x 
                                              ) 
                                     ) 
                                     (ssadd (entlast) sss) 
                                     ob 
                                   ) 
                                  (list (setq h (* 0.5 width)) 
                                    (- h) 
                                  ) 
                                ) 
                              ) 
                            ) 
                  ) 
                  (mapcar '(lambda (k l) 
                             (entmakex (list (cons 0 "LINE") (cons 10 k) (cons 11 l))) 
                             (ssadd (entlast) sss) 
                           ) 
                    (car pts)(cadr pts) 
                  ) 
                  (command "_.pedit" "_m" sss ""  "_j" 0.0 "") 
                  (setq del-e (entlast)) 
                  ;(entdel e) 
                ) 
              ) 
            ) 
          )            ;;; 鼠标移动 
          ( (or (= 25 a) (= 11 a) ;右键 
              (and (= a 2) (= aa 13));回车 
              (and (= a 2) (= aa 32));或空格 
              (= a 3);鼠标左键 
            ) 
            (setq loop nil) 
          ) 
        ) 
      ) 
    ) 
  ) 
  (redraw) 
  (setvar 'peditaccept pac) 
  (princ) 
)

ketxu · 发表于 2019-11-1 11:30:50

yubihai 发表于 2019-10-7 08:39
在2010及以上版本不可用，提示：错误: no function definition: VLAX-CURVE-GETSTARTPOINT

Put (vl-load-com) at top or bottom of lisp ^^

yubihai · 发表于 2019-10-7 08:39:16

在2010及以上版本不可用，提示：错误: no function definition: VLAX-CURVE-GETSTARTPOINT

yoyoho · 发表于 2012-12-21 09:03:48

程序本身就能多选了啊!

zyhandw · 发表于 2012-12-21 10:18:55

用起来不错，感谢分享

咖啡走糖 · 发表于 2012-12-21 11:59:07

太棒了.感谢楼主分享的程序拉.~!太实用拉.

清风明月名字 · 发表于 2013-6-29 12:02:49

谢谢楼主分享，辛苦了！

林小林子 · 发表于 2018-8-27 19:41:27

用了之后对象捕捉就要重新勾选？？？？

ynhh · 发表于 2019-3-18 09:24:47

这是以现有直线为中线画矩形
谢谢你
还以为是对角线改矩形啊

szd112 · 发表于 2019-8-6 10:21:47

用起来不错，感谢分享

happy336 · 发表于 2019-8-13 20:01:28

谢谢分享，支持

水仙的错 · 发表于 2019-9-11 23:41:07

如果直线不在中心位置就好了，以一边为准

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