;;; ------------------------------------------------------------------------
;;; CreateReducer.lsp v1.1
;;;
;;; Copyright © January, 2007
;;; Timothy G. Spangler
;;;
;;; Permission to use, copy, modify, and distribute this software
;;; for any purpose and without fee is hereby granted, provided
;;; that the above copyright notice appears in all copies and
;;; that both that copyright notice and the limited warranty and
;;; restricted rights notice below appear in all supporting
;;; documentation.
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED
;;; WARRANTY. ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR
;;; PURPOSE AND OF MERCHANTIBILITY ARE HEREBY DISCLAIMED BY THE
;;; PROGRAMMER.
;;;
;;; -----------------------------------------------------------------------

;;; ------------ COMMAND LINE FUNCTIONS
(defun c:REDUCER (/)(REDUCER_START))
;;; ------------ MAIN FUNCTION
(defun REDUCER_START (/ *error* ActiveDoc Space OldClayer OldCmdEcho OldOsmode LineStart LineEnd
LineAngle TrunkSize ReducerStart SidePoint TrunkDirection FlatSidePoint ReducerAngle ReducerOutlet
ReducerInsul ReducerLength ReducerPt01 ReducerPt02 ReducerPt03 ReducerPt04 ReducerOutCenter
ReducerInsPt01 ReducerInsPt02 ReducerInsPt03 ReducerInsPt04 ReducerInsPt05
ReducerInsPt06 ReducerInsPt07 ReducerInsPt08 )

;;; Begin Error Handler -------------------------------------------------
(defun *error* (MSG)

(if (not (member MSG '("Function cancelled" "quit / exit abort")))
(princ (strcat "\n*** Program Error: " (strcase MSG) " ***"))
(princ "\n... Program Cancelled ...")
)
(while (< 0 (getvar "cmdactive"))
(command)
)
(REDUCER_RESET_ENV)
)
;;; End Error Handler ---------------------------------------------------
(REDUCER_SET_ENV)
)
;;; ------------ SET ENVIROMENT BEFORE LAUNCH
(defun REDUCER_SET_ENV(/)

(setq OldClayer (getvar "CLAYER"))
(setq OldCmdEcho (getvar "CMDECHO"))
(setq OldOsmode (getvar "OSMODE"))

(setvar "CMDECHO" 0)
(command "_undo" "begin")

(vl-load-com)
(setq ActiveDoc (vla-get-activedocument (vlax-get-acad-object)))
(setq Space
(if (= (getvar "cvport") 1)
(vla-get-paperspace ActiveDoc)
(vla-get-modelspace ActiveDoc)
)
)

;; Setup layer for centerline
(REDUCER_CREATE_LAYER "M-HVAC-CNTR" "Mechanical Plan - Ductwork centerline" "CENTER2" "25" "12" "0")
;; Setup layer for insulation
(REDUCER_CREATE_LAYER "M-HVAC-INSL" "Mechanical Plan - Ductwork Insulation" "HIDDEN2" "15" "201" "1")

;; Run elbow
(REDUCER_RUN)
)
;;; ------------ RUN OFFSET SUB ROUTINE - GET VARIABLES
(defun REDUCER_RUN (/ TrunkLine EntList ReducerLayer ReducerTemp)

;; Get properties from current trunk line
(while (null (setq TrunkLine (car(nentsel "\n Select trunk to add offset to: "))))
(princ "\n Duct not selected")
)
(setq EntList (entget TrunkLine))
(setq ReducerLayer (cdr (assoc 8 EntList)))

;; Set layer
(setvar "CLAYER" ReducerLayer)

;; Set reducer properties
(if (equal (cdr (assoc 0 EntList)) "LINE")
(progn
(setq LineStart (cdr (assoc 10 EntList)))
(setq LineEnd (cdr (assoc 11 EntList)))
(setq LineAngle (angle LineStart LineEnd))
(setq TrunkSize (distance LineStart LineEnd))
(setq ReducerStart (polar LineStart LineAngle (/ (distance LineStart LineEnd) 2)))
)
(progn
(princ " Trunk must be a line. ")
(REDUCER_RUN)
)
)

;; Get reducer direction
(setq SidePoint (getpoint ReducerStart "\n Define reducer direction "))
(setq TrunkDirection (REDUCER_GET_PERP LineStart LineEnd SidePoint))

;; Get flat side
(setq ReducerTemp (polar ReducerStart TrunkDirection 12))
(setq FlatSidePoint (getpoint ReducerTemp "\n Define reducer flat side "))
(setq ReducerAngle(REDUCER_GET_PERP ReducerStart ReducerTemp FlatSidePoint))

;; Get reducer outlet size
(setq ReducerOutlet (- TrunkSize 2.0))
(initget 6)
(if (not(setq ReducerOutlet (getreal (strcat "\n Enter reducer outlet size: " ""))))
(setq ReducerOutlet (- TrunkSize 2.0))
)

;; Get reducer insulation
(initget 1 "None Inside Outside Both")
(setq ReducerInsul (getkword "\n Insulation options: (None/Inside/Oustside/Both)"))

;; Get reducer length
(setq ReducerLength (REDUCER_LAWOFSINE 15.0 75.0 (- TrunkSize ReducerOutlet) 0))

;; Create reducer
(REDUCER_CREATE ReducerInsul)
)
;;; ------------ CREATE REDUCER SUB ROUTINE
(defun REDUCER_CREATE (ReducerInsul / ReducerCntrLine01)

;; Create outside points
(setq ReducerPt01 (polar ReducerStart ReducerAngle (/ TrunkSize 2.0)))
(setq ReducerPt02 (polar ReducerStart (REDUCER_ADD_ANGLE ReducerAngle 180.0) (/ TrunkSize 2.0)))
(setq ReducerPt03 (polar ReducerPt01 TrunkDirection ReducerLength))
(setq ReducerPt04 (polar ReducerPt03 (REDUCER_ADD_ANGLE ReducerAngle 180.0) ReducerOutlet))

(setq ReducerOutCenter (polar ReducerPt03 (REDUCER_ADD_ANGLE ReducerAngle 180.0)(/ ReducerOutlet 2.0)))

;; Create reducer
(vlax-invoke space 'addline ReducerPt01 ReducerPt02)
(vlax-invoke space 'addline ReducerPt01 ReducerPt03)
(vlax-invoke space 'addline ReducerPt03 ReducerPt04)
(vlax-invoke space 'addline ReducerPt02 ReducerPt04)

(setq ReducerCntrLine01 (vlax-invoke space 'addline ReducerStart ReducerOutCenter))

;; Set reducer properties
(vlax-put ReducerCntrLine01 'Layer "M-HVAC-CNTR")

;; Set inside insulation points
(setq ReducerInsPt01 (polar ReducerPt01 (REDUCER_ADD_ANGLE ReducerAngle 180.0) 1.0))
(setq ReducerInsPt02 (polar ReducerPt03 (REDUCER_ADD_ANGLE ReducerAngle 180.0) 1.0))
(setq ReducerInsPt03 (polar ReducerPt02 ReducerAngle 1.0))
(setq ReducerInsPt04 (polar ReducerPt04 ReducerAngle 1.0))
;; Set inside insulation points
(setq ReducerInsPt05 (polar ReducerPt01 ReducerAngle 1.0))
(setq ReducerInsPt06 (polar ReducerPt03 ReducerAngle 1.0))
(setq ReducerInsPt07 (polar ReducerPt02 (REDUCER_ADD_ANGLE ReducerAngle 180.0) 1.0))
(setq ReducerInsPt08 (polar ReducerPt04 (REDUCER_ADD_ANGLE ReducerAngle 180.0) 1.0))

;; Set insulation layer
(setvar "CLAYER" "M-HVAC-INSL")

(cond
((= ReducerInsul "Inside")
(vlax-invoke space 'addline ReducerInsPt01 ReducerInsPt02)
(vlax-invoke space 'addline ReducerInsPt03 ReducerInsPt04)
)
((= ReducerInsul "Outside")
(vlax-invoke space 'addline ReducerInsPt05 ReducerInsPt06)
(vlax-invoke space 'addline ReducerInsPt07 ReducerInsPt08)
)
((= ReducerInsul "Both")
(vlax-invoke space 'addline ReducerInsPt01 ReducerInsPt02)
(vlax-invoke space 'addline ReducerInsPt03 ReducerInsPt04)
(vlax-invoke space 'addline ReducerInsPt05 ReducerInsPt06)
(vlax-invoke space 'addline ReducerInsPt07 ReducerInsPt08)
)
)
;; Reset environment
(REDUCER_RESET_ENV)
)
;;; ------------ LAYER CREATION ROUINE
(defun REDUCER_CREATE_LAYER (Layer Descpition Linetype Thickness Color Plot / TmpList VLA-Obj)

;; Check to see if linetype exsists
(if (= (tblsearch "ltype" Linetype) nil)
(if (REDUCER_CHECK_LINETYPE (findfile "acad.lin") Linetype)
(command "linetype" "load" Linetype "acad.lin" "")
(setq Linetype "Continuous")
)
)
;;; ------------ CREATE A LIST FOR ENTMAKE
(setq TmpList
(list
(cons 0 "LAYER")
(cons 100 "AcDbSymbolTableRecord")
(cons 100 "AcDbLayerTableRecord")
(cons 70 0)
)
)
;; Create layer name list
(setq TmpList (append TmpList (list (cons 2 Layer))))
;; Create layer color list
(setq TmpList (append TmpList (list (cons 62 (atoi Color)))))
;; Create layer linetype list
(setq TmpList (append TmpList (list (cons 6 Linetype))))
;; Create layer lineweight list
(setq TmpList (append TmpList (list (cons 370 (atoi Thickness)))))
;; Create layer plot list
(setq TmpList (append TmpList (list (cons 290 (atoi Plot)))))
;; Create layer from first item in the list
(entmake TmpList)
;; Create layer description
(if(or(= 16.1 (atof(getvar "acadver")))(< 16.1 (atof(getvar "acadver"))))
(progn
(setq VLA-Obj(vla-Add (vla-Get-Layers ActiveDoc)Layer))
(vla-Put-Description VLA-Obj Descpition)
(vlax-release-object VLA-Obj)
)
)
)
;;; ------------ CHECKS TO SEE IF A LINETYPE IS AVAILIBLE
(defun REDUCER_CHECK_LINETYPE (LINFile Linetype / OpenFile LineNumber CurrentLine Result)

(setq OpenFile (open LINFile "r"))
(while (setq CurrentLine (read-line OpenFile))
(if (wcmatch CurrentLine "`**")
(progn
(setq LinetypeName (substr(car(REDUCER_STRING_TO_LIST CurrentLine ","))2))
(if (= (strcase Linetype) LinetypeName)
(setq Result T)
)
)
)
)
(close OpenFile)
Result
)
;;; ------------ STRING TO LIST SUB ROUTINE
(defun REDUCER_STRING_TO_LIST (Stg Del / CurChr PosCnt TmpLst TmpStr)

(setq PosCnt 1
TmpStr ""
)
(repeat (1+ (strlen Stg))
(setq CurChr (substr Stg PosCnt 1))
(if (= CurChr Del)
(progn
(setq TmpLst (cons TmpStr TmpLst))
(setq TmpStr "")
)
(setq TmpStr (strcat TmpStr CurChr))
)
(setq PosCnt (1+ PosCnt))
)
(setq TmpLst (reverse TmpLst))
)
;;; ------------ ADD / SUBTRACT ANGLE SUB ROUTINES
(defun REDUCER_ADD_ANGLE (Radians AddAngle / )

(REDUCER_DTR(+ (REDUCER_RTD Radians) AddAngle))
)
(defun REDUCER_SUBTRACT_ANGLE (Radians AddAngle / )

(REDUCER_DTR(- (REDUCER_RTD Radians) AddAngle))
)
;;; ------------ LAW OF SINS (2 ANGLES & 1 SIDE)
(defun REDUCER_LAWOFSINE (SinAngle1 SinAngle2 Side1 Round / A SinA SinB Sidelength)

(setq SinA (sin (REDUCER_DTR SinAngle1)))
(setq SinB (sin (REDUCER_DTR SinAngle2)))
(if (= Round 1)
(setq SideLength (REDUCER_RND (/ (* Side1 SinB) SinA)4))
(setq SideLength (/ (* Side1 SinB) SinA))
)
Sidelength
)
;;; ------------ GET PERPENDICULAR POINT
(defun REDUCER_GET_PERP (StartPoint EndPoint Point / EntList LineStart LineEnd LineAngle PerpAngle)

(setq PerpStart (trans StartPoint 0 1))
(setq PerpEnd (trans EndPoint 0 1))
(setq PerpAngle (angle PerpStart PerpEnd))

(if (minusp (sin (- (angle PerpStart Point) PerpAngle))) ;determine direction
(setq NewAngle (- PerpAngle (/ pi 2))) ;if "below" -90 deg
(setq NewAngle (+ PerpAngle (/ pi 2))) ;or "above" +90 deg
)
NewAngle
)
;;; ------------ ROUND NUMBER
(defun REDUCER_RND (Number Precision)
(setq Number(distof (rtos Number 4 Precision)4))
)
;; ------------ DEGREES / RADIANS SUB ROUTINES
(defun REDUCER_DTR (NumberOfDegrees)
(* pi (/ NumberOfDegrees 180.0))
)
(defun REDUCER_RTD (NumberOfRadians)
(* 180.0 (/ NumberOfRadians pi))
)
;;; ------------ RESET SYSEM VARIABLES
(defun REDUCER_RESET_ENV (/)

(setvar "CMDECHO" OldCmdEcho)
(setvar "CLAYER" OldClayer)
(setvar "OSMODE" OldOsmode)
(command "_undo" "end")
(princ)
)
;;;
;;; Echos to the command line
(princ "\n CreateReducer v1.1 ©Timothy Spangler, \n January, 2007....loaded.")
(terpri)
(princ "C:REDUCER")
(print)
;;; End echo

Advertisements