;;;=======================[ FlexDuct.lsp ]==============================
;;; Author: Copyright© 2014 Charles Alan Butler (CAB)
;;; Contact or Updates @ http://www.TheSwamp.org
;;; Version: 2.3 Dec 28,2014
;;; Purpose: Create Flex Duct from a centerline that the user picks
;;; Centerline may be anything vla-curve will handle
;;; 12.28.14 added Rounded duct surface
;;; Sub_Routines:
;;; makePline which creates a LW Polyline
;;; Restrictions: UCS is supported
;;; Duct Layer is hard coded, see var Flexlayer
;;; Debug only error handler at this time
;;; Known Issues:
;;; Tight curves cause pline jacket distortion
;;; Added warning when this is about to occur
;;; Returns: none
;;;=====================================================================
;;; THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED ;
;;; WARRANTY. ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR ;
;;; PURPOSE AND OF MERCHANTABILITY ARE HEREBY DISCLAIMED. ;
;;; ;
;;; You are hereby granted permission to use, copy and modify this ;
;;; software without charge, provided you do so exclusively for ;
;;; your own use or for use by others in your organization in the ;
;;; performance of their normal duties, and provided further that ;
;;; the above copyright notice appears in all copies and both that ;
;;; copyright notice and the limited warranty and restricted rights ;
;;; notice below appear in all supporting documentation. ;
;;;=====================================================================
(vl-load-com)
;; Command Line Call, User picks pline centerline(s)
(defun c:Flx() (MyFlex nil ; no pre selected centerline
nil ; use default settings
))

