Jump to content

help to modify the lisp?


xpr0

Recommended Posts

hello everyone,

i need help in modifying a lisp.i'm sure most of u know about this lisp it's called 'DUCT'.i want to add explode command at the end of it...when u draw a duct with it.it creates a mline for straight duct and pline for elbows all i want is that it also explode the mline after it creates it so that i don't've to use explode again n again to break it into lines.

i hope i've made my case clear.i'm new to lisps so plz ignore any mistakes.

 

here's code.

(defun c:DUCT(/ actDoc ang1 ang2 ang3 ptLst enDist
       fPt lEnt lObj lPln oldVars oldWd
       plEnd plStart1 plStart2 prDir
       segLst Start stDist stLst tAng
       vlaPln cFlg *error*)
 
 (vl-load-com)

 (defun GetPlineVer(plObj)
   (mapcar 'cdr
    (vl-remove-if-not
     '(lambda(x)(=(car x)10))
     (entget plObj)))
   ); end of GetPLineVer

 (defun asmi-PlineSegmentDataList(plObj / cLst outLst)
  (setq cLst
   (vl-remove-if-not
     '(lambda(x)(member(car x) '(10 40 41 42)))
     (entget plObj))
  	 outLst '()
   ); end setq
 (while cLst
   (if(assoc 40 cLst)
     (progn
      (setq outLst
     (append outLst
      (list
	(list
	  (cdr(assoc 10 cLst))
	  (cdr(assoc 40 cLst))
	  (cdr(assoc 41 cLst))
	  (cdr(assoc 42 cLst))
	 ); end list
); end list
     ); end if
); end setq
      (repeat 4
(setq cLst(cdr cLst))
); end repeat
      ); end progn
     (setq outLst
     (append outLst
     (list
       (list
 	(cdr(assoc 10 cLst))
	); end list
       ); end list
    ); end append
   cLst nil
   ); end setq
     ); end if
   ); end while
 outLst
   ); end of asmi-GetPlineSegmentData


 (defun asmi-LayersUnlock(/ restLst)
 (setq restLst '())
 (vlax-for lay
   (vla-get-Layers
            (vla-get-ActiveDocument
              (vlax-get-acad-object)))
   (setq restLst
    (append restLst
      (list
        (list
         lay
          (vla-get-Lock lay)
  (vla-get-Freeze lay)
         ); end list
        ); end list
      ); end append
   ); end setq
   (vla-put-Lock lay :vlax-false)
   (if
     (vl-catch-all-error-p
(vl-catch-all-apply
 'vla-put-Freeze(list lay :vlax-false)))
     t)
   ); end vlax-for
 restLst
 ); end of asmi-LayersUnlock

 (defun asmi-LayersStateRestore(StateList)
 (foreach lay StateList
   (vla-put-Lock(car lay)(cadr lay))
    (if
     (vl-catch-all-error-p
(vl-catch-all-apply
 'vla-put-Freeze(list(car lay)(nth 2 lay))))
     t)
   ); end foreach
 (princ)
    ); end of asmi-LayersStateRestore

 (defun PipeMLineStyle(/ dxfLst mlDict)
 (setq dxfLst
  (list'(0 . "MLINESTYLE")'(102 . "{ACAD_REACTORS")'(102 . "}")
   '(100 . "AcDbMlineStyle") '(2 . "DUCT_PIPE")
   '(70 . 274)'(3 . "")'(62 . 256)'(51 . 1.5708)'(52 . 1.5708)
   '(71 . 2)'(49 . 0.5)'(62 . 256)'(6 . "BYBLOCK")
   '(49 . -0.5)'(62 . 256)'(6 . "BYBLOCK"))); end setq
   (if
    (null
     (member
      (assoc 2 dxfLst)
        (dictsearch
  (namedobjdict)
  "ACAD_MLINESTYLE")))
   (progn
     (setq mlDict
      (cdr
        (assoc -1
  (dictsearch
    (namedobjdict)
    "ACAD_MLINESTYLE"))))
     (dictadd mlDict
        (cdr(assoc 2 dxfLst))(entmakex dxfLst))
     ); end progn
   ); end if
); end of PipeMLineStyle

(defun SideCalculate(Wdth Ang / Rad)
 (setq Ang(- pi Ang))
 (setq Rad(* (if (= dpipeelb "Mitered") 0.5 dpiper/w) Wdth))
 (+ (if (= dpipeelb "Mitered") dpipetan  0)
  (*
   (/
     (sqrt(-(* 2(expt Rad 2))(* 2(expt Rad 2)(cos Ang))))
     (sin(- pi Ang)))(sin(/(- pi(- pi Ang))2.0)
    )
   )
  )
 ); end of SideCalculate


 (defun BodyFunction()
 (if
   (not
     (equal lObj(entlast)))
(progn
 (setq lEnt(entlast)
       stLst(asmi-LayersUnlock)
 	segLst(asmi-PlineSegmentDataList lEnt)
 	vlaPln(vlax-ename->vla-object lEnt)
 ); end setq
 (setvar "OSMODE" 0)
 (setvar "CMDECHO" 0)
 (while (/= 1(length segLst))
      (setq stDist
      (vlax-curve-getDistAtPoint vlaPln
	(caar segLst))
     enDist
      (vlax-curve-getDistAtPoint vlaPln
	(caadr segLst))
     ); end setq
   (if(< 2(length segLst))
     (progn
      (setq ang1
      (+(/ pi 2)(angle(caar segLst)(caadr segLst)))
     ang2
      (+(/ pi 2)(angle(caadr segLst)(car(nth 2 segLst))))
     ); end setq
      ); end progn
     ); end if
   (if
     (or
(not Start)
prDir
);end or
      (setq plStart1
       (vlax-curve-getPointAtDist vlaPln
	 stDist)
     Start T); end setq
      (setq plStart1
       (vlax-curve-getPointAtDist vlaPln
	 (+ stDist(SideCalculate(cadar segLst)ang3)))); end setq
     ); end if
   (if(and ang1 ang2)
     (progn
     (if(> ang1 ang2)
 (setq ang3(- ang1 ang2))
 (setq ang3(- ang2 ang1))
 ); end if
      (setq ang3(- pi ang3)
     tAng ang3)
      (if(minusp ang3)(setq ang3(- ang3)))
      ); end progn
     ); end if

   (if
     (or
       (equal ang1 ang2 0.000001)
(= 2(length segLst))
      ); end or
     	  (setq plEnd
           (vlax-curve-getPointAtDist vlaPln
	   enDist)
	prDir T); end setq
         (setq plEnd
           (vlax-curve-getPointAtDist vlaPln
	    (- enDist(SideCalculate(cadar segLst)ang3)))
	prDir nil); end setq
     ); end if
   (if
     (< 2(length segLst))
      (setq plStart2
       (vlax-curve-getPointAtDist vlaPln
	 (+ enDist(SideCalculate(cadar segLst)ang3)))); end setq
     ); end if
      (if(< 2(length segLst))
       (if
	 (=(cadar segLst)(nth 2(car segLst)))
	  (setq ptLst
                    (mapcar
	      '(lambda(x)(trans x 0 1)); end lambda
                         (append
                            (if (not (/= "Segmented" dpipeelb "Mitered"))
                              (progn
                                 (setq ang4 (apply '(lambda(x)(atan x (sqrt (abs (1- (* x x))))))
                                   (list (sin (- ang1 (/ pi 2.0) (angle plEnd plStart2)))))
                                   )
                                 (setq SegNum (cond ((or (= dpipeelb "Mitered") (< (abs ang4)
                                   (* (/ 35 360.0) pi))) 2) ((< (abs ang4) (* (/ 55 360.0) pi)) 3)
                                   ((< (abs ang4) (* (/ 75 360.0) pi)) 4) (T 5))
                                   )
                                 (setq tan4 (+ (if (= dpipeelb "Mitered") dpipetan 0.0) (*
                                   (if (= dpipeelb "Mitered") 0.5 dpiper/w) (cadar segLst)
                                   (abs (apply '(lambda(x) (/ (sin x) (cos x))) (list (/ ang4
                                   0.5 (1- SegNum) 2.0))))))
                                   )
                                 (setq mllst (list plEnd (polar plEnd (- ang1 (/ pi 2.0)) tan4)))
                                 (setq SegCnt 0)
                                 (while (< (+ SegCnt 2) SegNum)
                                   (setq mllst (append mllst (list (polar (last mllst)
                                               (+ (angle (cadr (reverse mllst)) (last mllst))
                                               (/ ang4 -0.5 (1- SegNum))) (* tan4 2.0)))
                                               )
                                         SegCnt (1+ SegCnt)
                                         )
                                      )
                                 (setq mllst (append mllst (list PlStart2)))
                                 (setq SegCnt (- (length mllst) 2))
                                 (setq pllst nil)
                                 (while (> SegCnt 0)
                                   (setq pllst (append pllst (list (polar (nth SegCnt mllst)
                                               (+ (angle (nth (1- SegCnt) mllst) (nth SegCnt mllst))
                                               (/ pi 2.0) (/ ang4 0.5 (1- SegNum) -2.0))
                                               (/(cadar segLst)2(cos (/ ang4 0.5 (1- SegNum) 2.0)))))
                                               )
                                         SegCnt (1- SegCnt)
                                         )
                                      )
                                 pllst
                                 )
                               )
                     (list(polar plEnd ang1 (/(cadar segLst)2)))
		     (list(polar plEnd (+ pi ang1)(/(cadar segLst)2)))
                            (if (not (/= "Segmented" dpipeelb "Mitered"))
                              (progn
                                 (setq SegCnt 1)
                                 (setq pllst nil)
                                 (while (< SegCnt (1- (length mllst)))
                                   (setq pllst (append pllst (list (polar (nth SegCnt mllst)
                                               (+ (angle (nth (1- SegCnt) mllst) (nth SegCnt mllst))
                                               (* pi 1.5) (/ ang4 0.5 (1- SegNum) -2.0))
                                               (/(cadar segLst)2(cos (/ ang4 0.5 (1- SegNum) 2.0)))))
                                               )
                                         SegCnt (1+ SegCnt)
                                         )
                                      )
                                (setq mllst (mapcar '(lambda(x)(trans x 0 1)) mllst))
                                pllst
                                )
                              )
		     (list(polar plStart2 (+ pi ang2)(/(cadar segLst)2)))
		     (list(polar plStart2 ang2 (/(cadar segLst)2)))
	      	); end append
	          ); end mapcar
		); end setq
	 (setq ptLst
	   (mapcar
	    '(lambda(x)(trans x 0 1)); end lambda
	       (list (polar plStart1 ang1 (/(cadar segLst)2))
		     (polar plStart1 (+ pi ang1)(/(cadar segLst)2))
		     (polar(caadr segLst)(+ pi ang2)(/(nth 2(car segLst))2))
		     (polar(caadr segLst)ang2(/(nth 2(car segLst))2))
		     ); end list
	          ); end mapcar
		); end setq
       ); end if
 ); end if
     (setq plStart1(trans plStart1 0 1)
      plEnd(trans plEnd 0 1)
  ); end setq
   	(if plStart2
     		(setq plStart2(trans plStart1 0 1))
     	); end if
      (if (< 2(length segLst))
  (if (or (/=(cadar segLst)(nth 2(car segLst)))
        (and (/= "Segmented" dpipeelb) (not(equal ang1 ang2 0.000001))
               ); end and
              ); end or
            (progn
       	(setvar "PLINEWID" 0.0)
       	(command "_.pline")
	(mapcar 'command ptLst)(command "_c")
       	(setvar "PLINEWID" dpipepWd)
        ); end progn
     (if (and (= "Segmented" dpipeelb) (not(equal ang1 ang2 0.000001)))
               (progn
                  (command "_.mline" "_st" "DUCT_PIPE" "_S" (cadar segLst) "_J" "_Z")
                  (mapcar 'command mlLst)
                  (command "")
;                   (setvar "PLINEWID" 0.0)
;                   (command "_.pline")
;                   (mapcar 'command ptLst)(command "_c")
;                   (setq SegCnt 0)
;                   (while (< SegCnt (1- SegNum))
;                      (command "_.line" (nth SegCnt ptlst)
;                         (nth (- (length ptlst) 3 SegCnt) ptlst)
;                         ""
;                         )
;                      (setq SegCnt (1+ SegCnt))
;                      )
;                   (setvar "PLINEWID" dpipepWd)
                   ); end progn
                ); end if
     ); end if
 ); end if
   (if
     (and (= dpipeelb "Radius")
       (not(equal ang1 ang2 0.000001))
       (< 2(length segLst))
     ); end and
     (progn
      	(setq lPln
      (vlax-ename->vla-object(entlast))
      tAng (abs (- ang2 ang1))
     ); end setq
(if (> tAng pi)
   (if(< ang1 ang2)
     (setq ang1(+ ang1 pi)
	   ang2(- ang2 pi)); end setq
     (setq ang1(- ang1 pi)
	   ang2(+ ang2 pi)); end setq
     ); end if
          ); end if
(setq Bulge(/(sin(/(rem(- ang2 ang1)pi)4.0))(cos(/(rem(- ang2 ang1)pi)4.0))))
(vla-SetBulge lPln 1 Bulge)
(vla-SetBulge lPln 3 (- Bulge))
      ); end progn
 ); end if
 (if
   (=(cadar segLst)(nth 2(car segLst)))
   	 (command "_.mline" "_st" "DUCT_PIPE"
	"_S" (cadar segLst) "_J" "_Z"
	plStart1 plEnd "")
;       (progn
;		(setq ptLst
;			(list (polar plStart1 (+ (angle plStart1 plEnd) (/ pi 2.0)) (/(cadar segLst)2))
;			     (polar plStart1 (- (angle plStart1 plEnd) (/ pi 2.0)) (/(cadar segLst)2))
;			     (polar plEnd (- (angle plStart1 plEnd) (/ pi 2.0)) (/(nth 2(car segLst))2))
;			     (polar plEnd (+ (angle plStart1 plEnd) (/ pi 2.0)) (/(nth 2(car segLst))2))
;			     )
;			)
;	       	(setvar "PLINEWID" 0.0)
;	       	(command "_.pline")
;		(mapcar 'command ptLst)(command "_c")
;	       	(setvar "PLINEWID" dpipepWd)
;	); end progn
   ); end if
   
   (setq segLst(cdr segLst)); end setq
   ); end while
 (command "_.erase" lEnt "")
 (asmi-LayersStateRestore stLst)
 ); end progn
   ); end if
   ); end of Body Function

   (defun *error*(msg)
    (if actDoc
     (vla-EndUndoMark actDoc)
     ); end if
    (setvar "CMDECHO" 0)
    (command "_.undo" "1")
    (if oldVars
     (mapcar 'setvar
     '("FILLMODE" "PLINEWID" "CMDECHO" "OSMODE")
     oldVars); end mapcar
    ); end if
    (if (not (member msg '("console break" "Function cancelled" "quit / exit abort" "")))
       (princ (strcat "\nError: " msg))
       (princ)
       )
   ); end of *error*

 (PipeMLineStyle)
 
 (if(not dpipepWd)(setq dpipepWd 1.0))
 (setq oldWd dpipepWd
oldVars(mapcar 'getvar '("FILLMODE" "PLINEWID" "CMDECHO" "OSMODE"))
       ); end setq
 (if(entlast)(setq lObj(entlast)))
 (vla-StartUndoMark
  (setq actDoc
   (vla-get-ActiveDocument
     (vlax-get-acad-object))))
 (setq dlastelb dpipeelb)
 (initget "Mitered Radius Segmented")
 (setq dpipeelb (getkword (strcat "\nSpecify elbow type "
(if (= dlastelb "Mitered") "<Mitered>/" "Mitered/")
(if (= dlastelb "Segmented") "<Segmented>/" "Segmented/")
(if (/= "Mitered" dlastelb "Segmented")
           (strcat "<" (setq dlastelb "Radius") ">: ")
           "Radius: "))
           )
)
 (if (or (= dpipeelb "Mitered") (and (not dpipeelb) (= dlastelb "Mitered")))
     (progn
        (initget 6)
        (setq dlasttan dpipetan
              dpipetan (getdist (strcat "\nNew elbow throat length <"
                  (rtos (if (/= (type dlasttan) 'REAL)
                  (setq dlasttan 6.0) dlasttan)) ">: ")
                  )
             )
(if (not dpipetan) (setq dpipetan dlasttan))
(if (not dpipeelb) (setq dpipeelb dlastelb))
(setq dlasttan nil)
)
     (progn
        (initget 6)
        (setq dlastr/w dpiper/w
              dpiper/w (getdist (strcat "\nNew centerline r/w factor <"
                  (rtos (if (/= (type dlastr/w) 'REAL)
                  (setq dlastr/w 1.5) dlastr/w)) ">: ")
                  )
             )
(if (not dpiper/w) (setq dpiper/w dlastr/w))
(if (not dpipeelb) (setq dpipeelb dlastelb))
(setq dlastr/w nil dpiper/w (max dpiper/w 0.5))
)
    )
 (initget 128)
 (while(not cFlg)
  (setq fPt
 (getpoint
   (strcat
     "\nSpecify start point or width <"
     (rtos dpipepWd) ">: " ))); end setq
   (cond
     ((= 'LIST(type fPt))
      (setq cFlg T)
      ); end condition #1
     ((= 'REAL(type(distof fPt)))
      (setq dpipepWd(distof fPt)); end setq
      ); end condition #2
     (T
      (princ "\nInvalid option keyword! ")
      ); end condition #3
     ); end cond
   ); end while
   (mapcar 'setvar
 '("FILLMODE" "PLINEWID" "CMDECHO")
 (list 0 dpipepWd 0)); end mapcar
 (command "_.pline" fPt)
 (setvar "CMDECHO" 1)
 (while(= 1(getvar "CMDACTIVE"))
   (command pause)
   ); end while
 (setq dpipepwd (getvar "PLINEWID"))
 (BodyFunction)
 (vla-EndUndoMark actDoc)
(mapcar 'setvar
     '("FILLMODE" "PLINEWID" "CMDECHO" "OSMODE")
     oldVars); end apply
 (princ)
 ); end of c:DUCT

Link to comment
Share on other sites

Hi there, you have recent modification of that lisp here :

http://www.cadtutor.net/forum/showthread.php?96683-Remove-distance-from-each-joint/page2&p=#15

 

And for your request : Why don't you draw all DUCTs and then explode them all at once if you want only lines and arcs...

Regards, M.R.

 

thanx for your reply but its not exploding the mlines at the end.basically its the same lisp which i posted above.

Link to comment
Share on other sites

thanx for your reply but its not exploding the mlines at the end.basically its the same lisp which i posted above.

 

You create new Layer, you draw all DUCTs with different colors, you select all objects on that layer (ducts), you use EXPLODE command on selected objects (all DUCTs)... You at the end turn different colored DUCTs to desired Layer(s)... It'd be good if colors would respond to Layer color, so you can write small routine to (entmod) LINES and ARCS to adequate Layer(s) according to color properties... Iterate through Layer table with (tblnext "LAYER" t (then) nil)... Store layer(s) info in list... Iterate through LINES and ARCS and get their DC 62 and 420... Iterate through layer(s) list and check if layer have the same DC 62 and 420... When match occurs then (entmod) ARC or LINE to put them to adequate DC 8 with correct Layer name... (DC - DXF CODE short abbreviation)... At the end remove Layer where you drawn all DUCTs with LAYDEL command or through LAYER command or through PURGE (Layer) command...

Link to comment
Share on other sites

Or even better :

store last drawn entity in variable for ex. "el" - (setq el (entlast))

draw all DUCTs in adequate Layer(s)...

when finished create sel. set by iterating through entities crated after "el" :

(setq ss (ssadd))
(while (setq el (entnext el))
 (ssadd el ss)
)

then select all objects on "ss" sel. set : SELECT -> !ss -> ENTER

then EXPLODE previous sel. set (EXPLODE -> P -> ENTER)

 

That's it - you have all DUCTs as LINES and ARCS in desired Layer(s)...

 

HTH, M.R.

Link to comment
Share on other sites

Why not use the version that has the multline portions of the code commented out? The original thread in which all modifications came from is at http://www.cadtutor.net/forum/archive/index.php/t-10882.html The code you attached has the polyline portions of the code commented out.

 

thanx for the link ronso.but thats a long thread. could u point me to the exact post where i can find the polyline code.

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.

×
×
  • Create New...