;;; Marko Ribar Duct Draw Routine
;;; Saved from here: http://www.cadtutor.net/forum/showthread.php?96683-Remove-distance-from-each-joint/page2&p=#15
(defun c:duct (/ *error* GetPlineVer asmi-PlineSegmentDataList asmi-LayersUnlock
asmi-LayersStateRestore PipeMLineStyle SideCalculate BodyFunction actDoc ang1 ang2
ang3 ang4 Bulge el enDist fPt int1 int2 lEnt lObj lPln mllst oldVars oldWd plEnd
pllst plStart1 plStart2 plx prDir ptLst segCnt segLst segNLst segNum Start stDist
stLst tan4 tAng vlaPln cFlg
)

(vl-load-com)

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

(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 '()
)
(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))
)
)
)
)
(repeat 4
(setq cLst (cdr cLst))
)
)
(setq outLst
(append outLst
(list
(list
(cdr (assoc 10 cLst))
)
)
)
cLst nil
)
)
)
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)
)
)
)
)
(vla-put-lock lay :vlax-false)
(if
(vl-catch-all-error-p
(vl-catch-all-apply
'vla-put-freeze
(list lay :vlax-false)
)
)
t
)
)
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
)
)
(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)
(cons 51 (/ pi 2.0))
(cons 52 (/ pi 2.0))
'(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 of PipeMLineStyle

(defun SideCalculate (Wdth Ang / Rad)
(setq Ang (- pi Ang))
(setq Rad (+ (* 0.5 Wdth)
(if (= dpipeelb "Mitered")
0.0
dpiperad
)
)
)
(+ (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)
)
(setvar "CMDECHO" 0)
(while (/= 1 (length segLst))
(setq stDist
(vlax-curve-getdistatpoint vlaPln
(caar segLst)
)
enDist
(vlax-curve-getdistatpoint vlaPln
(caadr segLst)
)
)
(if ( ang1 ang2)
(setq ang3 (- ang1 ang2))
(setq ang3 (- ang2 ang1))
)
(setq ang3 (- pi ang3)
tAng ang3
)
(if (minusp ang3)
(setq ang3 (- ang3))
)
)
)
(if
(or
(equal ang1 ang2 0.000001)
(= 2 (length segLst))
)
(setq plEnd
(vlax-curve-getpointatdist vlaPln
enDist
)
prDir t
)
(setq plEnd
(vlax-curve-getpointatdist vlaPln
(- enDist (SideCalculate (cadar segLst) ang3))
)
prDir nil
)
)
(if
(< 2 (length segLst))
(setq plStart2
(vlax-curve-getpointatdist vlaPln
(+ enDist (SideCalculate (cadar segLst) ang3))
)
)
)
(if (and (not (cdddr segLst)) plStart2 ang2)
(setq plStart2 (polar plStart2 (- ang2 (/ pi 2.0)) 1.0))
)
(if (< 2 (length segLst))
(if
(= (cadar segLst) (nth 2 (car segLst)))
(setq ptLst
(mapcar
'(lambda (x) (trans x 0 1))
(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
)
(*
(+ (* 0.5 (cadar segLst))
(if (= dpipeelb "Mitered")
0.0
dpiperad
)
)
(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 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)))
)
)
)
(setq ptLst
(mapcar
'(lambda (x) (trans x 0 1))
(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))
)
)
)
)
)
(setq plStart1 (trans plStart1 0 1)
plEnd (trans plEnd 0 1)
)
(if plStart2
(setq plStart2 (trans plStart1 0 1))
)

