[编程交流] 连接三维多段线

;=======================================================================
;    JPline.Lsp                                 May 30, 2007
;    Joins Any 2 ECS LINEs, ARCs, Or POLYLINEs That Have A
;    Common End Point Into New WCS 3DPOLY
;================== Start Program ======================================
(princ "\nCopyright (C) 2007, Fabricated Designs, Inc.")
(princ "\nLoading JPline v1.5 ")
;;;1.5 LWPolyLines & zerop Thickness
(setq jp_ nil lsp_file "JPline")
;==== For Automated Calling From Another Program =======================
(defun jp_auto (ar1 ar2)       ;;;Provide enames Of
     (jp_make ar1 ar2))       ;;;2 Entities To Join
;================== Macros =============================================
(defun PDot ()(princ "."))
(defun Beep (/ f)
(and (wcmatch (getvar "PLATFORM") "*DOS*")
     (setq f (open "con" "w"))
     (write-char '7 f)
     (close f)))
(defun Err (e)
          (beep)
          (princ (strcat "\nError: ** " e " ** "))
          (quit))
(PDot);++++++++++++ Set Modes & Error ++++++++++++++++++++++++++++++++++
(defun jp_smd ()
(SetUndo)
(setq oldlay (getvar "CLAYER")
      olderr *error*
     *error* (lambda (e)
               (while (> (getvar "CMDACTIVE") 0)
                      (command))
               (and (/= e "quit / exit abort")
                    (princ (strcat "\nError: *** " e " *** ")))
               (command "_.UNDO" "_END" "_.U")
               (jp_rmd))
      jp_var '(
 ("CMDECHO"   . 0) ("MENUECHO" . 0)
 ("MENUCTL"   . 0) ("MACROTRACE" . 0)
 ("OSMODE"    . 0) ("SORTENTS" . 119)
 ("REGENMODE" . 1) ("MODEMACRO" . ".")
 ("BLIPMODE"  . 0) ("EXPERT"   . 0)
 ("SNAPMODE"  . 1) ("PLINEWID"   . 0.0)
 ("ORTHOMODE" . 1) ("GRIDMODE" . 0)
 ("ELEVATION" . 0) ("THICKNESS"  . 0)
 ("UCSICON"   . 0) ("HIGHLIGHT" . 1)
 ("COORDS"    . 2) ("DRAGMODE" . 2)
 ("CECOLOR"   . "BYLAYER") ("CELTYPE" . "BYLAYER")))
(foreach v jp_var
     (setq m_v (cons (getvar (car v)) m_v)
           m_n (cons (car v) m_n))
     (setvar (car v) (cdr v)))
 (if (not (entnext))
     (err "There Are No Entities To Work With!"))
(princ (strcat (getvar "PLATFORM") " Release " (substr (ver) 18 2)
  " -  Join LINES, ARCS, & PLINES ....\n"))
(princ))
(PDot);++++++++++++ Return Modes & Error +++++++++++++++++++++++++++++++
(defun jp_rmd ()
 (SetLayer oldlay)
 (setq *error* olderr)
 (mapcar 'setvar m_n m_v)
 (command "_.UNDO" "_END")
 (prin1))
(PDot);++++++++++++ Set And Start An Undo Group ++++++++++++++++++++++++
(defun SetUndo ()
(and (zerop (getvar "UNDOCTL"))
     (command "_.UNDO" "_ALL"))
(and (= (logand (getvar "UNDOCTL") 2) 2)
     (command "_.UNDO" "_CONTROL" "_ALL"))
(and (= (logand (getvar "UNDOCTL")  8)
     (command "_.UNDO" "_END"))
(command "_.UNDO" "_GROUP"))
(PDot);++++++++++++ Make Layer Current +++++++++++++++++++++++++++++++++
(defun SetLayer (lay_name / lay_list lay_flag)
 (if (not (tblsearch "LAYER" lay_name))
     (command "_.LAYER" "_MAKE" lay_name "")
     (progn
      (setq lay_list (tblsearch "LAYER" lay_name)
            lay_flag (cdr (assoc 70 lay_list)))
      (if (= (logand lay_flag  1)  1)
          (command "_.LAYER" "_THAW" lay_name ""))
      (if (minusp (cdr (assoc 62 lay_list)))
          (command "_.LAYER" "_ON" lay_name ""))
      (if (= (logand lay_flag  4)  4)
          (command "_.LAYER" "_UNLOCK" lay_name ""))
      (and (= (logand lay_flag 16) 16)
           (princ "\nCannot Set To XRef Dependent Layer")
           (quit))
      (command "_.LAYER" "_SET" lay_name ""))))
(PDot);++++++++++++ Convert LINE To 3DPOLY +++++++++++++++++++++++++++++
(defun ledit (ln / ld lay pt1 pt2 lty thk clr hf vf)
 (and (= (type ln) 'ENAME)
      (setq ld (entget ln))
      (= (cdr (assoc 0 ld)) "LINE")
      (setq lay (cdr (assoc  8 ld))
            pt1 (cdr (assoc 10 ld))
            pt2 (cdr (assoc 11 ld))
            lty (if (assoc  6 ld) (cdr (assoc  6 ld)) "BYLAYER")
            thk (if (assoc 39 ld) (cdr (assoc 39 ld)) 0.0)
            clr (if (assoc 62 ld) (cdr (assoc 62 ld)) 256)))
 (if (and pt1 pt2)
     (progn
       (if (equal (caddr pt1) (caddr pt2) 0.0001)
           (setq hf 0 vf 0)
           (setq hf 8 vf 32 thk 0.0 lty "BYLAYER"))
       (entdel ln)
       (entmake (list (cons 0 "POLYLINE")(cons 8 lay)(cons 66 1)
                      (cons 10 (list 0.0 0.0 0.0))(cons 70 hf)
                      (cons 40 0.0)(cons 41 0.0)(cons 210 (list 0.0 0.0 1.0))
                      (cons 71 0)(cons 72 0)(cons 73 0)(cons 74 0)(cons 75 0)
                      (cons 62 clr)(cons 39 thk)(cons 6 lty)))
       (entmake (list (cons 0 "VERTEX")(cons 8 lay)(cons 10 pt1)
                      (cons 40 0.0)(cons 41 0.0)(cons 42 0.0)
                      (cons 70 vf)(cons 50 0.0)
                      (cons 71 0)(cons 72 0)(cons 73 0)(cons 74 0)
                      (cons 62 clr)(cons 39 thk)(cons 6 lty)))
       (entmake (list (cons 0 "VERTEX")(cons 8 lay)(cons 10 pt2)
                      (cons 40 0.0)(cons 41 0.0)(cons 42 0.0)
                      (cons 70 vf)(cons 50 0.0)
                      (cons 71 0)(cons 72 0)(cons 73 0)(cons 74 0)
                      (cons 62 clr)(cons 39 thk)(cons 6 lty)))
       (entmake (list (cons 0 "SEQEND")(cons 8 lay))))
     (progn
       (princ "\n*LEDIT* Unsuccessful ")
       (exit))))
(PDot);++++++++++++ Get Entity Name ++++++++++++++++++++++++++++++++++++
(defun GetOne (/ st os)
(setq os (getvar "SNAPMODE") s nil)
(setvar "SNAPMODE" 0)
(while (not st)
       (setq st (ssget)))
(while (> (sslength st) 1)
       (setq st nil)
       (princ "\nOnly 1 At A Time Please\n")
       (while (not st)
              (setq st (ssget))))
(setvar "SNAPMODE" os)
(setq s (ssname st 0)))
;++++++++++++ FINDPATH +++++++++++++++++++++++++++++++++++++++++++
;;;Returns ECS Point Values Of PLINE
(defun findpath (en / pl ed sp_flg cl_flg bf nl i vp bf vf pl_flg)
 (setq ed (entget en))
 (and (/= "POLYLINE" (cdr (assoc 0 ed)))
      (princ "\nUnable To Find The Path For This Entity ")
      (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 rseg)
 (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)))
 (if (not rseg)
     (progn
       (initget 6)
       (setq rseg (getint "\nNumber Of Segments To A 180 Degree Arc <16>:   "))
       (and (not rseg)
            (setq rseg 16))))
 (setq qty (abs (fix (/ ia (/ pi rseg)))))
 (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))))
