直线变矩形源码

长风（尚品） 发表于 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)
)

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

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

页: [1] 2 3

明经CAD社区's Archiver

直线变矩形源码