Jump to content

Drawing cylindrical break line ?

liuhaixin88

By liuhaixin88
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

  • Replies 48
  • Created
  • Last Reply

Top Posters In This Topic

  • liuhaixin88

    21

  • Tharwat

    16

  • ReMark

    4

  • highflybird

    4

Popular Days

Top Posters In This Topic

Popular Days

Posted Images

highflybird Enthusiast

highflybird

Posted
Posted (edited)
If that routine is yours , post the codes .

 

Sorry ,Tharwat, No offense.

It's not mine, just a little suggestion.

 

I find the source code at here:

http://bbs.xdcad.org/thread-673470-1-1.html

 

(defun C:w1 (/ CMD1 FIL OSM1 P1 P2 SS)
 (defun *error* (msg)
   (vl-bt)
   (if        *DOC*
     (_EndUndo *DOC*)                                            
   )
   (while (not (equal (getvar "cmdnames") "")) (command nil))
   (cond (cmd1 (setvar "cmdecho" cmd1)))
   (princ "\n err!")
   (princ)
 )
 (setq        fil '((-4 . "<or")
             (-4 . "<and")
             (0 . "LWPOLYLINE")
             (90 . 2)
             (-4 . "and>")
             (0 . "LINE")
             (-4 . "or>")
            )
 )
 (cond
   ((and
      (setq p1 (getpoint))
      (setq p2 (getpoint p1))
      (setq ss (ssget "_C" p1 p2 fil))
      (> (sslength ss) 1)
    )
    (vl-load-com)
    (or *DOC*
        (setq *DOC* (vla-get-ActiveDocument (vlax-get-acad-object)))
    )
    (_StartUndo *DOC*)
    (HH:ayOSMode nil)
    (setq cmd1 (getvar "cmdecho"))
    (setvar "cmdecho" 0)
    (VL-CATCH-ALL-APPLY 'HH::pmDo (list p1 p2 ss))
    (setvar "cmdecho" cmd1)
    (HH:ayOSMode T)
    (_EndUndo *DOC*)
    (gc)
   )
 )
 (princ)
)