(PDot);++++++++++++ Make 3DPOLY From 2 PLINES   ++++++++++++++++++++++++
(defun jp_make (p1 p2)
 (command "_.UCS" "_World")
 (if (= (cdr (assoc 0 (entget p1))) "LINE")
     (progn
       (ledit p1)
       (setq p1 (entlast))))
 (if (= (cdr (assoc 0 (entget p1))) "ARC")
     (progn
       (if (not (equal (cdr (assoc 210 (entget p1))) 0.00001))
           (command "_.UCS" "_E" p1))
       (command "_.PEDIT" p1 "_Yes" "_Exit")
       (setq p1 (entlast))))
 (command "_.UCS" "_World")
 (if (= (cdr (assoc 0 (entget p2))) "LINE")
     (progn
       (ledit p2)
       (setq p2 (entlast))))
 (if (= (cdr (assoc 0 (entget p2))) "ARC")
     (progn
       (if (not (equal (cdr (assoc 210 (entget p2))) 0.00001))
           (command "_.UCS" "_E" p2))
       (command "_.PEDIT" p2 "_Yes" "_Exit")
       (setq p2 (entlast))))
 (command "_.UCS" "_World")
 (setq l1 (findpath p1))
 (setq l2 (findpath p2))
 (foreach v l1 (setq w1 (cons (trans v p1 0) w1)))
 (foreach v l2 (setq w2 (cons (trans v p2 0) w2)))
 (cond ((equal (last w1) (car w2) 0.0001)    (princ))
       ((equal (last w2) (car w1) 0.0001)    (setq w1 (reverse w1)
                                                   w2 (reverse w2)))
       ((equal (last w1) (last w2) 0.0001)   (setq w2 (reverse w2)))
       ((equal (car w1) (car w2) 0.0001)     (setq w1 (reverse w1)))
       (t  (err "Entities Do Not Have Common End Points")))
 (setq w2 (cdr w2))
 (command "_.3DPOLY")
 (foreach p w1
      (command p))
 (foreach p w2
      (command p))
 (command "")
 (entdel p1)
 (entdel p2)
 (redraw (entlast)))
