[编程交流] 沿多段线复制？

(vl-load-com)
(defun c:copysquarealongpline ( / osm a +a -a ss pl stpt enpt loop ptint d )
 (setq osm (getvar 'osmode))
 (setvar 'osmode 0)
 (setq a (getdist "\nDimension of edge of square : "))
 (setq +a a)
 (setq -a (- a))
 (while (not ss)
   (prompt "\nSelect 2d polyline witch vertices are oriented from left to right to perform copym of square along it")
   (setq ss (ssget ":L" '((0 . "*POLYLINE"))))
 )
 (setq pl (ssname ss 0))
 (setq stpt (vlax-curve-getstartpoint pl))
 (setq enpt (vlax-curve-getendpoint pl))
 (if (> (cadr stpt) (cadr enpt))
   (progn
     (setq loop T)
     (while loop
       (setq ptint (vlax-curve-getclosestpointtoprojection pl (list (car stpt) (+ (cadr stpt) a) (caddr stpt)) '(1.0 0.0 0.0)))
       (setq d (- (car ptint) (car stpt)))
       (if (not (eq a -a))
         (vl-cmdf "_.rectangle" stpt "d" +a +a (list (+ (car stpt) 1.0) (+ (cadr stpt) 1.0) (caddr stpt)))
         (vl-cmdf "_.rectangle" stpt "d" +a +a (list (+ (car stpt) 1.0) (- (cadr stpt) 1.0) (caddr stpt)))
       )
       (if ptint
         (repeat (fix (/ d +a))
           (vl-cmdf "_.copy" (entlast) "" '(0.0 0.0 0.0) (list +a 0.0 0.0) "")
         )
       )
       (if (eq a +a)
         (if (eq (cadr ptint) (+ (cadr stpt) a)) 
           (setq stpt ptint) 
           (progn
             (vl-cmdf "_.pedit" pl "r" "")
             (setq ptint nil a 0.0)
           )
         )
       )
       (if (eq a 0.0)
         (if (eq (cadr ptint) (cadr stpt))
           (setq stpt ptint a -a)
         ) 
       )
       (if (and (not (equal stpt ptint 1e-) (eq a -a))
         (progn
           (if (equal ptint enpt 1e-
             (progn 
               (setq d (- (car enpt) (car stpt)))
               (setq loop nil)
             )
           )
           (if (eq (cadr ptint) (+ (cadr stpt) a))
             (setq stpt ptint)
           )
         )
       )
     )
     (vl-cmdf "_.pedit" pl "r" "")
   )
   (progn
     (vl-cmdf "_.pedit" pl "r" "")
     (setq stpt (vlax-curve-getstartpoint pl))
     (setq enpt (vlax-curve-getendpoint pl))
     (setq loop T)
     (while loop
       (setq ptint (vlax-curve-getclosestpointtoprojection pl (list (car stpt) (+ (cadr stpt) a) (caddr stpt)) '(1.0 0.0 0.0)))
       (setq d (- (- (car ptint) (car stpt))))
       (if (not (eq a -a))
         (vl-cmdf "_.rectangle" stpt "d" +a +a (list (- (car stpt) 1.0) (+ (cadr stpt) 1.0) (caddr stpt)))
         (vl-cmdf "_.rectangle" stpt "d" +a +a (list (- (car stpt) 1.0) (- (cadr stpt) 1.0) (caddr stpt)))
       )
       (if ptint
         (repeat (fix (/ d +a))
           (vl-cmdf "_.copy" (entlast) "" '(0.0 0.0 0.0) (list -a 0.0 0.0) "")
         )
       )
       (if (eq a +a)
         (if (eq (cadr ptint) (+ (cadr stpt) a)) 
           (setq stpt ptint) 
           (progn
             (vl-cmdf "_.pedit" pl "r" "")
             (setq ptint nil a 0.0)
           )
         )
       )
       (if (eq a 0.0)
         (if (eq (cadr ptint) (cadr stpt))
           (setq stpt ptint a -a)
         ) 
       )
       (if (and (not (equal stpt ptint 1e-) (eq a -a))
         (progn
           (if (equal ptint enpt 1e-
             (progn 
               (setq d (- (car enpt) (car stpt)))
               (setq loop nil)
             )
           )
           (if (eq (cadr ptint) (+ (cadr stpt) a))
             (setq stpt ptint)
           )
         )
       )
     )
   )
 )
 (setvar 'osmode osm)
 (princ)
)
(defun c:csapl nil (c:copysquarealongpline))
(prompt "\nShortcut to c:copysquarealongpline is c:csapl")
(princ)

(defun c:coord (/ e len n e1)
(setq e (entget (car (entsel))))
;get the entity list
(setq len (length e))
;get the length of the list
(setq n 0)
;set counter to zero
(repeat len
;repeat for the length of the entity list
  (setq e1 (car (nth n e)))
  ;get each item in the entity list
  ;and strip the entity code number
  (if (= e1 10)
  ;check for code 10 (vertex)
    (progn
    ;if it's group 10 do the following
        (terpri)
          ;new line
                 (setq pt (cdr (nth n e))) ;; my code starts here
          (cdr (reverse (setq lst (list pt lst))))
          (reverse (cdr lst)) ;; my code ends here
    );progn
  );if
  (setq n (1+ n))
  ;increment the counter
);repeat
 (princ)
);defun
(princ)

([color=BLUE]defun[/color] LM:LW-Vertices ( ent [color=BLUE]/[/color] _lwvertices )
   ([color=BLUE]defun[/color] _lwvertices ( en [color=BLUE]/[/color] pair )
       ([color=BLUE]if[/color] ([color=BLUE]setq[/color] pair ([color=BLUE]assoc[/color] 10 en))
           ([color=BLUE]cons[/color] ([color=BLUE]cdr[/color] pair) (_lwvertices ([color=BLUE]cdr[/color] ([color=BLUE]member[/color] pair en))))
       )
   )
   (_lwvertices ([color=BLUE]entget[/color] ent))
)

([color=BLUE]defun[/color] LM:LW-Vertices ( ent )
   ([color=BLUE]apply[/color] '[color=BLUE]append[/color] ([color=BLUE]mapcar[/color] '([color=BLUE]lambda[/color] ( x ) ([color=BLUE]if[/color] ([color=BLUE]=[/color] 10 ([color=BLUE]car[/color] x)) ([color=BLUE]list[/color] ([color=BLUE]cdr[/color] x)))) ([color=BLUE]entget[/color] ent)))
)

([color=BLUE]defun[/color] LM:LW-Vertices ( ent [color=BLUE]/[/color] lst )
   ([color=BLUE]foreach[/color] pair ([color=BLUE]entget[/color] ent)
       ([color=BLUE]if[/color] ([color=BLUE]=[/color] 10 ([color=BLUE]car[/color] pair))
           ([color=BLUE]setq[/color] lst ([color=BLUE]cons[/color] ([color=BLUE]cdr[/color] pair) lst))
       )
   )
   ([color=BLUE]reverse[/color] lst)
)

([color=BLUE]defun[/color] LM:LW-Vertices ( ent [color=BLUE]/[/color] _group2 )
   ([color=BLUE]defun[/color] _group2 ( lst )
       ([color=BLUE]if[/color] lst
           ([color=BLUE]cons[/color] ([color=BLUE]list[/color] ([color=BLUE]car[/color] lst) ([color=BLUE]cadr[/color] lst)) (_group2 ([color=BLUE]cddr[/color] lst)))
       )
   )
   (_group2 ([color=BLUE]vlax-get[/color] ([color=BLUE]vlax-ename->vla-object[/color] ent) 'coordinates))
)

([color=BLUE]defun[/color] LM:LW-Vertices ( ent )
   ([color=BLUE]mapcar[/color] '[color=BLUE]cdr[/color] ([color=BLUE]vl-remove-if-not[/color] '([color=BLUE]lambda[/color] ( x ) ([color=BLUE]=[/color] 10 ([color=BLUE]car[/color] x))) ([color=BLUE]entget[/color] ent)))
)

([color=BLUE]defun[/color] c:test ( [color=BLUE]/[/color] e )
   ([color=BLUE]if[/color]
       ([color=BLUE]and[/color]
           ([color=BLUE]setq[/color] e ([color=BLUE]car[/color] ([color=BLUE]entsel[/color] [color=MAROON]"\nSelect LWPolyline: "[/color])))
           ([color=BLUE]eq[/color] [color=MAROON]"LWPOLYLINE"[/color] ([color=BLUE]cdr[/color] ([color=BLUE]assoc[/color] 0 ([color=BLUE]entget[/color] e))))
       )
       (LM:LW-Vertices e)
   )
)