;;;(command "_.undo" "be")
(defun _StartUndo (*DOC*)
 (_EndUndo *DOC*)
 (vla-StartUndoMark *DOC*)
)
;;;(if (= 8 (logand (getvar "undoctl") ) (command "_.undo" "_e"))
(defun _EndUndo        (*DOC*)
 (if (= 8 (logand 8 (getvar 'UNDOCTL)))
   (vla-EndUndoMark *DOC*)
 )
)
(defun HH::pmDo        (p1 p2 ss / ANG DIST E E1 E2 EP EP1 EP2 LENT1 LENT2 LST N SP SP1 SP2)
 (repeat (setq n (sslength ss))
   (setq e (ssname ss (setq n (1- n))))
   (setq sp (vlax-curve-getStartPoint e))
   (setq Ep (vlax-curve-getEndPoint e))
   (setq dist (car (trans (mapcar '- p1 sp) 0 (mapcar '- Ep sp))))
   (setq lst (cons (list (abs dist) e) lst))
   (setq lst (HH:ssPts:Sort lst "x" 0.1))                   
 )
 (setq e1 (cadar lst))
 (setq e2 (cadr (last lst)))
 (setq ang (angle p1 p2))
 (setq dist (* (distance p1 p2) 0.25))
 (setq sp1 (vlax-curve-getStartPoint e1))
 (setq Ep1 (vlax-curve-getEndPoint e1))
 (setq sp2 (vlax-curve-getStartPoint e2))
 (setq Ep2 (vlax-curve-getEndPoint e2))
 (setq sp (polar p1 (+ ang (* pi 0.5)) dist))
 (setq Ep (polar p2 (+ ang (* pi 0.5)) dist))
 (HH::pmDo2P (inters sp1 Ep1 sp Ep T) (inters sp2 Ep2 sp Ep T) ang)
 (setq Lent1 (entlast))
 (setq ang (+ ang pi))
 (setq sp (polar p1 (+ ang (* pi 0.5)) dist))
 (setq Ep (polar p2 (+ ang (* pi 0.5)) dist))
 (HH::pmDo2P (inters sp2 Ep2 sp Ep T) (inters sp1 Ep1 sp Ep T) ang)
 (setq Lent2 (entlast))
 (command "_.trim" Lent1 Lent2  "" (list e1 (inters sp1 Ep1 p1 p2 T)) "")
 (command "_.trim" Lent1 Lent2 "" (list e2 (inters sp2 Ep2 p1 p2 T)) "")
)

(defun HH::pmDo2P (p1 p2 ang / AN DIST PT)
 (setq dist (distance p1 p2))
 (setq an (* 180 (/ ang pi)))
 (setq pt (polar p1 ang (* 0.5 dist)))
 (command "_.pline" p1 "a" "d" (+ an -45) pt p2 "d" (+ an 180 45) pt "")
)

Edited by highflybird
Link to comment
Share on other sites
stevesfr Rising Star

stevesfr

Posted
Posted
Sorry ,Tharwat, No offense.

It's not mine, just a little suggestion.

 

I find the source code at here:

http://bbs.xdcad.org/thread-673470-1-1.html

 

(defun C:w1 (/ CMD1 FIL OSM1 P1 P2 SS)
(defun *error* (msg)
(vl-bt)
(if *DOC*
(_EndUndo *DOC*) 
)
(while (not (equal (getvar "cmdnames") "")) (command nil))
(cond (cmd1 (setvar "cmdecho" cmd1)))
(princ "\n err!")
(princ)
)
(setq fil '((-4 . "<or")
(-4 . "<and")
(0 . "LWPOLYLINE")
(90 . 2)
(-4 . "and>")
(0 . "LINE")
(-4 . "or>")
)
)
(cond
((and
(setq p1 (getpoint))
(setq p2 (getpoint p1))
(setq ss (ssget "_C" p1 p2 fil))
(> (sslength ss) 1)
)
(vl-load-com)
(or *DOC*
(setq *DOC* (vla-get-ActiveDocument (vlax-get-acad-object)))
)
(_StartUndo *DOC*)
(HH:ayOSMode nil)
(setq cmd1 (getvar "cmdecho"))
(setvar "cmdecho" 0)
(VL-CATCH-ALL-APPLY 'HH::pmDo (list p1 p2 ss))
(setvar "cmdecho" cmd1)
(HH:ayOSMode T)
(_EndUndo *DOC*)
(gc)
)
)
(princ)
)

;;;(command "_.undo" "be")
(defun _StartUndo (*DOC*)
(_EndUndo *DOC*)
(vla-StartUndoMark *DOC*)
)
;;;(if (= 8 (logand (getvar "undoctl") ) (command "_.undo" "_e"))
(defun _EndUndo (*DOC*)
(if (= 8 (logand 8 (getvar 'UNDOCTL)))
(vla-EndUndoMark *DOC*)
)
)
(defun HH::pmDo (p1 p2 ss / ANG DIST E E1 E2 EP EP1 EP2 LENT1 LENT2 LST N SP SP1 SP2)
(repeat (setq n (sslength ss))
(setq e (ssname ss (setq n (1- n))))
(setq sp (vlax-curve-getStartPoint e))
(setq Ep (vlax-curve-getEndPoint e))
(setq dist (car (trans (mapcar '- p1 sp) 0 (mapcar '- Ep sp))))
(setq lst (cons (list (abs dist) e) lst))
(setq lst (HH:ssPts:Sort lst "x" 0.1)) 
)
(setq e1 (cadar lst))
(setq e2 (cadr (last lst)))
(setq ang (angle p1 p2))
(setq dist (* (distance p1 p2) 0.25))
(setq sp1 (vlax-curve-getStartPoint e1))
(setq Ep1 (vlax-curve-getEndPoint e1))
(setq sp2 (vlax-curve-getStartPoint e2))
(setq Ep2 (vlax-curve-getEndPoint e2))
(setq sp (polar p1 (+ ang (* pi 0.5)) dist))
(setq Ep (polar p2 (+ ang (* pi 0.5)) dist))
(HH::pmDo2P (inters sp1 Ep1 sp Ep T) (inters sp2 Ep2 sp Ep T) ang)
(setq Lent1 (entlast))
(setq ang (+ ang pi))
(setq sp (polar p1 (+ ang (* pi 0.5)) dist))
(setq Ep (polar p2 (+ ang (* pi 0.5)) dist))
(HH::pmDo2P (inters sp2 Ep2 sp Ep T) (inters sp1 Ep1 sp Ep T) ang)
(setq Lent2 (entlast))
(command "_.trim" Lent1 Lent2 "" (list e1 (inters sp1 Ep1 p1 p2 T)) "")
(command "_.trim" Lent1 Lent2 "" (list e2 (inters sp2 Ep2 p1 p2 T)) "")
)

(defun HH::pmDo2P (p1 p2 ang / AN DIST PT)
(setq dist (distance p1 p2))
(setq an (* 180 (/ ang pi)))
(setq pt (polar p1 ang (* 0.5 dist)))
(command "_.pline" p1 "a" "d" (+ an -45) pt p2 "d" (+ an 180 45) pt "")
)

 

Anyone get this lisp to work in Acad 2008 or before version. I get no error, but not working either. Steve

Link to comment
Share on other sites
ymg3 Rising Star

ymg3

Posted
Posted (edited)

highflybird,

 

There is some function missing from your code namely "HH:ssPts:Sort" and "HH:ayOSMode"

 

Also since you are filtering polylines to a length of 2, this would means that it needs to be

exploded. ???

 

I also doubt very much that this code ad the one shown on the animation are the same.

 

ymg

Edited by ymg3
Link to comment
Share on other sites
marko_ribar Veteran

marko_ribar

Posted
Posted (edited)

Yes, the code is the same, but I had to modify it - to add missing subfunctions; to add POLYLINE option (ymg, yes I had to explode POLYLINE)...

 

Here is my version :

 

(defun C:w1 (/ *error* CMD1 FIL OSM1 P1 P2 SS SSS)
 
 (defun *error* (msg)
   (vl-bt)
   (if *DOC*
     (_EndUndo *DOC*)                                            
   )
   (while (not (equal (getvar "cmdnames") "")) (command nil))
   (if cmd1 (setvar "cmdecho" cmd1))
   (if msg (prompt msg))
   (princ)
 )
 
 (setq fil '((-4 . "<or")
             (-4 . "<and")
             (0 . "LWPOLYLINE")
             (90 . 2)
             (-4 . "and>")
             (0 . "LINE")
             (-4 . "or>")
            )
 )
 (cond
   ((and
      (setq p1 (getpoint))
      (setq p2 (getpoint p1))
      (progn
        (setq sss (ssget "_C" p1 p2 '((-4 . "<or") (-4 . "<and") (0 . "POLYLINE") (-4 . "<not") (-4 . "&=") (70 .  (-4 . "not>") (-4 . "and>") (-4 . "<and") (0 . "LWPOLYLINE") (-4 . "<not") (90 . 2) (-4 . "not>") (-4 . "and>") (-4 . "or>"))))
        t
      )
      (if sss
        (progn
          (mapcar '(lambda (x)
                     (command "_.explode" x)
                     (while (> (getvar 'cmdactive) 0) (command ""))
                   )
                  (vl-remove-if 'listp (mapcar 'cadr (ssnamex sss)))
          )
          t
        )
        t
      )
      (setq ss (ssget "_C" p1 p2 fil))
      (> (sslength ss) 1)
    )
    (vl-load-com)
    (or *DOC*
        (setq *DOC* (vla-get-ActiveDocument (vlax-get-acad-object)))
    )
    (_StartUndo *DOC*)
    (HH:ayOSMode nil)
    (setq cmd1 (getvar "cmdecho"))
    (setvar "cmdecho" 0)
    (VL-CATCH-ALL-APPLY 'HH::pmDo (list p1 p2 ss))
    (setvar "cmdecho" cmd1)
    (HH:ayOSMode T)
    (_EndUndo *DOC*)
    (gc)
   )
 )
 (princ)
)

(defun _StartUndo (*DOC*)
 (_EndUndo *DOC*)
 (vla-StartUndoMark *DOC*)
)

(defun _EndUndo (*DOC*)
 (if (= 8 (logand 8 (getvar 'UNDOCTL)))
   (vla-EndUndoMark *DOC*)
 )
)

(defun HH::pmDo (p1 p2 ss / ANG DIST E E1 E2 EP EP1 EP2 LENT1 LENT2 LST N SP SP1 SP2)
 (repeat (setq n (sslength ss))
   (setq e (ssname ss (setq n (1- n))))
   (setq sp (vlax-curve-getStartPoint e))
   (setq Ep (vlax-curve-getEndPoint e))
   (setq dist (car (trans (mapcar '- p1 sp) 0 (mapcar '- Ep sp))))
   (setq lst (cons (list (abs dist) e) lst))
   (setq lst (HH:ssPts:Sort lst car 0.1))                   
 )
 (setq e1 (cadar lst))
 (setq e2 (cadr (last lst)))
 (setq ang (angle p1 p2))
 (setq dist (* (distance p1 p2) 0.25))
 (setq sp1 (vlax-curve-getStartPoint e1))
 (setq Ep1 (vlax-curve-getEndPoint e1))
 (setq sp2 (vlax-curve-getStartPoint e2))
 (setq Ep2 (vlax-curve-getEndPoint e2))
 (setq sp (polar p1 (+ ang (* pi 0.5)) dist))
 (setq Ep (polar p2 (+ ang (* pi 0.5)) dist))
 (HH::pmDo2P (inters sp1 Ep1 sp Ep T) (inters sp2 Ep2 sp Ep T) ang)
 (setq Lent1 (entlast))
 (setq ang (+ ang pi))
 (setq sp (polar p1 (+ ang (* pi 0.5)) dist))
 (setq Ep (polar p2 (+ ang (* pi 0.5)) dist))
 (HH::pmDo2P (inters sp2 Ep2 sp Ep T) (inters sp1 Ep1 sp Ep T) ang)
 (setq Lent2 (entlast))
 (command "_.trim" Lent1 Lent2  "" (list e1 (inters sp1 Ep1 p1 p2 T)) "")
 (command "_.trim" Lent1 Lent2 "" (list e2 (inters sp2 Ep2 p1 p2 T)) "")
)

(defun HH::pmDo2P (p1 p2 ang / AN DIST PT)
 (setq dist (distance p1 p2))
 (setq an (* 180 (/ ang pi)))
 (setq pt (polar p1 ang (* 0.5 dist)))
 (command "_.pline" p1 "a" "d" (- an 45) pt p2 "d" (+ an 225) pt "")
)

(defun HH:ayOSMode (f)
 (if (not f)
   (progn
     (setq osm1 (getvar 'osmode))
     (setvar 'osmode 0)
   )
   (if osm1 (setvar 'osmode osm1))
 )
)

(defun HH:ssPts:Sort (lst fun fuzz)
 (vl-sort lst '(lambda (a b)
                 (cond
                   ((< (fun a) (fun b)))
                   ((equal (fun a) (fun b) fuzz))
                 )
               )
 )
)

M.R.

Edited by marko_ribar
Link to comment
Share on other sites
highflybird Enthusiast

highflybird

Posted
Posted
highflybird,

 

There is some function missing from your code namely "HH:ssPts:Sort" and "HH:ayOSMode"

 

Also since you are filtering polylines to a length of 2, this would means that it needs to be

exploded. ???

 

I also doubt very much that this code ad the one shown on the animation are the same.

 

ymg

 

Sorry , The author published the code that's it.

tt.jpg

 

I find the author before release function.

 

(defun HH:ayOSMode (isOpenSnap)
(if isOpenSnap
 (setvar "osmode" (rem (getvar "osmode") 703));
 (setvar "osmode" (+ (rem (getvar "osmode") 703) 703))
);end_if
);end_defun

 

;;Marshalling start;(command "_.undo" "be")
(defun _StartUndo (*DOC*)
 (_EndUndo *DOC*)
 (vla-StartUndoMark *DOC*)
)
;;Marshalling end;(if (= 8 (logand (getvar "undoctl") ) (command "_.undo" "_e"))
(defun _EndUndo        (*DOC*)
 (if (= 8 (logand 8 (getvar 'UNDOCTL)))
   (vla-EndUndoMark *DOC*)
 )
)

 

;;Sort function
(defun HH:ssPts:Sort (ssPts KEY FUZZ / E EN FUN LST N)
 
 (defun sortpts (PTS FUN xyz FUZZ)
   (vl-sort pts
            '(lambda (a b)
               (if (not (equal (xyz a) (xyz b) fuzz))
                 (fun (xyz a) (xyz b))
               )
             )
   )
 )
 
 (defun sortpts1 (PTS KEY FUZZ)
   (setq Key (vl-string->list Key))
   (foreach xyz (reverse Key)
     (cond ((< xyz 100)
            (setq fun >)
            (setq xyz (nth (- xyz 88) (list car cadr caddr)))
           )
           (T
            (setq fun <)
            (setq xyz (nth (- xyz 120) (list car cadr caddr)))
           )
     )
     (setq Pts (sortpts Pts fun xyz fuzz))
   )
 )
 ;;Main
 (cond
   ((= (type ssPts) 'PICKSET)
    (repeat (setq n (sslength ssPts))
      (if (and        (setq e (ssname ssPts (setq n (1- n))))
               (setq en (entget e))
          )
        (setq lst (cons (append (cdr (assoc 10 en)) (list e)) lst))
      )
    )
    (mapcar 'last (sortpts1 lst KEY FUZZ))
   )
   ((Listp ssPts)
     (cond
       ((vl-consp (car ssPts)) (sortpts1 ssPts KEY FUZZ))
       ((= (type (car ssPts)) 'ENAME)
        (foreach e ssPts
          (if (setq en (entget e))
            (setq lst (cons (append (cdr (assoc 10 en)) (list e)) lst))
          )
        )
        (mapcar 'last (sortpts1 lst KEY FUZZ))
       )
       (T
        (cond ((equal key "X") (vl-sort ssPts '>))
              (T (vl-sort ssPts '<))
        )
       )
     )
   )    
 )
)

Link to comment
Share on other sites
highflybird Enthusiast

highflybird

Posted
Posted (edited)

Hi, marko ,nice! we are so proud of you.

 

I think there is another situation. about tube break.

 

tt.jpg

Edited by highflybird
Link to comment
Share on other sites
liuhaixin88 Collaborator

liuhaixin88

Posted
  • Author
Posted (edited)

Thanks marko_ribar & highflybird ,Thank you for your attention.Thank you for your help!

And Thanks Tharwat, You are the best.

 

If can break tube, It will be very perfect.

Edited by liuhaixin88
Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 Share
Go to topic listing
×
×
  • Create New...