(PDot);++++++++++++ Compare 2 PLINEs +++++++++++++++++++++++++++++++++++
(defun jp_comp (/ df1 df2 et1 et2 lt1 lt2 la1 la2 tk1 tk2 cl1 cl2
              wd1 wd2 wd3 wd4 lter tker laer cler wder)
 (if (equal e1 e2)
     (err "Cannot Join Same Entity"))
 (setq df1 (entget e1)
       df2 (entget e2)
       et1 (cdr (assoc 0 df1))
       et2 (cdr (assoc 0 df2))
       lt1 (cdr (assoc 6 df1))
       lt2 (cdr (assoc 6 df2))
       la1 (cdr (assoc 8 df1))
       la2 (cdr (assoc 8 df2))
       tk1 (cdr (assoc 39 df1))
       tk2 (cdr (assoc 39 df2))
       wd1 (cdr (assoc 40 df1))
       wd2 (cdr (assoc 40 df2))
       wd3 (cdr (assoc 41 df1))
       wd4 (cdr (assoc 41 df2))
       cl1 (cdr (assoc 62 df1))
       cl2 (cdr (assoc 62 df2)))
  (and (or lt1 lt2)
       (setq lter t))
  (and (/= la1 la2)
       (setq laer t))
  (and (or tk1 tk2)
       (not (zerop tk1))
       (not (zerop tk2))
       (setq tker t))
  (and (/= cl1 cl2)
       (setq cler t))
  (if (and (= et1 "POLYLINE")
           (= et2 "POLYLINE")
           (or (/= wd1 0.0)
               (/= wd2 0.0)
               (/= wd3 0.0)
               (/= wd4 0.0)))
      (setq wder t))
  (if (or lter tker wder)
      (progn
        (beep)
        (princ "\nEntities Contain ")
        (if wder (princ "WIDTHS"))
        (and wder (and lter tker)
             (princ ", "))
        (and wder lter (not tker)
             (princ " & "))
        (and wder tker (not lter)
             (princ " & "))
        (if lter (princ "LINETYPES"))
        (and lter tker
             (princ " & "))
        (if tker (princ "THICKNESS"))
        (princ " That Can Not Be Duplicated")
        (initget "Yes No")
        (if (= "No" (getkword "\nContinue:  <Y>:   "))
            (exit))))
   (if laer
       (progn
          (beep)
          (princ "\nEntities Reside On Different Layers")
          (princ "\nNew 3DPOLY Will Be Constructed On LAyer ")
          (prin1 (getvar "CLAYER"))
          (getstring " Press Any Key To Continue:  ")))
   (if (and (not laer)
            (/= (getvar "CLAYER") la1))
       (SetLayer la1))
   (if cler
       (progn
          (beep)
          (princ "\nEntities Have Different Colors")
          (princ "\nNew 3DPOLY Will Be Constructed With Color "BYLAYER"")
          (getstring " Press Any Key To Continue:  ")))
   (if (and cl1
           (not cler)
           (not (zerop cl1)))
       (setvar "CECOLOR" (itoa cl1))))
(PDot);************ Main Program ***************************************
(defun jp_ (/ m_v m_n olderr oldlay jp_var e1 e2 l1 l2 w1 w2 s)
 (jp_smd)
 (princ "\nSelect 1st LINE, ARC, or PLINE:  ")
 (setq e1 (GetOne))
 (if (= "LWPOLYLINE" (cdr (assoc 0 (entget e1))))
     (command "_.CONVERTPOLY" "Heavy" e1 ""))
 (princ "\nSelect 2nd LINE, ARC, or PLINE:  ")
 (setq e2 (GetOne))
 (if (= "LWPOLYLINE" (cdr (assoc 0 (entget e2))))
       (command "_.CONVERTPOLY" "Heavy" e2 ""))
 (jp_comp)
 (jp_make e1 e2)
 (jp_rmd))
(PDot);************ Load Program ***************************************
(defun C:JPline () (jp_))
(if jp_ (princ "\nJPline Loaded\n"))
(prin1)
;================== End Program ========================================
;Tested With R12_c3 DOS & R13_c4a DOS
;Copyright (C) 2007, Fabricated Designs, Inc.
;"AS IS" Public Domain Software Donated By