;; Lisp entry point
(defun MyFlex (PLent variables /
cl-ent ribWidth RibShort RibLong collar
dist steps ribFlag pt curAng curDer
RibPtLst1 RibPtLst2 p1 p2 doc space
cflag cl-len ribRadius tmp NewPline NewPline2
pl1 pl2 cnt errflag InsulThick FlexColor
FlexLayer ss FlexCLLayer lyrent *error* pass1
BulgeLst1 BulgeLst2 bulge DuctSurface
)
(defun *error* (msg) (vl-bt))

(setq Doc (vla-get-activedocument (vlax-get-acad-object)))
(vla-endundomark doc)
(vla-startundomark doc)

;; \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/
;; Variables set by calling routine must be in pairs
;; '((FlexLayer "Duct")(FlexColor acred)(collar 0))
(if (vl-consp variables)
(mapcar (function (lambda (x)(set (car x) (cadr x)))) variables)
)
;; Default settings, Change these if you want

(or FlexLayer (setq FlexLayer "0" )) ; put your Duct layer here
(or FlexColor (setq FlexColor nil )) ; put your color over ride here or nil
(or FlexCLLayer(setq FlexCLLayer "" )) ; put your Duct Center Line layer here, "" or nil = no change
(or InsulThick (setq InsulThick 0 )) ; to be added to duct diameter, use 2 for 1" insulation
(or collar (setq collar 4.0 )) ; collar length at each end, can be 0
(setq cflag t) ; Add collar flag
(or DelCL (setq DelCL nil )) ; delete the centerline t=Yes nil=No
(or GroupFlex (setq GroupFlex nil )) ; make flex duct a Group t=Yes nil=No
(if DuctDiam ; override the first time only
(or duct:dia (setq duct:dia DuctDiam)) ; Duct Diameter, global variable
(or duct:dia (setq duct:dia 16.0)) ; Duct Diameter, global variable
)
(setq DuctSurface "Rounded") ; R = Rounded surface P = Pointed surface ; CAB 122814
(setq bulge 1.0) ; bulge for rounded duct surface ; CAB 122814
;; \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/

;; -------- Local Functions ---------
;; by CAB 10/05/2007
;; Expects pts to be a list of 2D or 3D point lists
;; Returns new pline object, note calling with BlockDEF and the pline is
;; created in the BlockDEF and not in model space
(defun makepline (spc pts blst / norm elv pline)
(setq norm (trans '(0 0 1) 1 0 t)
elv (caddr (trans (car pts) 1 norm))
)
;; flatten the point list to 2d
(if (= (length (car pts)) 2) ; 2d point list
(setq pts (apply 'append pts))
(setq pts (apply 'append (mapcar '(lambda (x) (list (car x) (cadr x))) pts)))
)
(setq
pts (vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbdouble (cons 0 (1- (length pts))))
pts
)
)
)
(setq pline (vla-addlightweightpolyline spc pts))
(vla-put-elevation pline elv)
(vla-put-normal pline (vlax-3d-point norm))
(if blst
(foreach b blst (vla-setbulge pline (car b)(cadr b)))
)
pline
)

;; -------------------------------------
;; Does not work in ACAD 2000
(defun _CreateAnonymousGroup ( ) ; courtesy of Michael Puckett
(vla-add
(vla-get-groups
(vla-get-activedocument (vlax-get-acad-object))) "*")
)

;; =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
;; S T A R T H E R E
;; =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
(while ; Main Loop
(progn
(if PLent
(setq cl-ent (list PLent 0)) ; automatic mode
(progn
(prompt (strcat "\nDuct diameter is set to " (vl-princ-to-string duct:dia)))
(setvar "errno" 0) ; must pre set the errno to 0
(initget "Diameter Type")
(setq cl-ent
(entsel (strcat "\nSelect center line of flex duct.[Type/"DuctSurface "][Diameter] Enter to quit.")))
)
) ; endif PLent

;;
(cond
((null (setq lyrent (tblobjname "layer" Flexlayer)))
(prompt (strcat "\nDuct Layer " Flexlayer " does not exist."))
)
((= 4 (logand 4 (cdr (assoc 70 (entget lyrent)))))
(prompt (strcat "\nDuct Layer " Flexlayer " is LOCKED."))
)
((and FlexCLlayer (/= FlexCLlayer "")
(null (setq lyrent (tblobjname "layer" FlexCLlayer)))
(princ (strcat "\n*** Center Line Layer " FlexCLlayer " does not exist. ***"))
(setq FlexCLlayer nil))
)
((= (getvar "errno") 52) ; exit if user pressed ENTER
nil ; exit loop
)
((= cl-ent "Diameter")
(initget (+ 2 4))
(setq tmp (getdist (strcat "\nSpecify duct diameter : ")))
(and tmp (setq duct:dia tmp))
t ; stay in loop
)
((= cl-ent "Type")
(initget "Rounded Pointed")
(setq tmp (getkword (strcat "\nEnter Duct Type (Rounded or Pointed): ")))
(and tmp (setq DuctSurface tmp))
t ; stay in loop
)

((vl-consp cl-ent)
;; check that entity is a curve before making the duct
(if (not (vl-catch-all-error-p
(setq tmp (vl-catch-all-apply 'vlax-curve-getpointatparam (list (car cl-ent) 0.0)))))
(progn ; OK to make duct
(setq cl-ent (car cl-ent) ; Center Line
ribWidth (* duct:dia 0.167)
RibShort (+ duct:dia InsulThick) ; add insulation
RibLong (+ RibShort (* ribWidth 2))
)
;; all ribs short when Rounded Duct Sides
(if (= DuctSurface "Rounded") (setq RibLong RibShort)) ; CAB 122814

;; centerline length, spacing @ center line is uniform
(setq cl-len (vlax-curve-getdistatparam cl-ent (vlax-curve-getendparam cl-ent))
steps (/ cl-len ribWidth)
)
(if (= (logand (fix steps) 1) 1) ; T = odd
(setq steps (fix steps))
(setq steps (1+ (fix steps)))
)
(setq ribWidth (/ (- cl-len 0.25) (1- steps))
dist 0.125 ; distance along center line
)

(setq ribFlag 0
cnt 0 ; vertex counter
pass1 t
pl1 nil
pl3 nil
errflag nil
RibPtLst1 nil
RibPtLst2 nil
BulgeLst1 nil
BulgeLst2 nil
)

;; ================================================
;; ---------- Create Rib End Points -----------
;; ================================================
(repeat steps
(setq pt (vlax-curve-getpointatdist cl-ent dist))
(setq curDer (trans
(vlax-curve-getfirstderiv cl-ent (vlax-curve-getparamatpoint cl-ent pt))
0 1)
)
;; Get angle 90 deg to curve
(setq curAng (+ (/ pi 2) (angle '(0 0) curDer)))
(setq ribRadius (if (zerop ribFlag) (/ RibShort 2) (/ RibLong 2)))
(setq pt (trans pt 0 1)) ; WCS > UCS
(setq p1 (polar pt curAng ribRadius))
(setq p2 (polar pt (+ pi curAng) ribRadius))
(if (and cflag pass1) ; create start collar points
(setq RibPtLst1 (list (polar p1 (angle curDer '(0 0)) collar))
RibPtLst2 (list (polar p2 (angle curDer '(0 0)) collar))
pass1 nil
)
)

;; this collection method creates a woven pline
(cond
((null pl1) ; first time through
(setq RibPtLst1 (cons p1 RibPtLst1)
RibPtLst2 (cons p2 RibPtLst2)
)
)
((= (logand (setq cnt (1+ cnt)) 1) 1) ; T = odd cnt, Main Rib
(setq RibPtLst1 (cons pl2 RibPtLst1)
RibPtLst1 (cons p2 RibPtLst1)
RibPtLst2 (cons pl1 RibPtLst2)
RibPtLst2 (cons p1 RibPtLst2)
)
)
((setq RibPtLst1 (cons pl1 RibPtLst1) ; end caps of ribs
RibPtLst1 (cons p1 RibPtLst1)
RibPtLst2 (cons pl2 RibPtLst2)
RibPtLst2 (cons p2 RibPtLst2)
)
)
)
(if (and pl3 (inters p1 p2 pl3 pl4 t))
(setq errflag t) ; overlap of ribs in tight turns
)
(setq ribFlag (- 1 ribFlag) ; toggle flag
dist (+ ribWidth dist)
pl3 pl1
pl4 pl2
pl1 p1
pl2 p2
)
) ; repeat steps

(cond ; CAB 122814
((= DuctSurface "Pointed") (setq BulgeLst1 nil BulgeLst2 nil))
((= DuctSurface "Rounded")
(setq cnt (if cflag 0 -1))
(repeat (1- (length RibPtLst1))
(if (and (> (setq cnt (1+ cnt)) 1)(/= (logand cnt 1) 1)) ; Cap of Rib
(setq BulgeLst1 (cons (list cnt bulge) BulgeLst1)
BulgeLst2 (cons (list cnt (- bulge)) BulgeLst2)
bulge (- bulge))
)
)
)
)

(setq RibPtLst1 (cons p2 RibPtLst1)
RibPtLst2 (cons p1 RibPtLst2)
)

(if cflag ; create end collar points
(setq RibPtLst1 (cons (polar p2 (angle '(0 0) curDer) collar) RibPtLst1)
RibPtLst2 (cons (polar p1 (angle '(0 0) curDer) collar) RibPtLst2)
)
)

;; -------- point list to WCS ------------
(setq RibPtLst1 (mapcar (function (lambda (x) (trans x 1 0))) RibPtLst1))
(setq RibPtLst2 (mapcar (function (lambda (x) (trans x 1 0))) RibPtLst2))

;; -------- create jacket plines ------------
(or space
(setq space
(if (zerop (vla-get-activespace doc))
(if (= (vla-get-mspace doc) :vlax-true)
(vla-get-modelspace doc) ; active VP
(vla-get-paperspace doc)
)
(vla-get-modelspace doc)
)
)
)

(cond
((and errflag
(progn
(initget "Yes No")
(= "No"
(cond
((getkword "\nTurns too tight, Proceed? [Yes/No]:"))
("Yes")))
)
)
t ; skip the create & stay in loop
)
((setq newpline (makePline space RibPtLst1 BulgeLst1))
(vla-put-layer newpline Flexlayer)
(if FlexColor (vla-put-color newpline FlexColor))
;;(vla-put-elevation newpline z)

(setq newpline2 (makePline space RibPtLst2 BulgeLst2))
(vla-put-layer newpline2 Flexlayer)
(if FlexColor (vla-put-color newpline2 FlexColor))
;;(vla-put-elevation newpline z)

(if DelCL
(entdel cl-ent) ; remove the centerline object
(if (and FlexCLlayer (/= FlexCLlayer "")
(setq lyrent (tblobjname "layer" (cdr(assoc 8 (entget cl-ent)))))
(or (/= 4 (logand 4 (cdr (assoc 70 (entget lyrent)))))
(prompt "\n*** Center Line layer is LOCKED ***"))
)
(vla-put-layer (vlax-ename->vla-object cl-ent) FlexCLlayer)
)
)
;| COMMAND method removed due to errors in ACAD2008
(if GroupFlex
(progn
(setq ss (ssadd))
(ssadd (vlax-vla-object->ename newpline) ss)
(ssadd (vlax-vla-object->ename newpline2) ss)
(or DelCl (ssadd cl-ent ss))
(if (vl-cmdf "_.-group" "_create" "*" "" ss "")
(princ "\nGrouping Done")
(princ "\nError Grouping")
)
)
)
|;
(if GroupFlex
(progn ; using Michael Puckett's method
(setq GroupObjects (list newpline newpline2))
(or DelCl (setq GroupObjects
(cons (vlax-ename->vla-object cl-ent) GroupObjects)))
(setq myGroup (_CreateAnonymousGroup))
(vlax-invoke myGroup 'AppendItems GroupObjects)
)
)

)
) ; cond
) ; progn ; OK to make duct
(princ "\nError - Can not use that object, Try again.")
) ; endif
(not PLent) ; exit flag, exit if PLent
)
(t (princ "\nMissed Try again."))
) ; cond stmt

) ; progn - while
) ; while
(vla-endundomark doc)
(and space (vlax-release-object space))
(vlax-release-object doc)
;;----------- E N D O F L I S P ----------------------------
(princ)
)
(prompt "\nFlex Duct loaded, Enter FLEX to run.")
(princ)
(c:flx)

Advertisements