[编程交流] Offset LISP例程只需要

(defun C:OFF2  (/ pickEnt pickObj offDist)
(vl-load-com)
(setvar "ErrNo" 0)
(while (and (not (setq pickEnt (entsel))) (/= 52 (getvar "ErrNo"))))
(cond ((and pickEnt
            (setq pickObj (vlax-EName->vla-Object (car pickEnt)))
            (progn (initget 6)
                   (setq offDist (getdist "\nSpecify offset distance: "))))
       (vla-Offset pickObj offDist)
       (vla-Offset pickObj (- offDist))
       (I:PutCL pickObj)))
(princ))
(defun I:PutCL  (myObj / linetypes ltName)
(setq linetypes (vla-Get-Linetypes (vla-Get-Document myObj))
      ltName    "Center")
(cond ((vl-catch-all-error-p
        (vl-catch-all-apply 'vla-Item (list linetypes ltName)))
       (vla-Load linetypes
                 ltName
                 (cond ((= (getvar "Measurement") 0) "Acad.lin")
                       ("AcadISO.lin")))))
(vla-Put-Linetype myObj ltName))

(defun C:OFF2 (/ pickEnt pickObj offDist)
 (vl-load-com)
[color="red"] (setq offDist(ureal 6 "" "\nSpecify offset distance: " 0.812))[/color]
 (while (setq pickEnt (entsel))
   (cond ((and pickEnt (setq pickObj (vlax-EName->vla-Object (car pickEnt))) offDist)
   (vla-Offset pickObj offDist)
   (vla-Offset pickObj (- offDist))
   (I:PutCL pickObj)
   )
  ) ;_ end of cond
   ) ;_ end of while
 (princ)
 ) ;_ end of defun
(defun I:PutCL (myObj / linetypes ltName)
 (setq        linetypes (vla-Get-Linetypes (vla-Get-Document myObj))
ltName          "Center"
) ;_ end of setq
 (cond        ((vl-catch-all-error-p (vl-catch-all-apply 'vla-Item (list linetypes ltName)))
 (vla-Load linetypes
           ltName
           (cond ((= (getvar "Measurement") 0) "Acad.lin")
                 ("AcadISO.lin")
                 ) ;_ end of cond
           ) ;_ end of vla-Load
 )
) ;_ end of cond
 (vla-Put-Linetype myObj ltName)
 ) ;_ end of defun
;;;-------------------------------------------------------------------
;; This function is freeware courtesy of the author's of "Inside AutoLisp"
;; for rel. 10 published by New Riders Publications.  This credit must
;; accompany all copies of this function.
;;* UKWORD User key word. DEF, if any, must match one of the KWD strings
;;* BIT (1 for no null, 0 for none) and KWD key word ("" for none) are same as
;;* for INITGET. MSG is the prompt string, to which a default string is added
;;* as <DEF> (nil or "" for none), and a : is added.
(defun UREAL (bit kwd msg def / inp)
 (if def
   (setq msg (strcat "\n" msg " <" (rtos def 2) "> : ")
         bit (* 2 (fix (/ bit 2)))
         )
   (setq msg (strcat "\n" msg " : "))
   )                                   ;if
 (initget bit kwd)
 (setq inp (getdist msg))
 (if inp inp def)
 )   

;;;http://www.cadtutor.net/forum/showthread.php?88082-Offset-LISP-Routine-just-needs-small-update.-Thanks!
(if (not [color="red"]*offDist*[/color])
 (setq *offDist* 0.812)
 ) ;_ end of if
(defun C:OFF2 (/ pickEnt pickObj offDist ss)
 (vl-load-com)
 (setvar "ErrNo" 0)
 (setq offDist (ureal 6 "Multiple" "\nSpecify offset distance or [Multiple] : " *offDist*)) ; _ end of
; setq
 (if (= offDist "Multiple")
   (progn (setq offDist   (ureal 6 "" "\nSpecify offset distance: " *offDist*)
         *offDist* offDist
         ) ;_ end of setq
   (prompt "\nSelect object.. ")
   (setq ss (ssget))
   (foreach en (vl-remove-if ''((x) (listp x)) (mapcar 'cadr (ssnamex ss))) ;_ end of vl-remove-if
     ([color="blue"]offset2: [/color]en offDist [color="red"](getvar "clayer")[/color])
     ) ;_ end of foreach
   ) ;_ end of progn
   (while (setq pickEnt (entsel))
     ([color="blue"]offset2:[/color] (car pickEnt) offDist [color="red"](getvar "clayer")[/color])
     (setq *offDist* offDist)
     ) ; _ end of
; while
   ) ;_ end of if
 (princ)
 ) ;_ end of defun
; modified by hanhphuc* 09/08/2014
(defun [color="blue"]offset2:[/color]        (e off lay / obj)
 (if (and e
   off
   (= (type lay) 'STR)
   (tblsearch "Layer" lay)
   (member (vla-get-objectname (setq obj (vlax-EName->vla-Object e)))
           '("AcDbCircle" "AcDbArc" "AcDbPolyline" "AcDbLine" "AcDbEllipse" "AcDbSpline")
           ) ;_ end of member
   ) ;_ end of and
   (progn (foreach o (list (vla-Offset obj off) (vla-Offset obj (- off)))
     (vla-put-layer (car (vlax-safearray->list (vlax-variant-value o))) lay)
     ) ;_ end of foreach
   (I:PutCL obj)
   ) ;_ end of progn
   ) ;_ end of if
 ) ;_ end of defun
(defun I:PutCL (myObj / linetypes ltName)
 (setq        linetypes (vla-Get-Linetypes (vla-Get-Document myObj))
ltName          "Center"
) ;_ end of setq
 (cond        ((vl-catch-all-error-p (vl-catch-all-apply 'vla-Item (list linetypes ltName)))
 (vla-Load linetypes
           ltName
           (cond ((= (getvar "Measurement") 0) "Acad.lin")
                 ("AcadISO.lin")
                 ) ;_ end of cond
           ) ;_ end of vla-Load
 )
) ;_ end of cond
 (vla-Put-Linetype myObj ltName)
 ) ;_ end of defun
;;;-------------------------------------------------------------------
;; This function is freeware courtesy of the author's of "Inside AutoLisp"
;; for rel. 10 published by New Riders Publications.  This credit must
;; accompany all copies of this function.
;;* UKWORD User key word. DEF, if any, must match one of the KWD strings
;;* BIT (1 for no null, 0 for none) and KWD key word ("" for none) are same as
;;* for INITGET. MSG is the prompt string, to which a default string is added
;;* as <DEF> (nil or "" for none), and a : is added.
(defun UREAL (bit kwd msg def / inp)
 (if def
   (setq msg (strcat "\n" msg " <" (rtos def 2) "> : ")
         bit (* 2 (fix (/ bit 2)))
         )
   (setq msg (strcat "\n" msg " : "))
   )                                   ;if
 (initget bit kwd)
 (setq inp (getdist msg))
 (if inp inp def)
 )