[编程交流] 仅偏移clo的一部分

(defun C:RRM008 (/ ang coords elist midp offsetted offsetted1 ofpt p1 p2 p3 pline side SUCE SUOM SUSM SUAB SUAD SUCL SUCR)
(setq SUCE (getvar "cmdecho"))
 (setq SUOM (getvar "orthomode"))
 (setq SUSM (getvar "osmode"))
 (setq SUAB (getvar "angbase"))
 (setq SUAD (getvar "angdir"))
 (setq SUCL (getvar "clayer"))
 (setq SUCR (getvar "cecolor"))
;(command "_.-layer" "_N" "CCC_LAYOUT_Proposed_Road_Lining_Yellow_RRM008" "_C" "2" "CCC_LAYOUT_Proposed_Road_Lining_Yellow_RRM008" "" )
(setq vl1 (list
        (cons 0 "LAYER")                ;Name of entity
        (cons 100 "AcDbSymbolTableRecord")                                        ;Open Records
        (cons 100 "AcDbLayerTableRecord")                                        ;Locate Layer Table
        (cons 2 "CCC_LAYOUT_Proposed_Road_Lining_Yellow_RRM008")                ;Name of Layer
        (cons 6 "Continuous")                                                ;Linetype
        (cons 62 2)                                                        ;colour = light grey
        (cons 70 0)                                                        ;state
        (cons 290 1)                                                        ;1=plot, 0=Don't plot
                )                                                        ;End of entity list
        )
        (entmake vl1)
(setvar "clayer" "CCC_LAYOUT_Proposed_Road_Lining_Yellow_RRM008")  
(command "._-linetype"  "s"  "bylayer" "")
(setvar "cecolor" "1")
(initget "D S")
(setq option (getkword "\nChoose Draw line or Select line method: [D/S]: "))
(cond     ((= option "D")(yellow_draw_01))
((= option "S")(yellow_select_01))
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun yellow_select_01 ()
(setq pline(entsel "\nSelect a kerb line: "))
(yellow_resume)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun yellow_draw_01 ()
(princ "\nDraw a kerb line: ")
(setvar "cecolor" "1")  
(command "._pline")
(while (= 1 (logand 1 (getvar "cmdactive")))
(command pause))
(setq pline (entlast)
elist (entget pline)
)
(setvar "cecolor" "Bylayer") 
(yellow_resume)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun yellow_resume ()
(setq side(getpoint "\nPick an offset side: "))
(command "._offset" 0.3 pline side "")
(setq offsetted (entlast)
elist (entget offsetted)
)
(entmod elist)
(command "._pedit" offsetted "_W" 0.1 "")
(setq coords (vl-remove-if (function not)
(mapcar (function (lambda (x)
(if (= 10 (car x))(cdr x))))
elist))
)
(setq p2 (car coords)
midp (mapcar (function (lambda( a b)(/ (+ a b) 2)))
p1 p2)
)
(command "_change" offsetted ""  "p" "Layer" "CCC_LAYOUT_Proposed_Road_Lining_Yellow_RRM008" "color" "Bylayer" "")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(command "._offset" 0.5 pline side "")
(setq offsetted1 (entlast)
elist (entget offsetted1)
)
(entmod elist)
(command "._pedit" offsetted1 "_W" 0.1 "")
(setq coords (vl-remove-if (function not)
(mapcar (function (lambda (x)
(if (= 10 (car x))(cdr x))))
elist))
)
(setq p2 (car coords)
midp (mapcar (function (lambda( a b)(/ (+ a b) 2)))
p1 p2)
)
(command "_change" offsetted1 ""  "p" "Layer" "CCC_LAYOUT_Proposed_Road_Lining_Yellow_RRM008" "color" "Bylayer" "")
(cond     ((= option "D")(command "_erase" pline "" ))
)
 (setvar "cmdecho"   SUCE)
 (setvar "orthomode" SUOM)
 (setvar "osmode"    SUSM)
 (setvar "angbase"   SUAB)
 (setvar "angdir"    SUAD)
 (setvar "clayer"    SUCL)
 (setvar "cecolor"    SUCR)
(princ) 
)

(c:offsec)

;;------------------=={ Offset LWPolyline Section }==-------------------;;
;;                                                                      ;;
;;  This program prompts the user to specify an offset distance and to  ;;
;;  select an LWPolyline. The user is then prompted to specify two      ;;
;;  points on the LWPolyline enclosing the section to be offset. The    ;;
;;  progam will proceed to offset all segments between the two given    ;;
;;  points to both sides by the specified distance.                     ;;
;;                                                                      ;;
;;  The program is compatible with LWPolylines of constant or varying   ;;
;;  width, with straight and/or arc segments, and defined in any UCS    ;;
;;  construction plane.                                                 ;;
;;----------------------------------------------------------------------;;
;;  Author:  Lee Mac, Copyright © 2013  -  www.lee-mac.com              ;;
;;----------------------------------------------------------------------;;
;;  Version 1.0    -    27-12-2012                                      ;;
;;                                                                      ;;
;;  First release.                                                      ;;
;;----------------------------------------------------------------------;;
;;  Version 1.1    -    05-04-2013                                      ;;
;;                                                                      ;;
;;  Fixed bug when offsetting polyline arc segments.                    ;;
;;----------------------------------------------------------------------;;
;;Slightly edited By: CB (Sorry Lee-Mac)
(defun c:offsec ( / d e h l m n o p q w x z )
   (if (null *off*)
       (setq *off* 1.0)
   )
   (initget 6)
   (if (setq d (getdist (strcat "\nSpecify Offset <" (rtos *off*) ">: ")))
       (setq *off* d)
       (setq d *off*)
   )
   (while
       (progn (setvar 'errno 0) (setq e (car (entsel "\nSelect LWPolyline: ")))
           (cond
               (   (= 7 (getvar 'errno))
                   (princ "\nMissed, try again.")
               )
               (   (null e) nil)
               (   (/= "LWPOLYLINE" (cdr (assoc 0 (entget e))))
                   (princ "\nObject is not an LWPolyline.")
               )
               (   (setq p (getpoint "\nSpecify 1st Point: "))
                   (setq p (vlax-curve-getclosestpointto e (trans p 1 0)))
                   (while
                       (and
                           (setq  q (getpoint (trans p 0 1) "\nSpecify 2nd Point: "))
                           (equal p (setq q (vlax-curve-getclosestpointto e (trans q 1 0))) 1e-
                       )
                       (princ "\nPoints must be distinct.")
                   )
                   (if q
                       (progn
                           (if (> (setq m (vlax-curve-getparamatpoint e p))
                                  (setq n (vlax-curve-getparamatpoint e q))
                               )
                               (mapcar 'set '(m n p q) (list n m q p))
                           )
                           (setq e (entget e)
                                 h (reverse (member (assoc 39 e) (reverse e)))
                                 h (subst (cons 70 (logand (cdr (assoc 70 h)) (~ 1))) (assoc 70 h) h)
                                 l (LM:LWVertices e)
                                 z (assoc 210 e)
                           )
                           (repeat (fix m)
                               (setq l (cdr l))
                           )
                           (if (not (equal m (fix m) 1e-)
                               (setq x (car l)
                                     w (cdr (assoc 40 x))
                                     l
                                   (cons
                                       (list
                                           (cons  10 (trans p 0 (cdr z)))
                                           (cons  40 (+ w (* (- m (fix m)) (- (cdr (assoc 41 x)) w))))
                                           (assoc 41 x)
                                           (cons  42
                                               (tan
                                                   (*  (- (min n (1+ (fix m))) m)
                                                       (atan (cdr (assoc 42 x)))
                                                   )
                                               )
                                           )
                                       )
                                       (cdr l)
                                   )
                               )
                           )
                           (setq l (reverse l))
                           (repeat (+ (length l) (fix m) (- (fix n)) -1)
                               (setq l (cdr l))
                           )
                           (if (not (equal n (fix n) 1e-)
                               (setq x (car l)
                                     w (cdr (assoc 40 x))
                                     l
                                   (vl-list*
                                       (list
                                           (cons 10 (trans q 0 (cdr z)))
                                          '(40 . 0.0)
                                          '(41 . 0.0)
                                          '(42 . 0.0)
                                       )
                                       (list
                                           (assoc 10 x)
                                           (assoc 40 x)
                                           (cons  41
                                               (+ w
                                                   (*  (/ (- n (max m (fix n))) (- (1+ (fix n)) (max m (fix n))))
                                                       (- (cdr (assoc 41 x)) w)
                                                   )
                                               )
                                           )
                                           (cons  42
                                               (tan
                                                   (*  (if (< (fix n) m) 1.0 (- n (fix n)))
                                                       (atan (cdr (assoc 42 x)))
                                                   )
                                               )
                                           )
                                       )
                                       (cdr l)
                                   )
                               )
                           )
                           (setq o
                               (vlax-ename->vla-object
                                   (entmakex (append h (apply 'append (reverse l)) (list z)))
                               )
                           )
                           (vl-catch-all-apply 'vla-offset (list o d))
                           (vl-catch-all-apply 'vla-offset (list o (* 2 d)))
                           (vla-delete o)
                       )
                   )
               )
           )
       )
   )
   (princ)
)
;; Tangent  -  Lee Mac
;; Args: x - real
(defun tan ( x )
   (if (not (equal 0.0 (cos x) 1e-)
       (/ (sin x) (cos x))
   )
)
;; LW Vertices  -  Lee Mac
;; Returns a list of lists in which each sublist describes the position,
;; starting width, ending width and bulge of a vertex of an LWPolyline
(defun LM:LWVertices ( e )
   (if (setq e (member (assoc 10 e) e))
       (cons
           (list
               (assoc 10 e)
               (assoc 40 e)
               (assoc 41 e)
               (assoc 42 e)
           )
           (LM:LWVertices (cdr e))
       )
   )
)
;;----------------------------------------------------------------------;;
(vl-load-com)
(princ
   (strcat
       "\n:: OffsetSection.lsp | Version 1.1 | \\U+00A9 Lee Mac "
       (menucmd "m=$(edtime,0,yyyy)")
       " www.lee-mac.com ::"
       "\n:: Type "offsec" to Invoke ::"
   )
)
(princ)
;;----------------------------------------------------------------------;;
;;                             End of File                              ;;
;;----------------------------------------------------------------------;;

 ;|------------------=={ Offset LWPolyline Section }==-------------------
 This program prompts the user to specify an offset distance and to
 select an LWPolyline. The user is then prompted to specify two
 points on the LWPolyline enclosing the section to be offset. The
 progam will proceed to offset all segments between the two given
 points to both sides by the specified distance.
 The program is compatible with LWPolylines of constant or varying
 width, with straight and/or arc segments, and defined in any UCS
 construction plane.
----------------------------------------------------------------------
 Author:  Lee Mac, Copyright © 2013  -  www.lee-mac.com
----------------------------------------------------------------------
 Version 1.0    -    27-12-2012
 First release.
----------------------------------------------------------------------
 Version 1.1    -    05-04-2013
 Fixed bug when offsetting polyline arc segments.
----------------------------------------------------------------------
 Version 1.2    -    06-09-2015
 Added prompt to select side to offset.  Tom Beauford
----------------------------------------------------------------------|;
(defun c:offsec ( / d e h l m n o p q w x z )
   (if (null *off*)
       (setq *off* 1.0)
   )
   (initget 6)
   (if (setq d (getdist (strcat "\nSpecify Offset <" (rtos *off*) ">: ")))
       (setq *off* d)
       (setq d *off*)
   )
   (while
       (progn (setvar 'errno 0) (setq e (car (entsel "\nSelect LWPolyline: ")))
           (cond
               (   (= 7 (getvar 'errno))
                   (princ "\nMissed, try again.")
               )
               (   (null e) nil)
               (   (/= "LWPOLYLINE" (cdr (assoc 0 (entget e))))
                   (princ "\nObject is not an LWPolyline.")
               )
               (   (setq p (getpoint "\nSpecify 1st Point: "))
                   (setq p (vlax-curve-getclosestpointto e (trans p 1 0)))
                   (while
                       (and
                           (setq  q (getpoint (trans p 0 1) "\nSpecify 2nd Point: "))
                           (equal p (setq q (vlax-curve-getclosestpointto e (trans q 1 0))) 1e-
                       )
                       (princ "\nPoints must be distinct.")
                   )
                   (if q
                       (progn
                           (if (> (setq m (vlax-curve-getparamatpoint e p))
                                  (setq n (vlax-curve-getparamatpoint e q))
                               )
                               (mapcar 'set '(m n p q) (list n m q p))
                           )
                           (setq e (entget e)
                                 h (reverse (member (assoc 39 e) (reverse e)))
                                 h (subst (cons 70 (logand (cdr (assoc 70 h)) (~ 1))) (assoc 70 h) h)
                                 l (LM:LWVertices e)
                                 z (assoc 210 e)
                           )
                           (repeat (fix m)
                               (setq l (cdr l))
                           )
                           (if (not (equal m (fix m) 1e-)
                               (setq x (car l)
                                     w (cdr (assoc 40 x))
                                     l
                                   (cons
                                       (list
                                           (cons  10 (trans p 0 (cdr z)))
                                           (cons  40 (+ w (* (- m (fix m)) (- (cdr (assoc 41 x)) w))))
                                           (assoc 41 x)
                                           (cons  42
                                               (tan
                                                   (*  (- (min n (1+ (fix m))) m)
                                                       (atan (cdr (assoc 42 x)))
                                                   )
                                               )
                                           )
                                       )
                                       (cdr l)
                                   )
                               )
                           )
                           (setq l (reverse l))
                           (repeat (+ (length l) (fix m) (- (fix n)) -1)
                               (setq l (cdr l))
                           )
                           (if (not (equal n (fix n) 1e-)
                               (setq x (car l)
                                     w (cdr (assoc 40 x))
                                     l
                                   (vl-list*
                                       (list
                                           (cons 10 (trans q 0 (cdr z)))
                                          '(40 . 0.0)
                                          '(41 . 0.0)
                                          '(42 . 0.0)
                                       )
                                       (list
                                           (assoc 10 x)
                                           (assoc 40 x)
                                           (cons  41
                                               (+ w
                                                   (*  (/ (- n (max m (fix n))) (- (1+ (fix n)) (max m (fix n))))
                                                       (- (cdr (assoc 41 x)) w)
                                                   )
                                               )
                                           )
                                           (cons  42
                                               (tan
                                                   (*  (if (< (fix n) m) 1.0 (- n (fix n)))
                                                       (atan (cdr (assoc 42 x)))
                                                   )
                                               )
                                           )
                                       )
                                       (cdr l)
                                   )
                               )
                           )
                           (setq p (getpoint "Specify point on side to offset or Enter for both: ")
                                   o (vlax-ename->vla-object(entmakex (append h (apply 'append (reverse l)) (list z))))
                                   ename (vlax-vla-object->ename o)
                           )
                           (if p
                             (progn
                               (princ "\nPoint selected!")
                               (command "_.offset" d ename p "")
                               (entdel ename)
                             )
                             (progn
                               (princ "\nPoint NOT selected!")
;                                (vlax-ename->vla-object o)
;                                (setq o (vlax-ename->vla-object(entmakex (append h (apply 'append (reverse l)) (list z)))))
                               (vl-catch-all-apply 'vla-offset (list o d))
                               (vl-catch-all-apply 'vla-offset (list o (- d)))
                               (vla-delete o)
                             )
                         )
                       )
                   )
               )
           )
       )
   )
   (princ)
)
;; Tangent  -  Lee Mac
;; Args: x - real
(defun tan ( x )
   (if (not (equal 0.0 (cos x) 1e-)
       (/ (sin x) (cos x))
   )
)
;; LW Vertices  -  Lee Mac
;; Returns a list of lists in which each sublist describes the position,
;; starting width, ending width and bulge of a vertex of an LWPolyline
(defun LM:LWVertices ( e )
   (if (setq e (member (assoc 10 e) e))
       (cons
           (list
               (assoc 10 e)
               (assoc 40 e)
               (assoc 41 e)
               (assoc 42 e)
           )
           (LM:LWVertices (cdr e))
       )
   )
)
;;----------------------------------------------------------------------;;
(vl-load-com)
(princ
   (strcat
       "\n:: OffsetSection.lsp | Version 1.1 | \\U+00A9 Lee Mac "
       (menucmd "m=$(edtime,0,yyyy)")
       " www.lee-mac.com ::"
       "\n:: Type "offsec" to Invoke ::"
   )
)
(princ)
;;----------------------------------------------------------------------;;
;;                             End of File                              ;;
;;----------------------------------------------------------------------;;