(if
(= (cadar segLst) (nth 2 (car segLst)))
(command "_.MLINE"
"_ST"
"DUCT_PIPE"
"_S"
(cadar segLst)
"_J"
"_Z"
"_non"
plStart1
"_non"
plEnd
""
)
)
(setq el (entlast))
(if (<= 2 (length (cdr segLst)))
(progn
(if (= (cadar (cdr segLst)) (nth 2 (car (cdr segLst))))
(progn
(setq stDist
(vlax-curve-getdistatpoint
vlaPln
(caar (cdr segLst))
)
enDist
(vlax-curve-getdistatpoint
vlaPln
(caadr (cdr segLst))
)
)
(if
(or
(not Start)
prDir
)
(setq plStart1
(vlax-curve-getpointatdist
vlaPln
stDist
)
Start t
)
(setq plStart1
(vlax-curve-getpointatdist
vlaPln
(+ stDist
(SideCalculate (cadar (cdr segLst)) ang3)
)
)
)
)
(if
(or
(equal ang1 ang2 0.000001)
(= 2 (length segLst))
)
(setq plEnd
(vlax-curve-getpointatdist
vlaPln
enDist
)
prDir t
)
(setq plEnd
(vlax-curve-getpointatdist
vlaPln
(- enDist
(SideCalculate (cadar (cdr segLst)) ang3)
)
)
prDir nil
)
)
)
(progn
(setq stDist
(vlax-curve-getdistatpoint
vlaPln
(caar (cddr segLst))
)
enDist
(vlax-curve-getdistatpoint
vlaPln
(if (cdddr segLst)
(caadr (cddr segLst))
(vlax-curve-getstartpoint vlaPln)
)
)
)
(if
(or
(not Start)
prDir
)
(setq plStart1
(vlax-curve-getpointatdist
vlaPln
stDist
)
Start t
)
(setq plStart1
(vlax-curve-getpointatdist
vlaPln
(+ stDist
(SideCalculate (cadar (cddr segLst)) ang3)
)
)
)
)
(if
(and
(or
(equal ang1 ang2 0.000001)
(= 2 (length segLst))
)
(not (equal enDist 0.0 1e-6))
)
(setq plEnd
(vlax-curve-getpointatdist
vlaPln
enDist
)
prDir t
)
(setq plEnd
(vlax-curve-getpointatdist
vlaPln
(- enDist
(SideCalculate (cadar (cddr segLst)) ang3)
)
)
prDir nil
)
)
)
)
(if
(= (cadar (cdr segLst)) (nth 2 (car (cdr segLst))))
(command "_.MLINE"
"_ST"
"DUCT_PIPE"
"_S"
(cadar (cdr segLst))
"_J"
"_Z"
"_non"
plStart1
"_non"
plEnd
""
)
(cond
((and (not (equal enDist 0.0 1e-6)) (cddr segLst))
(command "_.MLINE"
"_ST"
"DUCT_PIPE"
"_S"
(cadar (cddr segLst))
"_J"
"_Z"
"_non"
plStart1
"_non"
plEnd
""
)
)
((and (equal enDist 0.0 1e-6) (cddr segLst))
(command "_.MLINE"
"_ST"
"DUCT_PIPE"
"_S"
(cadar (cddr segLst))
"_J"
"_Z"
"_non"
(vlax-curve-getendpoint vlaPln)
"_non"
(polar (vlax-curve-getendpoint vlaPln) (- ang2 (/ pi 2.0)) 1.0)
""
)
)
)
)
(if (not (eq el (entlast)))
(setq el (entlast))
(setq el nil)
)
(if (< 2 (length segLst))
(if
(or (/= (cadar segLst) (nth 2 (car segLst)))
(and (/= "Segmented" dpipeelb)
(not (equal ang1 ang2 0.000001))
)
)
(progn
(if (entget lEnt)
(entdel lEnt)
)
(setvar "PLINEWID" 0.0)
(setvar "OSMODE" 1)
(setvar "APERTURE" 1)
(command "_.PLINE")
(foreach p ptLst
(command p)
)
(command "_C")
(setvar "OSMODE" (nth 3 oldVars))
(setvar "PLINEWID" dpipepWd)
(if (not (entget lEnt))
(entdel lEnt)
)
)
(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 "")
)
)
)
)
(if (and (equal enDist 0.0 1e-6) (cddr segLst))
(progn
(setq ptLst
(list
(polar (vlax-curve-getpointatparam vlaPln
(float (1- (vlax-curve-getendparam vlaPln)))
)
ang2
(/ (cadr (cadr segLst)) 2.0)
)
(polar (vlax-curve-getendpoint vlaPln) ang2 (/ (cadr (caddr segLst)) 2.0))
(polar (vlax-curve-getendpoint vlaPln) ang2 (- (/ (cadr (caddr segLst)) 2.0)))
(polar (vlax-curve-getpointatparam vlaPln
(float (1- (vlax-curve-getendparam vlaPln)))
)
ang2
(- (/ (cadr (cadr segLst)) 2.0))
)
)
)
(if (entget lEnt)
(entdel lEnt)
)
(setvar "PLINEWID" 0.0)
(setvar "OSMODE" 1)
(setvar "APERTURE" 1)
(command "_.PLINE")
(foreach p ptLst
(command p)
)
(command "_C")
(setvar "OSMODE" (nth 3 oldVars))
(setvar "PLINEWID" dpipepWd)
(if (not (entget lEnt))
(entdel lEnt)
)
)
)
(if
(and (= dpipeelb "Mitered")
(not (equal ang1 ang2 0.000001))
(< 2 (length segLst))
)
(progn
(setq plx (entget (entlast)))
(setq int1 (inters (caaddr (setq segNLst (asmi-PlineSegmentDataList (entlast))))
(polar (caaddr segNLst) (- ang1 (/ pi 2.0)) 1.0)
(car (nth 4 segNLst))
(polar (car (nth 4 segNLst)) (- ang2 (/ pi 2.0)) -1.0)
nil
)
)
(setq int2 (inters (car (last segNLst))
(polar (car (last segNLst)) (- ang2 (/ pi 2.0)) -1.0)
(caadr segNLst)
(polar (caadr segNLst) (- ang1 (/ pi 2.0)) 1.0)
nil
)
)
(setq plx
(mapcar
'(lambda (x)
(if (= (car x) 10)
(cons
10
(if
(vl-member-if
'(lambda (y)
(equal
(mapcar '+ '(0.0 0.0) (trans (cdr x) (cdr (assoc -1 plx)) 0))
y
1e-4
)
)
(list int1 int2)
)
(mapcar
'+
'(0.0 0.0)
(trans
(car
(vl-member-if
'(lambda (y)
(equal (mapcar '+
'(0.0 0.0)
(trans (cdr x) (cdr (assoc -1 plx)) 0)
)
y
1e-4
)
)
(list int1 int2)
)
)
0
(cdr (assoc -1 plx))
)
)
(cdr x)
)
)
x
)
)
plx
)
)
(entupd (cdr (assoc -1 (entmod plx))))
)
)
(if
(and (= dpipeelb "Radius")
(not (equal ang1 ang2 0.000001))
(vla-object (entlast))
tAng (abs (- ang2 ang1))
)
(if (> tAng pi)
(if (< ang1 ang2)
(setq ang1 (+ ang1 pi)
ang2 (- ang2 pi)
)
(setq ang1 (- ang1 pi)
ang2 (+ ang2 pi)
)
)
)
(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))
)
)
(if (and el (entget el))
(entdel el)
)
)
)
(setq segLst (cdr segLst))
)
(if (entget lEnt)
(entdel lEnt)
)
(asmi-LayersStateRestore stLst)
)
)
) ; end of Body Function

