论坛 › A/VLISP › 超级OFFSET，能偏移块，XREF里面的曲线

Lisphk 发表于 2017-7-21 12:03:47

超级OFFSET，能偏移块，XREF里面的曲线

(defun c:OffsetNested (/ *error* AT:GetSel dist ent new)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; SUBROUTINES ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun *error* (msg)
    (and ent (redraw (car ent) 4))
    (and new (entdel new))
    (and cmd (setvar 'CMDECHO cmd))
    (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,")))
      (progn (vl-bt) (princ (strcat "\nError: " msg)))
    )
)


(defun AT:GetSel (meth msg fnc / ent)
    ;; meth - selection method (entsel, nentsel, nentselp)
    ;; msg - message to display (nil for default)
    ;; fnc - optional function to apply to selected object
    ;; Ex: (AT:GetSel entsel "\nSelect arc: " (lambda (x) (eq (cdr (assoc 0 (entget (car x)))) "ARC")))
    ;; Alan J. Thompson, 05.25.10
    (while
      (progn (setvar 'ERRNO 0)
             (setq ent (meth (cond (msg)
                                 ("\nSelect object: ")
                           )
                     )
             )
             (cond ((eq (getvar 'ERRNO) 7) (princ "\nMissed, try again."))
                   ((eq (type (car ent)) 'ENAME)
                  (if (and fnc (not (fnc ent)))
                      (princ "\nInvalid object!")
                  )
                   )
             )
      )
    )
    ent
)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MAIN ROUTINE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(initget 6 "Through")
(setq dist (getdist (strcat "\nOffset Nested\nSpecify offset distance or <"
                              (if (minusp (getvar 'OFFSETDIST))
                              "Through"
                              (rtos (getvar 'OFFSETDIST))
                              )
                              ">: "
                      )
             )
)

(cond ((not dist))
      ((eq (getvar 'OFFSETDIST) dist))
      ((eq dist "Through") (setvar 'OFFSETDIST -1.))
      ((setvar 'OFFSETDIST dist))
)

(if (and (setq ent (AT:GetSel nentselp
                              "\nSelect object to offset: "
                              (lambda (x)
                                  (member (cdr (assoc 0 (entget (car x))))
                                          '("ARC" "CIRCLE" "ELLIPSE" "LINE" "LWPOLYLINE" "SPLINE")
                                  )
                              )
                     )
         )
         (progn
             (if (eq (length ent) 4)
               (progn (setq new (entmakex
                                  (subst (cons 8 (getvar 'CLAYER))
                                       (assoc 8 (entget (car ent)))
                                       (entget (car ent))
                                  )
                              )
                      )
                      (vla-transformby (vlax-ename->vla-object new) (vlax-tmatrix (caddr ent)))
                      (setq ent (list new (cadr ent)))
               )
             )

             (redraw (car ent) 3)

             (setq pnt (getpoint (cadr ent)
                                 (if (minusp (getvar 'OFFSETDIST))
                                 "\nSpecify through point: "
                                 "\nSpecify point on side to offset: "
                                 )
                     )
             )
         )
      )

    (command "_.offset" "" ent "_non" pnt "")
)

(*error* nil)

(princ)
)
(vl-load-com)
(princ)


**** Hidden Message *****

laiz3000 发表于 2017-7-21 12:37:33

{:1_1:}好高级

q3_2006 发表于 2017-7-21 12:46:25

这个厉害了..

yoyoho 发表于 2017-7-21 13:01:30

感谢分享程序！

SmartStar 发表于 2017-7-21 14:48:32

看看隐藏了什么{:1_12:}

434939575 发表于 2017-7-21 14:57:02

来学习的，路太漫长了！

sunshinejwt 发表于 2017-7-21 15:03:14

看看隐藏了什么

HLCAD 发表于 2017-7-21 15:12:48

太实用了，感谢楼主的源代码！

qyming1996 发表于 2017-7-21 15:19:59

学习，学习，学习

819534890 发表于 2017-7-21 16:29:40

回复学习是个好习惯

Linhay 发表于 2017-7-21 16:52:46

马后再看                  

xchj81 发表于 2017-7-21 17:16:42

找了好久。谢谢

sicky111 发表于 2017-7-22 00:40:17

看标题高大上啊。

xinxirong 发表于 2017-7-22 06:09:43

吧，也行呀？吃了饭**形象代言人

ray7891 发表于 2017-7-22 12:29:41

块解决？{:1_6:}{:1_6:}{:1_6:}{:1_6:}

查看完整版本: 超级OFFSET，能偏移块，XREF里面的曲线