[编程交流] 多段线lisp布线的点

(defun c:pts2file (/ pts e file openf)
 (vl-load-com)
 (if (and (setq e (car (entsel)))
      (= (cdr (assoc 0 (entget e))) "LWPOLYLINE")
      (setq pts (mapcar 'cdr
                (vl-remove-if-not
                  (function (lambda (pt) (= (car pt) 10)))
                  (entget e)
                )
            )
      )
      (setq file (strcat (getvar 'dwgprefix)
                 (getvar 'dwgname)
                 "__points.txt"
             )
      )
      (setq openf (open file "w"))
     )
   (progn
     (foreach pt pts
   (write-line (vl-prin1-to-string pt) openf)
     )
     (close openf)
   )
 )
 (princ file)
 (princ)
)

;;;Returns ECS Point Values Of PLINE
(defun findpath (en / pl ed sp_flg cl_flg bf nl i vp bf vf pl_flg)
 (and (/= (type en) 'ENAME)
      (princ "\n*** FindPath Error *** ")
      (exit))
 (if (= "LWPOLYLINE" (cdr (assoc 0 (entget en))))
     (command "_.CONVERTPOLY" "_Heavy" en ""))
 (setq ed (entget en))
 (and (/= "POLYLINE" (cdr (assoc 0 ed)))
      (princ "\n*** POLYLINEs Only *** ")
      (exit))
 (setq pl_flg (cdr (assoc 70 ed)))
 (and (= (logand pl_flg 1) 1)
      (setq cl_flg T))
 (and (= (logand pl_flg 4) 4)
      (setq sp_flg T))
 (and (or (= (logand pl_flg 16) 16)
          (= (logand pl_flg 64) 64))
      (princ "\nInvalid POLYLINE Mesh")
      (exit))
 (while (/= "SEQEND" (cdr (assoc 0 (entget (entnext en)))))
        (setq en (entnext en)
              ed (entget en)
              vp (cdr (assoc 10 ed))
              bf (cdr (assoc 42 ed))
              vf (cdr (assoc 70 ed)))
        (cond; ((= "SEQEND" (cdr (assoc 0 (entget (entnext en)))))
             ;  (setq pl (cons vp pl)))
              ((and (/= bf 0.0)
                    (/= "SEQEND" (cdr (assoc 0 (entget (entnext en))))))
               (add_arc vp (cdr (assoc 10 (entget (entnext en)))) bf))
              ((and (/= bf 0.0)
                    cl_flg
                    (= "SEQEND" (cdr (assoc 0 (entget (entnext en))))))
               (add_arc vp (last pl) bf))
              ((and (= bf 1.0)
                    (not cl_flg)
                    (= "SEQEND" (cdr (assoc 0 (entget (entnext en))))))
               (princ))
              ((and sp_flg
                    (= bf 0.0)
                    (= (logand vf  8))
               (setq pl (cons vp pl)))
              ((and (not sp_flg)
                    (= bf 0.0)
                    (/= (logand vf  8))
               (setq pl (cons vp pl)))))
 (if (and cl_flg
          (not (equal (car pl) (last pl))))
     (setq pl (cons (last pl) pl)))
 (setq i 0)
 (while (< i (length pl))
        (while (equal (nth i pl) (nth (1+ i) pl) 0.0001)
               (setq i (1+ i)))
        (and (nth i pl)
             (setq nl (cons (nth i pl) nl)))
        (setq i (1+ i)))
  nl)
(defun add_arc (sp ep bulge / alist x1 x2 y1 y2 cotbce
               ce ra sa ea ia inc qty na temp)
 (setq x1 (car sp);;Modified Bulge
       x2 (car ep);;Conversion By
       y1 (cadr sp);;Duff Kurland
       y2 (cadr ep);;Autodesk, Inc.
   cotbce (/ (- (/ 1.0 bulge) bulge) 2.0)
       ce (list (/ (+ x1 x2 (- (* (- y2 y1) cotbce))) 2.0)
                (/ (+ y1 y2    (* (- x2 x1) cotbce) ) 2.0)
                (caddr sp))
       ra (distance ce sp)
       sa (atan (- y1 (cadr ce)) (- x1 (car ce)))
       ea (atan (- y2 (cadr ce)) (- x2 (car ce))))
 (if (minusp sa)
     (setq sa (+ sa (* 2.0 pi))))
 (if (minusp ea)
     (setq ea (+ ea (* 2.0 pi))))
 (if (minusp bulge)
     (setq temp sa sa ea ea temp))
 (if (> sa ea)
     (setq ia (+ (- (* pi 2.0) sa) ea))
     (setq ia (- ea sa)))
 (setq qty (abs (fix (/ ia (/ pi 16)))))
 (if (< qty 2)
     (setq qty 2))
 (setq na sa
      inc (/ (abs ia) qty))
 (repeat (1+ qty)
     (setq alist (cons (polar ce na ra) alist)
              na (+ sa inc)
              sa na))
 (if (not (equal sp (car alist) 0.0001))
     (setq alist (reverse alist)))
 (foreach a alist
     (setq pl (cons a pl))))

[b][color=BLACK]([/color][/b]defun c:fpth [b][color=FUCHSIA]([/color][/b]/ s ss ppl fn wf[b][color=FUCHSIA])[/color][/b]
 [b][color=FUCHSIA]([/color][/b]while [b][color=NAVY]([/color][/b]or [b][color=MAROON]([/color][/b]not ss[b][color=MAROON])[/color][/b]
            [b][color=MAROON]([/color][/b]> [b][color=GREEN]([/color][/b]sslength ss[b][color=GREEN])[/color][/b] 1[b][color=MAROON])[/color][/b][b][color=NAVY])[/color][/b]
         [b][color=NAVY]([/color][/b]princ [color=#2f4f4f]"\nSelect 1 PLINE"[/color][b][color=NAVY])[/color][/b]
         [b][color=NAVY]([/color][/b]setq ss [b][color=MAROON]([/color][/b]ssget '[b][color=GREEN]([/color][/b][b][color=BLUE]([/color][/b]0 . [color=#2f4f4f]"*POLYLINE"[/color][b][color=BLUE])[/color][/b][b][color=GREEN])[/color][/b][b][color=MAROON])[/color][/b][b][color=NAVY])[/color][/b][b][color=FUCHSIA])[/color][/b]
 [b][color=FUCHSIA]([/color][/b]setq s [b][color=NAVY]([/color][/b]ssname ss 0[b][color=NAVY])[/color][/b][b][color=FUCHSIA])[/color][/b]
 [b][color=FUCHSIA]([/color][/b]setq ppl [b][color=NAVY]([/color][/b]findpath s[b][color=NAVY])[/color][/b][b][color=FUCHSIA])[/color][/b]
 [b][color=FUCHSIA]([/color][/b]while [b][color=NAVY]([/color][/b]or [b][color=MAROON]([/color][/b]not fn[b][color=MAROON])[/color][/b]
            [b][color=MAROON]([/color][/b]not [b][color=GREEN]([/color][/b]snvalid fn[b][color=GREEN])[/color][/b][b][color=MAROON])[/color][/b][b][color=NAVY])[/color][/b]
        [b][color=NAVY]([/color][/b]setq fn [b][color=MAROON]([/color][/b]getstring [color=#2f4f4f]"\nOutput File Name:   "[/color][b][color=MAROON])[/color][/b][b][color=NAVY])[/color][/b][b][color=FUCHSIA])[/color][/b]
 [b][color=FUCHSIA]([/color][/b]setq wf [b][color=NAVY]([/color][/b]open [b][color=MAROON]([/color][/b]strcat fn [color=#2f4f4f]".DAT"[/color][b][color=MAROON])[/color][/b] [color=#2f4f4f]"w"[/color][b][color=NAVY])[/color][/b][b][color=FUCHSIA])[/color][/b]
 [b][color=FUCHSIA]([/color][/b]write-line [color=#2f4f4f]"[b][color=NAVY]([/color][/b]setq path_list '[b][color=MAROON]([/color][/b]"[/color] wf[b][color=MAROON])[/color][/b]
 [b][color=MAROON]([/color][/b]foreach p ppl
  [b][color=GREEN]([/color][/b]write-line
   [b][color=BLUE]([/color][/b]strcat [color=#2f4f4f]"[b][color=RED]([/color][/b]"[/color] [b][color=PURPLE]([/color][/b]rtos [b][color=TEAL]([/color][/b]car p[b][color=TEAL])[/color][/b] 2 12[b][color=PURPLE])[/color][/b] [color=#2f4f4f]" "[/color]
               [b][color=PURPLE]([/color][/b]rtos [b][color=TEAL]([/color][/b]cadr p[b][color=TEAL])[/color][/b] 2 12[b][color=PURPLE])[/color][/b] [color=#2f4f4f]" "[/color]
               [b][color=PURPLE]([/color][/b]rtos [b][color=TEAL]([/color][/b]caddr p[b][color=TEAL])[/color][/b] 2 12[b][color=PURPLE])[/color][/b] [color=#2f4f4f]"[b][color=RED])[/color][/b]"[/color][b][color=BLUE])[/color][/b] wf[b][color=GREEN])[/color][/b][b][color=MAROON])[/color][/b]
 [b][color=MAROON]([/color][/b]write-line [color=#2f4f4f]"[b][color=MAROON])[/color][/b][b][color=NAVY])[/color][/b]"[/color] wf[b][color=FUCHSIA])[/color][/b]
 [b][color=FUCHSIA]([/color][/b]close wf[b][color=FUCHSIA])[/color][/b]
 [b][color=FUCHSIA]([/color][/b]prin1[b][color=FUCHSIA])[/color][/b][b][color=BLACK])[/color][/b]

4