;;;--- MAIN FUNCTION START ---;;;

(PipeMLineStyle)
(if (not dpipepWd)
(setq dpipepWd 1.0)
)
(setq oldWd dpipepWd
oldVars (mapcar 'getvar '("FILLMODE" "PLINEWID" "CMDECHO" "OSMODE" "APERTURE"))
)
(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/"
)
(if (= dlastelb "Segmented")
"/"
"Segmented/"
)
(if (/= "Mitered" dlastelb "Segmented")
(strcat ": ")
"Radius: "
)
)
)
)
(if (or (= dpipeelb "Mitered") (and (not dpipeelb) (= dlastelb "Mitered")))
(progn
(initget 6)
(setq dlasttan dpipetan
dpipetan (getdist (strcat "\nSpecify elbow throat length : "
)
)
)
(if (not dpipetan)
(setq dpipetan dlasttan)
)
(if (not dpipeelb)
(setq dpipeelb dlastelb)
)
(setq dlasttan nil)
)
(progn
(initget 6)
(setq dlastrad dpiperad
dpiperad (getdist (strcat "\nSpecify elbow throat radius : "
)
)
)
(if (not dpiperad)
(setq dpiperad dlastrad)
)
(if (not dpipeelb)
(setq dpipeelb dlastelb)
)
)
)
(while (not cFlg)
(initget 129)
(setq fPt
(getpoint
(strcat
"\nSpecify start point or width : "
)
)
)
(cond
((= 'list (type fPt))
(setq cFlg t)
)
((= 'REAL (type (distof fPt)))
(setq dpipepWd (distof fPt))
)
(t
(princ "\nInvalid option keyword! ")
)
)
)
(mapcar 'setvar
'("FILLMODE" "PLINEWID" "CMDECHO")
(list 0 dpipepWd 0)
)
(command "_.PLINE" "_non" fPt)
(setvar "CMDECHO" 1)
(while (= 1 (getvar "CMDACTIVE"))
(command "\\")
)
(setq dpipepwd (getvar "PLINEWID"))
(BodyFunction)
(vla-endundomark actDoc)
(mapcar 'setvar
'("FILLMODE" "PLINEWID" "CMDECHO" "OSMODE" "APERTURE")
oldVars
)
(princ)
) ; end of C:DUCT
(c:duct)

Advertisements