Convert All 3D Polylines to 2D Polylines


;;; Convert All 3D Polylines to 2D Polylines
;;; Created by peter.. saved from here: http://forums.augi.com/showthread.php?52607-How-to-convert-3D-Polylines-to-2D-Polylines
;;; Slightly modified by Igal Averbuh 2017 (added option for all 3D Polylines)

(defun C:P3D (/ intCount
lstCoordiantes
objDocument
obj2dPolyline
obj3dPolyline
ssSelections
strProperty
)
(if (setq ssSelections (ssget "X" (list (cons 0 "polyline"))))
(vlax-for obj3dPolyline (vla-get-activeselectionset
(setq objDocument (vla-get-activedocument
(vlax-get-acad-object))))
(if (= (vla-get-objectname obj3dPolyline) "AcDb3dPolyline")
(progn
(setq intCount 0
lstCoordinates (mapcar
'(lambda (sngCoordinate)
(if (= (/ (setq intCount (1+ intCount)) 3.0)
(/ intCount 3)
)
nil
sngCoordinate
)
)
(vlax-get obj3dPolyline "coordinates")
)
lstCoordinates (vl-remove nil lstCoordinates)
obj2dPolyline (vla-addlightweightpolyline
(vla-get-block
(vla-get-activelayout objDocument))
(listtosafearray 5 lstCoordinates))
)
(foreach strProperty (list "truecolor" "layer" "linetype" "closed")
(vlax-put obj2dPolyline strProperty (vlax-get obj3dPolyline strProperty))
)
(vla-delete obj3dPolyline)
)
)
)
)
(princ)
)

; This function creates a safearray from a list and the safearray type symbol
; for example: (listtosafearray vlax-vbinteger (list 0) )

(defun ListToSafeArray (symSafeArrayType lstItems / safArray)
(setq safArray (vlax-make-safearray symSafeArrayType (cons 0 (1- (length lstItems)))))
(vlax-safearray-fill safArray lstItems)
)

;vlax-vbInteger (2) Integer
;vlax-vbLong (3) Long integer
;vlax-vbSingle (4) Single-precision floating-point number
;vlax-vbDouble (5) Double-precision floating-point number
;vlax-vbString (8) String
;vlax-vbObject (9) Object
;vlax-vbBoolean (11) Boolean
;vlax-vbVariant (12) Variant

(prin1)
(c:p3d)

Convert user selected 3D Polylines to 2D Polylines


;;; Convert user selected 3D Polylines to 2D Polylines
;;; Created by by Tony Hotchkiss saved from CADALYST 09/03 AutoLISP Solutions

(defun pline-3d-2d ()
(vl-load-com)
(setq *thisdrawing* (vla-get-activedocument
(vlax-get-acad-object)
) ;_ end of vla-get-activedocument
*modelspace* (vla-get-ModelSpace *thisdrawing*)
) ;_ end of setq
(setq 3d-pl-list
(get-3D-pline)
) ;_ end of setq
(if 3d-pl-list
(progn
(setq vert-array-list (make-list 3d-pl-list))
(setq n (- 1))
(repeat (length vert-array-list)
(setq vert-array (nth (setq n (1+ n)) vert-array-list))
(setq lyr (vlax-get-property (nth n 3d-pl-list) 'Layer))
(setq obj (vla-AddPolyline *modelspace* vert-array))
(vlax-put-property obj 'Layer lyr)
) ;_ end of repeat
(foreach obj 3d-pl-list (vla-delete obj))
) ;_ end of progn
) ;_ end of if
) ;_ end of pline-3d-2d

(defun get-3D-pline ()
(setq pl3dobj-list nil
obj nil
3d "AcDb3dPolyline"
) ;_ end of setq
(setq selsets (vla-get-selectionsets *thisdrawing*))
(setq ss1 (vlax-make-variant "ss1"))
(if (= (vla-get-count selsets) 0)
(setq ssobj (vla-add selsets ss1))
) ;_ end of if
(vla-clear ssobj)
(setq Filterdata (vlax-make-variant "POLYLINE"))
(setq no-ent 1)
(while no-ent
(vla-Selectonscreen ssobj)
(if (> (vla-get-count ssobj) 0)
(progn
(setq no-ent nil)
(setq i (- 1))
(repeat (vla-get-count ssobj)
(setq
obj (vla-item ssobj
(vlax-make-variant (setq i (1+ i)))
) ;_ end of vla-item
) ;_ end of setq
(cond
((= (vlax-get-property obj "ObjectName") 3d)
(setq pl3dobj-list
(append pl3dobj-list (list obj))
) ;_ end of setq
)
) ;_ end-of cond
) ;_ end of repeat
) ;_ end of progn
(prompt "\nNo entities selected, try again.")
) ;_ end of if
(if (and (= nil no-ent) (= nil pl3dobj-list))
(progn
(setq no-ent 1)
(prompt "\nNo 3D-polylines selected.")
(quit)
) ;_ end of progn
) ;_ end of if
) ;_ end of while
(vla-delete (vla-item selsets 0))
pl3dobj-list
) ;_ end of get-3D-pline

(defun get-3D-pline-old ()
(setq no-ent 1)
(setq filter '((-4 . "")
)
) ;_ end of setq
(while no-ent
(setq ss (ssget filter)
k (- 1)
pl3dobj-list nil
obj nil
3d "AcDb3dPolyline"
) ;_ end-of setq
(if ss
(progn
(setq no-ent nil)
(repeat (sslength ss)
(setq ent (ssname ss (setq k (1+ k)))
obj (vlax-ename->vla-object ent)
) ;_ end-of setq
(cond
((= (vlax-get-property obj "ObjectName") 3d)
(setq pl3dobj-list
(append pl3dobj-list (list obj))
) ;_ end of setq
)
) ;_ end-of cond
) ;_ end-of repeat
) ;_ end-of progn
(prompt "\nNo 3D-polylines selected, try again.")
) ;_ end-of if
) ;_ end-of while
pl3dobj-list
) ;_ end of get-3D-pline-old

(defun make-list (p-list)
(setq i (- 1)
vlist nil
calist nil
) ;_ end of setq
(repeat (length p-list)
(setq obj (nth (setq i (1+ i)) p-list)
coords (vlax-get-property obj "coordinates")
ca (vlax-variant-value coords)
) ;_ end-of setq
(setq calist (append calist (list ca)))
) ;_ end-of repeat
) ;_ end-of make-list

(defun c:p2d ()
(pline-3d-2d)
(princ)
) ;_ end of pl32

(c:p2d)

Select Hatches with same scale as scale of user selected hatch


;;; Select Hatches with same scale as scale of user selected hatch
;;; Based on ttray33y approach: http://www.cadtutor.net/forum/showthread.php?90752-Lisp-for-selecting-hatches-based-on-scale
;;; Slightly modified by Igal Averbuh 2017 (added option to operate with Scale of user selected hatch)

; to change the pattern scale
;(vla-put-patternscale hatchObject 2.0)

(defun C:hs(/ ent count)
(vl-load-com)
(setvar "cmdecho" 0)

; select hatch entity and get the ename
(setq hatchObject (car (entsel "\nSelect example hatch object: ")))

; convert the ename to a vla-object
(setq hatchObject (vlax-ename->vla-object hatchObject))

; to get the pattern scale
(setq Sel (vla-get-patternscale hatchObject))

(setq ent(ssget (list(cons 0 "HATCH")(cons 41 Sel))))

(if (and ent (> (sslength ent) 0))

(progn
(setq count(sslength ent))

(princ (strcat "Selected " (itoa count) " Hatches."))

)
)
(setvar "cmdecho" 1)
(princ)
)

(princ)
(c:hs)

Create closed area Hatch already drawn by polyline with option to edit alredy created hatch dynamicly


;;; Create closed area Hatch already drawn by polyline with option to edit alredy created hatch dynamicly
;;; Modified by Igal Averbuh 2017
;;; Based on Marko Ribar routine published here: http://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/2-click-solid-hatch/td-p/6055800
;;; end other developers subroutines with respect to them

(defun c:dhe ( / *error* GetHatchNames Sel Ent EntData oData nStyle BasePt HatchList Pos
TogAngle tempList tempPt tempData )

(defun *error* ( msg )

(vl-bt)
(if oData (entmake oData))
(if Ent (entdel Ent))
(if msg (prompt (strcat "\n Error-> " msg)))
(redraw)
)
;--------------------------------
(defun GetHatchNames ( filePath / Opened tempStr tempPos tempName HatchList )

(if (setq Opened (open filePath "r"))
(while (setq tempStr (read-line Opened))
(if
(and
(= (substr tempStr 1 1) "*")
(setq tempPos (vl-string-search "," tempStr))
(setq tempName (substr tempStr 2 (1- tempPos)))
(/= (strcase tempName) "SOLID")
)
(setq HatchList (cons tempName HatchList))
)
)
)
(if Opened (close Opened))
(reverse HatchList)
)
;------------------------------------
(if
(and
(setq Sel (entsel "\nSelect just created hatch to edit it dynamicly: "))
(setq oData (entget (car Sel)))
(= (cdr (assoc 0 oData)) "HATCH")
(setq nStyle (cdr (assoc 2 oData)))
(setq BasePt (cadr Sel))
(setq HatchList (GetHatchNames (findfile "acad.pat")))
(setq Pos (vl-position nStyle HatchList))
(setq TogAngle 0)
)
(while
(and
(not
(prompt
(strcat
"\r Current style: "
nStyle
" , Allow angle change: "
(if (zerop TogAngle) "No" "Yes")
" [Style / Angle toggle]: "
)
)
)
(setq tempList (grread T 11))
(not (equal (car tempList) 3))
)
(or
Ent
(setq Ent (car Sel))
)
(setq EntData (entget Ent '("*")))
(cond
( (equal (car tempList) 5)
(setq tempPt (cadr tempList))
(redraw)
(grdraw BasePt tempPt 7)
(setq tempData
(subst
(cons
41
(distance tempPt BasePt)
;(/ (distance tempPt BasePt) (/ (getvar 'ViewSize) 5.))
)
(assoc 41 EntData)
EntData
)
)
(if (equal TogAngle 1)
(setq tempData
(subst
(cons 52 (angle BasePt tempPt))
(assoc 52 EntData)
tempData
)
)
)
(if (entmake tempData)
(progn
(entdel Ent)
(setq Ent (entlast))
)
)
)
((equal (car tempList) 2)
(cond
( (member (cadr tempList) '(83 115))
(setq nStyle (nth (setq Pos (1+ Pos)) HatchList))
(if (entmake
(subst
(cons 2 nStyle)
(assoc 2 EntData)
EntData
)
)
(progn
(entdel Ent)
(setq Ent (entlast))
)
)
)
( (member (cadr tempList) '(65 97))
(setq TogAngle (abs (1- TogAngle)))
)
)
)
)
)
)
(redraw)
(princ)
)

(defun c:phx ( / hpn )
(setq hpn (getvar 'hpname))
(setvar 'hpname "ANSI37")
(setvar "osmode" 167)
(setq sc (getdist "\nSet Initial Hatch Scale: "))
(command "_.pline")
(while (< 0 (getvar 'cmdactive)) (command "\\"))
(command "_.-BHATCH" "P" "" sc "" "_S" (ssadd (entlast)))
(while (< 0 (getvar 'cmdactive)) (command ""))
(setvar 'hpname hpn)
(princ)
(command "_.change" "L" "" "P" "C" "Bylayer" "")
)

(defun c:ph ( /)
(c:phx)
(c:dhe)
)
(c:ph)

Filter Objects (Arcs Lines and Polylines) by Length Range


;;; Filter Objects (Arcs Lines and Polylines) by Length Range
;;; Modified by Igal Averbuh 2017 (changed precision value for Length Range)
(defun C:flx ( / LayFtLst LM:UniqueFuzz SS oprec i ln e Lst ChsnItms nSS )
;| Created by Grr Credits to: Lee Mac, Tharwat, Roy |;

(setq LayFtLst
'( (-4 . "<OR")
(0 . "ARC") (0 . "LINE") (0 . "SPLINE")
(-4 . "<AND")
(0 . "*POLYLINE") (-4 . ""); (70 .81) Excludes closed polylines (70 . 1), AcDbPolygonMesh (70 . 16) and AcDbPolyFaceMesh (70 . 64).
(-4 . "AND>")
(-4 . "OR>")
)
); setq

;; Unique with Fuzz - Lee Mac
;; Returns a list with all elements considered duplicate to
;; a given tolerance removed.

(defun LM:UniqueFuzz ( l f / x r )
(while l
(setq x (car l)
l (vl-remove-if (function (lambda ( y ) (equal x y f))) (cdr l))
r (cons x r)
)
)
(reverse r)
)

(if (not (setq SS (ssget ":L-I" LayFtLst))) ;<- shotouts to 'dbroad' (This is undocumented).
(progn (prompt "\nSelect open curves to filter by their length: ")
(setq SS (ssget "_:L" LayFtLst))
)
(sssetfirst nil nil)
)

(if SS
(progn
(setq oprec (getvar 'luprec)) (setvar 'luprec 8)
(sssetfirst nil nil)
(repeat (setq i (sslength SS)) (setq e (ssname SS (setq i (1- i))))
(setq ln (vlax-curve-getDistAtPoint e (vlax-curve-getEndPoint e)))
; (if (/= 0. ln ) ; this means that the curve is closed (now useless when I added "LayFtLst")
(setq Lst (cons (list e ln) Lst))
; )
)
(if Lst
(progn
(setq Lst (vl-sort Lst (function (lambda (a b) (< (cadr a) (cadr b))))))
(setq Lst ; convert to strings
(mapcar '(lambda (a b) (list a (rtos b (getvar 'lunits) (getvar 'luprec))))
(mapcar 'car Lst) (mapcar 'cadr Lst))
)
(if (setq ChsnItms (LM:FiltListBox "Choose lengths to filter" (LM:UniqueFuzz (mapcar 'cadr Lst) (getvar 'luprec)) T)) ; remove dupes
(progn
(setq nSS (ssadd))
(mapcar '(lambda (x) (ssadd x nSS))
(mapcar 'car (vl-remove-if-not '(lambda (x) (member (cadr x) ChsnItms)) Lst))
)
(sssetfirst nil nSS)
(vla-Regen (vla-get-ActiveDocument (vlax-get-acad-object)) acActiveViewport)
)
)
)
)
(setvar 'luprec oprec)
)
); if SS

(princ)
);| defun |; (vl-load-com) (princ)

;;------------------=={ Filtered List Box }==-----------------;;
;; ;;
;; Displays a list box interface from which the user may ;;
;; select one or more items. Includes an edit box filter ;;
;; to enable the user to filter the displayed list of items. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2013 - http://www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; msg - List box dialog title ;;
;; lst - List of strings to display in the list box ;;
;; mtp - Boolean flag to determine whether the user may ;;
;; select multiple items (T=Allow Multiple) ;;
;;------------------------------------------------------------;;
;; Returns: List of selected items, else nil. ;;
;;------------------------------------------------------------;;

(defun LM:FiltListBox ( msg lst mtp / _addlist dch dcl des rtn tmp )

(defun _addlist ( key lst )
(start_list key)
(foreach x lst (add_list x))
(end_list)
lst
)

(if
(and
(setq dcl (vl-filename-mktemp nil nil ".dcl"))
(setq des (open dcl "w"))
(write-line
(strcat
"filtlistbox : dialog { label = \"" msg "\"; spacer;"
": list_box { key = \"lst\"; width = 50; fixed_width = true; height = 15; fixed_height = true; allow_accept = true; "
"multiple_select = " (if mtp "true" "false") "; }"
": edit_box { key = \"flt\"; width = 50; fixed_width = true; label = \"Filter:\"; }"
"spacer; ok_cancel; }"
)
des
)
(not (close des))
(< 0 (setq dch (load_dialog dcl)))
(new_dialog "filtlistbox" dch)
)
(progn
(_addlist "lst" (setq tmp lst))
(set_tile "lst" (setq rtn "0"))
(set_tile "flt" "*")
(action_tile "lst" "(setq rtn $value)")
(action_tile "flt"
(vl-prin1-to-string
'(progn
(setq flt (strcat "*" (strcase $value) "*"))
(_addlist "lst" (setq tmp (vl-remove-if-not '(lambda ( x ) (wcmatch (strcase x) flt)) lst)))
(set_tile "lst" (if (< (atoi rtn) (length tmp)) rtn (setq rtn "0")))
)
)
)
(setq rtn
(if (= 1 (start_dialog))
(mapcar '(lambda ( x ) (nth x tmp)) (read (strcat "(" rtn ")")))
)
)
)
)
(if (< 0 dch)
(setq dch (unload_dialog dch))
)
(if (and (= 'str (type dcl)) (findfile dcl))
(vl-file-delete dcl)
)
rtn
)
(c:flx)

Draw Steel Pipe with Elbows and Tee – PP V3.0


;-----------------------------------------------------------------------------;
; Fichier: Pipe.lsp ;
; Objet : Permet de dessiner un tuyaux de diametre X avec un # de schedule Y ;
; 'utilisateur doit fournir un point de depart et un point d'arrivee ;
;-----------------------------------------------------------------------------;

(setq pipeversion "V3.0")

(pragma '((unprotect-assign 2pi pi/2 3pi/2 inf dtr rtd tan)))
(setq 2pi (+ pi pi)
pi/2 (/ pi 2)
3pi/2 (/ (+ pi pi pi) 2)
inf 1.7e308
)

; Degree to Radian Conversion & Radian to Degree ;

(defun dtr (a) (* pi (/ a 180.0)))
(defun rtd (a) (* 180.0 (/ a pi)))
(defun tan (a / cosa)
(cond ((zerop (rem a pi)) 0.0)
((zerop (rem a pi/2)) inf)
((zerop (setq cosa (cos a))) inf)
(t (/ (sin a) cosa))))

(pragma '((protect-assign 2pi pi/2 3pi/2 inf dtr rtd tan)))

; ;
; Layers Settings ;
; ;

(setq center (list "Pipe CENTER LINE" 3 "CENTER")
outside (list "Pipe EXTERIOR" 7 "CONTINUOUS")
inside (list "Pipe WALL" 6 "HIDDEN")
)

(setq pipe
(list
(list "1/2" (list "OD" 0.840)(list "5S" 0.065 )(list "5" 0.065)
(list "10S" 0.83)(list "10" 0.083)(list "STD" 0.109)
(list "40" 0.109)(list "XS" 0.147)(list "80" 0.147)
(list "160" 0.187)(list "XXS" 0.294)(list "A" 1.5)
(list "B" 0.625)(list "E" 1.0))
(list "3/4" (list "OD" 1.050)(list "5S"0.065)(list "5" 0.065)
(list "10S" 0.83)(list "10" 0.083)(list "STD" 0.113)
(list "40" 0.113)(list "XS" 0.154)(list "80" 0.154)
(list "160" 0.218)(list "XXS" 0.308)(list "A" 1.125)
(list "B" 0.4375)(list "E" 1.5) (list "C" 1.125))
(list "1" (list "OD" 1.315)(list "5S" 0.065)(list "5" 0.065)
(list "10S" 0.109)(list "10" 0.109)(list "STD" 0.133)
(list "40" 0.133)(list "XS" 0.179)(list "80" 0.179)
(list "160" 0.250)(list "XXS" 0.358)(list "A" 1.5)
(list "B" 0.875)(list "D" 1.0)(list "E" 1.5)
(list "C" 1.5))
(list "1 1/4" (list "OD" 1.66)(list "5S" 0.065)(list "5" 0.065)
(list "10S" 0.109)(list "10" 0.109)(list "STD" 0.140)
(list "40" 0.140)(list "XS" 0.191)(list "80" 0.191)
(list "160" 0.250)(list "XXS" 0.382)(list "A" 1.875)
(list "B" 1.0)(list "D" 1.25)(list "E" 1.5)
(list "C" 1.875))
(list "1 1/2" (list "OD" 1.90)(list "5S" 0.065)(list "5" 0.065)
(list "10S" 0.109)(list "10" 0.109)(list "STD" 0.145)
(list "40" 0.145)(list "XS" 0.20)(list "80" 0.20)
(list "160" 0.281)(list "XXS" 0.4)(list "A" 2.25)
(list "B" 1.125)(list "D" 1.5)(list "E" 1.5)
(list "C" 2.25))
(list "2" (list "OD" 2.375)(list "5S" 0.065)(list "5" 0.065)
(list "10S" 0.109)(list "10" 0.109)(list "STD" 0.154)
(list "40" 0.154)(list "XS" 0.218)(list "80" 0.218)
(list "160" 0.343)(list "XXS" 0.436)(list "A" 3.0)
(list "B" 1.375)(list "D" 2.0)(list "E" 1.5)
(list "C" 2.5))
(list "2 1/2" (list "OD" 2.875)(list "5S" 0.083)(list "5" 0.083)
(list "10S" 0.120)(list "10" 0.120)(list "STD" 0.203)
(list "40" 0.203)(list "XS" 0.276)(list "80" 0.276)
(list "160" 0.375)(list "XXS" 0.375)(list "A" 3.75)
(list "B" 1.75)(list "D" 2.5)(list "E" 1.5)
(list "C" 3))
(list "3" (list "OD" 3.500)(list "5S" 0.083)(list "5" 0.083)
(list "10S" 0.120)(list "10" 0.120)(list "STD" 0.216)
(list "40" 0.216)(list "XS" 0.3)(list "80" 0.3)
(list "160" 0.437)(list "XXS" 0.6)(list "A" 4.5)
(list "B" 2.0)(list "D" 3.0)(list "E" 2.0)
(list "C" 3.375))
(list "3 1/2" (list "OD" 4.0)(list "5S" 0.083)(list "5" 0.083)
(list "10S" 0.120)(list "10" 0.120)(list "STD" 0.226)
(list "40" 0.226)(list "XS" 0.318)(list "80" 0.318)
(list "XXS" 0.636)(list "A" 5.25)(list "B" 2.25)
(list "D" 3.5)(list "E" 2.5)(list "C" 3.75))
(list "4" (list "OD" 4.5)(list "5S" 0.083)(list "5" 0.083)
(list "10S" 0.120)(list "10" 0.120)(list "STD" 0.237)
(list "40" 0.237)(list "60" 0.281)(list "XS" 0.337)
(list "80" 0.337)(list "120" 0.437)(list "160" 0.531)
(list "XXS" 0.674)(list "A" 6.0)(list "B" 2.5)
(list "D" 4.0)(list "E" 2.5)(list "C" 4.125))
(list "4 1/2" (list "OD" 5.0)(list "STD" 0.247)(list "XS" 0.355)
(list "XXS" 0.710))
(list "5" (list "OD" 5.563)(list "5S" 0.109)(list "5" 0.109)
(list "10S" 0.134)(list "10" 0.134)(list "STD" 0.258)
(list "40" 0.258)(list "XS" 0.375)(list "80" 0.375)
(list "120" 0.5)(list "160" 0.625)(list "XXS" 0.750)
(list "A" 7.5)(list "B" 3.125)(list "D" 5.0)
(list "E" 3.0)(LIST "C" 4.875))
(list "6" (list "OD" 6.625)(list "5S" 0.109)(list "5" 0.109)
(list "10S" 0.134)(list "10" 0.134)(list "STD" 0.280)
(list "40" 0.280)(list "XS" 0.432)(list "80" 0.432)
(list "120" 0.562)(list "160" 0.718)(list "XXS" 0.864)
(list "A" 9.0)(list "B" 3.75)(list "D" 6.0)
(list "E" 3.5)(list "C" 5.625))
(list "7" (list "OD" 7.625)(list "STD" 0.301)(list "XS" 0.5)
(list "XXS" 0.875))
(list "8" (list "OD" 8.625)(list "5S" 0.109)(list "5" 0.109)
(list "10S" 0.148)(list "10" 0.148)(list "20" 0.250)
(list "30" 0.277)(list "STD" 0.322)(list "40" 0.322)
(list "60" 0.406)(list "XS" 0.5)(list "80" 0.5)
(list "100" 0.593)(list "120" 0.718)(list "140" 0.812)
(list "160" 0.906)(list "XXS" 0.875)(list "A" 12.0)
(list "B" 5.0)(list "D" 8.0)(list "E" 4.0)(list "C" 7.0))
(list "9" (list "OD" 9.625)(list "STD" 0.342)(list "XS" 0.5)(list "A" nil))
(list "10" (list "OD" 10.75)(list "5S" 0.134)(list "5" 0.134)
(list "10S" 0.165)(list "10" 0.165)(list "20" 0.250)
(list "30" 0.307)(list "STD" 0.365)(list "40" 0.365)
(list "60" 0.5)(list "XS" 0.5)(list "80" 0.593)
(list "100" 0.718)(list "120" 0.843)(list "140" 1.0)
(list "160" 1.125)(list "A" 15.0)(list "B" 6.25)
(list "D" 10.0)(list "E" 5.0)(list "C" 8.5))
(list "11" (list "OD" 11.75)(list "STD" 0.375)(list "XS" 0.5)(list "A" nil))
(list "12" (list "OD" 12.75)(list "5S" 0.156)(list "5" 0.165)
(list "10S" 0.180)(list "10" 0.180)(list "20" 0.250)
(list "30" 0.330)(list "STD" 0.375)(list "40" 0.406)
(list "60" 0.562)(list "XS" 0.5)(list "80" 0.687)
(list "100" 0.843)(list "120" 1.0)(list "140" 1.125)
(list "160" 1.312)(list "A" 18.0)(list "B" 7.5)
(list "D" 12.0)(list "E" 6.0)(list "C" 10.0))
(list "14" (list "OD" 14.0)(list "5S" 0.156)(list "10S" 0.188)
(list "10" 0.250)(list "20" 0.312)(list "30" 0.375)
(list "STD" 0.375)(list "40" 0.437)(list "60" 0.593)
(list "XS" 0.500)(list "80" 0.750)(list "100" 0.937)
(list "120" 1.093)(list "140" 1.25)(list "160" 1.406)
(list "A" 21.0)(list "B" 8.75)(list "D" 14.0)
(list "E" 6.5)(list "C" 11.0))
(list "16" (list "OD" 16.0)(list "5S" 0.165)(list "10S" 0.188)
(list "10" 0.250)(list "20" 0.312)(list "30" 0.375)
(list "STD" 0.375)(list "40" 0.50)(list "60" 0.656)
(list "XS" 0.5)(list "80" 0.843)(list "100" 1.031)
(list "120" 1.218)(list "140" 1.437)(list "160" 1.593)
(list "A" 24.0)(list "B" 10.0)(list "D" 16.0)
(list "E" 7.0)(list "C" 12.0))
(list "18" (list "OD" 18.0)(list "5S" 0.165)(list "10S" 0.188)
(list "10" 0.250)(list "20" 0.312)(list "30" 0.437)
(list "STD" 0.375)(list "40" 0.562)(list "60" 0.75)
(list "XS" 0.5)(list "80" 0.937)(list "100" 1.156)
(list "120" 1.375)(list "140" 1.562)(list "160" 1.781)
(list "A" 27.0)(list "B" 11.25)(list "D" 18.0)
(list "E" 8.0)(list "C" 13.5))
(list "20" (list "OD" 20.0)(list "5S" 0.188)(list "10S" 0.218)
(list "10" 0.250)(list "20" 0.375)(list "30" 0.5)
(list "STD" 0.375)(list "40" 0.593)(list "60" 0.812)
(list "XS" 0.5)(list "80" 1.031)(list "100" 1.28)
(list "120" 1.5)(list "140" 1.75)(list "160" 1.968)
(list "A" 30.0)(list "B" 12.5)(list "D" 20.0)
(list "E" 9.0)(list "C" 15.0))
(list "24" (list "OD" 24.0)(list "5S" 0.218)(list "10S" 0.250)
(list "10" 0.250)(list "20" 0.375)(list "30" 0.562)
(list "STD" 0.375)(list "40" 0.687)(list "60" 0.968)
(list "XS" 0.5)(list "80" 1.218)(list "100" 1.531)
(list "120" 1.812)(list "140" 2.062)(list "160" 2.343)
(list "A" 36.0)(list "B" 15.0)(list "D" 24.0)
(list "E" 10.5)(list "C" 17.0))
)
)

(setq avatar
'( 8 253 253 253 253 9 252 253 253 252 252 252 254 253 253 253 253 253 253 252 253 252 252 253 252 253 9 253 254 253 253 252
8 253 8 252 253 9 253 9 253 253 253 253 9 253 9 253 253 253 253 253 253 253 253 253 253 9 253 253 253 252 9 253
253 9 253 9 9 253 252 253 253 253 253 253 253 253 9 253 253 9 253 9 252 9 253 9 253 253 9 253 9 253 253 9
252 253 9 9 253 9 253 253 252 253 253 253 17 16 14 16 16 16 18 16 39 9 253 9 253 253 253 8 9 9 9 254
9 253 9 253 252 253 253 253 253 9 9 254 17 12 14 14 14 14 14 14 17 9 252 253 252 253 253 252 9 253 253 253
9 253 9 253 253 9 253 253 252 253 253 253 17 12 14 14 14 14 12 12 17 9 253 9 253 253 9 252 253 252 253 9
253 253 253 252 8 253 253 253 253 9 253 9 39 14 12 14 14 12 14 14 27 9 253 253 252 253 253 252 9 253 9 9
9 253 252 252 252 253 253 253 253 253 253 9 17 12 12 14 12 12 12 12 17 9 253 9 253 253 253 253 253 253 9 254
253 253 253 9 9 254 254 9 253 253 253 9 17 12 14 14 14 12 12 14 17 9 252 253 9 253 253 9 253 253 253 253
253 253 253 253 253 253 253 252 253 253 253 253 39 14 12 12 12 12 12 14 17 253 252 253 253 253 9 9 253 253 253 253
252 252 251 251 8 252 251 251 8 8 252 8 29 16 16 16 16 16 18 16 29 9 9 253 253 253 253 9 253 253 253 252
9 8 54 52 52 52 54 54 54 54 54 54 59 251 8 251 251 8 8 8 96 97 253 253 253 253 253 253 253 253 252 253
252 251 54 54 54 54 52 52 52 54 52 54 59 251 251 251 251 251 251 96 94 94 88 8 252 253 253 253 9 252 253 253
8 8 54 54 54 54 54 54 54 54 52 56 59 251 251 8 251 251 99 96 94 94 94 94 75 253 9 253 253 252 253 254
252 8 54 52 52 52 52 52 52 54 54 46 59 8 8 8 8 109 94 94 92 94 94 92 94 97 252 9 9 252 253 9
252 252 54 54 54 54 52 54 54 54 52 54 67 8 8 251 251 94 94 94 92 94 92 92 94 94 96 252 253 252 253 9
253 8 54 52 54 54 52 52 54 52 52 54 67 8 8 251 96 94 94 92 92 94 92 92 94 94 94 96 87 252 253 253
254 252 52 52 52 54 52 54 54 62 52 52 67 8 251 86 92 94 94 94 94 96 96 92 94 94 94 92 94 86 253 253
253 251 54 54 52 54 52 54 54 54 54 54 59 251 99 94 92 94 92 94 92 92 92 94 96 94 94 92 92 92 96 252
9 8 54 52 54 54 52 54 52 54 42 52 66 251 94 94 94 94 92 94 94 92 94 92 92 92 94 92 94 94 97 9
253 251 54 52 52 54 52 54 52 54 54 52 58 96 94 94 94 94 92 94 92 92 92 92 94 94 94 94 94 99 253 253
8 252 251 8 251 8 251 8 8 8 251 251 251 86 94 94 94 94 92 94 94 92 94 94 94 92 94 94 96 253 253 9
253 253 253 253 253 253 253 254 253 252 253 253 253 253 99 94 94 92 92 94 94 94 94 94 94 94 94 96 252 9 253 253
252 253 9 253 253 9 253 253 8 253 253 253 252 253 253 77 94 92 92 94 94 94 96 94 94 94 96 85 253 9 252 253
252 253 9 253 253 253 253 253 253 253 254 253 252 9 253 253 253 86 94 94 94 92 92 94 92 92 97 254 9 9 252 8
254 253 253 253 253 253 253 9 253 252 9 253 253 254 252 253 253 252 89 94 94 94 92 94 92 86 253 253 252 252 253 252
253 253 253 9 252 253 253 253 253 253 9 253 9 253 8 9 254 9 9 8 84 92 92 94 86 8 253 253 253 252 253 253
252 253 252 253 252 9 253 253 252 253 253 9 253 252 252 253 253 253 252 253 253 97 94 94 8 253 253 253 253 253 254 252
253 253 253 253 253 9 9 254 253 9 253 253 252 253 9 253 9 9 253 253 9 253 87 97 9 253 253 9 253 9 9 8
252 253 253 9 253 253 253 253 253 9 252 9 253 9 253 253 9 9 253 253 253 252 253 252 253 253 252 253 252 253 253 253
252 253 252 253 252 253 253 253 253 8 252 9 253 253 253 253 9 253 8 253 9 252 253 252 9 9 252 253 253 253 253 252
8 253 254 9 253 253 253 253 253 252 253 254 252 9 253 253 253 253 253 254 253 253 253 9 9 9 252 253 253 253 253 9)
)

;; ;
;; If the current Version of the DCL is not found in the TEMP directory, ;
;; then the file is generated. ;
;; ;
;; Previous version of the DCL are not erased, User is expected to maintain ;
;; his temp directory manually. ;
;; ;

(defun generatedcl (/ fn f)
(setq fn (strcat (getvar 'TEMPPREFIX) "Pipe" pipeversion ".dcl"))
(if (not (findfile fn)) (make_dcl fn))
(load_dialog fn)
)

(defun make_dcl (fn)
(setq f (open fn "w"))
(write-line "pipe : dialog { "f)
(write-line (strcat "label = \"Pipe " pipeversion " by R.P.\"; ")f)
(write-line " : boxed_column { "f)
(write-line " label = \"Settings\"; "f)
(write-line " : row { "f)
(write-line " : text { "f)
(write-line " label = \"Pipe Size : \"; "f)
(write-line " } "f)
(write-line " : popup_list { "f)
(write-line " horizontal_margin= none; "f)
(write-line " width = 8; "f)
(write-line " fixed_width = true; "f)
(write-line " key = \"siz\"; "f)
(write-line " } "f)
(write-line " } "f)
(write-line " : row { "f)
(write-line " : text { "f)
(write-line " label = \"Pipe Schedule : \"; "f)
(write-line " } "f)
(write-line " : popup_list { "f)
(write-line " horizontal_margin = none; "f)
(write-line " width = 8; "f)
(write-line " fixed_width = true; "f)
(write-line " key = \"sch\"; "f)
(write-line " } "f)
(write-line " } "f)
(write-line " } "f)
(write-line " : boxed_column { "f)
(write-line " label = \"Commands\"; "f)
(write-line " : button { "f)
(write-line " label = \"Elbow &90 Long\"; "f)
(write-line " key = \"elbow90l\"; "f)
(write-line " alignment = centered; "f)
(write-line " width =22; "f)
(write-line " fixed_width = true; "f)
(write-line " } "f)
(write-line " : button { "f)
(write-line " label = \"Elbow 9&0 Short\"; "f)
(write-line " key = \"elbow90s\"; "f)
(write-line " alignment = centered; "f)
(write-line " width = 22; "f)
(write-line " fixed_width = true; "f)
(write-line " } "f)
(write-line " : button { "f)
(write-line " label = \"Elbow &180 Long\"; "f)
(write-line " key = \"elbow180l\"; "f)
(write-line " alignment = centered; "f)
(write-line " width = 22; "f)
(write-line " fixed_width = true; "f)
(write-line " } "f)
(write-line " : button { "f)
(write-line " label = \"Elbow 1&80 Short\"; "f)
(write-line " key = \"elbow180s\"; "f)
(write-line " alignment = centered; "f)
(write-line " width = 22; "f)
(write-line " fixed_width = true; "f)
(write-line " } "f)
(write-line " : button { "f)
(write-line " label = \"&Tee\"; "f)
(write-line " key = \"tee\"; "f)
(write-line " alignment = centered; "f)
(write-line " width = 22; "f)
(write-line " fixed_width = true; "f)
(write-line " } "f)
(write-line " : button { "f)
(write-line " label = \" Straight &Pipe \"; "f)
(write-line " key = \"pipe\"; "f)
(write-line " alignment = centered; "f)
(write-line " width = 22; "f)
(write-line " fixed_width = true; "f)
(write-line " } "f)
(write-line " } "f)
(write-line " : row { "f)
(write-line " : column { "f)
(write-line " spacer; "f)
(write-line " : button { "f)
(write-line " label = \"Cancel\"; "f)
(write-line " key = \"cancel\"; "f)
(write-line " alignment = right; "f)
(write-line " width = 12; "f)
(write-line " fixed_width = true; "f)
(write-line " is_default = true; "f)
(write-line " } "f)
(write-line " } "f)
(write-line " : column { "f)
(write-line " : image_button { "f)
(write-line " key = \"avatar\"; "f)
(write-line " aspect_ratio = 1; "f)
(write-line " width = 5.3; "f)
(write-line " fixed_width = true; "f)
(write-line " fixed_height = true; "f)
(write-line " alignment = right; "f)
(write-line " color = -15; "f)
(write-line " } "f)
(write-line " } "f)
(write-line " } "f)
(write-line "} "f)
(close f)
)

;; ;
;; onleft_p by ymg ;
;; ;
;; Returns t if point is strictly on left of vector. ;
;; ;
;; Arguments: p, Point ;
;; v1, First point of vector. ;
;; v2, Second point of vector v1->v2 ;
;; ;
;; ;

(defun onleft_p (p v1 v2 / xp yp)
(setq xp (car p) yp (cadr p))

(minusp
(- (* (- (cadr v1) yp) (- (car v2) xp)) (* (- (car v1) xp) (- (cadr v2) yp)))
)
)

;; ;
;; signum from std-lib ;
;; ;
;; Returns -1, 0 or 1 if the argument is negative zero or positive ;
;; ;

(defun signum (x) (cond ((minusp x) -1) ((zerop x) 0) (t 1)))

;; ;
;; midpoint ;
;; ;
;; Returns The Midpoint Between Point a and Point b ;
;; ;

(defun midpoint (a b) (mapcar (function (lambda (a b) (* (+ a b) 0.5))) a b))

;; ;
;; trunc by Gille Chanteau ;
;; Retourne la liste tronquיe א partir de la premiטre occurrence ;
;; de l'expression (liste complיmentaire de celle retournיe par MEMBER) ;
;; ;
;; Arguments ;
;; expr : l'expression recherchיe ;
;; lst : la liste ;
;; ;

(defun trunc (expr lst)
(if (and lst (not (equal (car lst) expr)))
(cons (car lst) (trunc expr (cdr lst)))
)
)

;; ;
;; mk_lin by ymg ;
;; ;
;; Given p1 and p2 (2 points) creates a line on current layer ;
;; Returns the entity name of the line ;
;; ;

(defun mk_lin (p1 p2)
(entmakex (list '(0 . "LINE") (cons 10 p1) (cons 11 p2)))
)

;; ;
;; mk_lwp by Alan J Thompson (Modified by ymg for closed poly) ;
;; ;
;; Argument: pl, A list of points (2d or 3d) ;
;; Create an LWPolyline at Elevation 0, on Current Layer. ;
;; Return: Entity Name ;
;; ;

(defun mk_lwp (pl / isclosed)
(setq isclosed 0)
(if (equal (car pl) (last pl) 0.001)
(setq isclosed 1 pl (cdr pl))
)

(entmakex
(append (list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 (length pl))
(cons 70 isclosed)
)
(mapcar '(lambda (p) (cons 10 (trans (list (car p) (cadr p)) 1 0))) pl)
)
)
)

;; ;
;; mk_arc by ymg ;
;; ;
;; Argument: c, Center Point of Arc ;
;; r, Radius of Arc ;
;; a1, Orientation at Start ;
;; a2, Orientation at End ;
;; ;
;; Return: Entity Name ;
;; ;

(defun mk_arc (c r a1 a2)
(entmakex
(list (cons 0 "ARC")
(cons 10 c)
(cons 40 r)
(cons 50 a1)
(cons 51 a2)
)
)
)

;; ;
;; mk_layer by CAB at TheSwamp.org ;
;; Optionnal Arguments by ymg. ;
;; Routine to ENTAKE a Layer entity. ;
;; ;
;; If the layer already exist, it will be: thawed ;
;; set on ;
;; unlocked ;
;; set as the current layer. ;
;; ;

(defun mk_layer (argl / ent lay Color ltype)
(setq lay (car argl) color (cadr argl) ltype (caddr argl))
(if (tblsearch "LAYER" lay)
(progn
(if color (setq ent (entget (tblobjname "LAYER" lay))
ent (subst (cons 62 color) (assoc 62 ent) ent)
ent (entmod ent)
)
)
(if ltype (setq ent (entget (tblobjname "LAYER" lay))
ent (subst (cons 6 ltype) (assoc 6 ent) ent)
ent (entmod ent)
)
)
(vl-cmdf "._Layer" "_Thaw" lay "_On" lay "_UnLock" lay "_Set" lay "" )
)
(entmakex
(list (cons 0 "LAYER")
(cons 100 "AcDbSymbolTableRecord")
(cons 100 "AcDbLayerTableRecord")
(cons 2 lay)
(cons 70 0)
(cons 62 (if (or (null color)(= Color "")) 7 Color))
(cons 6 (if (or (null ltype)(= ltype "")) "Continuous" ltype))
(cons 290 1)
(cons 370 -3)
)
)
)
(setvar 'CLAYER lay)
)

;; delvertex -Gilles Chanteau- gile@TheSwamp 2007-04-23 ;
;; Delete the selected vertex of a polyline (lw, 2d or 3d) ;
;; ;
;; 2007-10_05 widths behavior corrected ;
;; Modified into a callable subroutine by ymg ;

(defun delvertex (pt en / obj os pt en typ plst par blst n wlst)

;; SPLIT-LIST Split a list into sub-lists (gile) ;
;; Arguments ;
;; - lst : the list to be splited ;
;; - num : an integer, the number of items of sub-lists ;

(defun split-list (lst n)
(if lst
(cons (sublist lst 0 n)
(split-list (sublist lst n nil) n)
)
)
)

;; SUBLIST Return a sub-list (gile) ;
;; ;
;; Arguments ;
;; lst : a list ;
;; start : start index for the sub-list (first item = 0) ;
;; leng : sub-list length (or nil) ;
;; ;

(defun sublist (lst start leng / n r)
(if (or (not leng) (vla-object en))
(setq typ (vla-get-ObjectName obj))

(if (and (setq plst (if (= typ "AcDbPolyline")
(split-list (vlax-get obj 'Coordinates) 2)
(split-list (vlax-get obj 'Coordinates) 3)
)
)
(> (length plst) 2)
)
(progn
(setq pt (trans pt 1 0)
par (cond
((equal pt (vlax-curve-getStartPoint en) 1e-9) 0)
((equal pt (vlax-curve-getEndPoint en) 1e-9) (1- (length plst)))
(t (atoi (rtos (vlax-curve-getParamAtPoint en pt) 2)))
)
blst nil
wlst nil
n 0
)
(if (/= typ "AcDb3dPolyline")
(progn
(repeat (length plst)
(if (/= n par)
(setq blst (cons (cons (length blst) (vla-getBulge obj n)) blst))
)
(setq n (1+ n))
)
(if (/= 0 par)
(progn
(vla-getWidth obj (1- par) 'swid1 'ewid1)
(vla-getWidth obj par 'swid2 'ewid2)
(setq wlst (cons (list (1- par) swid1 ewid2) wlst))
)
)
(repeat (- (setq n (1- (fix (vlax-curve-getEndParam en)))) par)
(vla-getWidth obj n 'swid 'ewid)
(setq wlst (cons (list (setq n (1- n)) swid ewid) wlst))
)
)
)
(vlax-put obj 'Coordinates (apply 'append (vl-remove (nth par plst) plst)))
(or (= typ "AcDb3dPolyline")
(and (mapcar '(lambda (x) (vla-setBulge obj (car x) (cdr x))) blst)
(mapcar '(lambda (x) (vla-setWidth obj (car x) (cadr x) (caddr x))) wlst)
)
)
)
(if (> (length plst) 2)
(alert "\nInvalid Entity")
(alert "\nThe polyline had only two vertices.")
)
)

(entget en)
)

;; ;
;; LoadLineType by MICHAEL PUCKETT ;
;; ;

(defun LoadLineTypes ( lineTypeSpec lineTypeFileName / result )
(if (findfile lineTypeFileName)
(vl-catch-all-apply
'(lambda ( )
(vla-load
(vla-get-linetypes
(vla-get-activedocument
(vlax-get-acad-object)
)
)
lineTypeSpec
lineTypeFileName
)
(setq result t)
)
)
)
result
)

;; ;
;; tolayer by Vovka ;
;; ;
;; Given a Layer Name and a Selection Set, ;
;; Will change the layer of all entities in Set to the new one. ;
;; ;

(defun tolayer (lay ss / i ent )
(repeat (setq i (sslength ss))
(entmod
(subst
(cons 8 lay)
(assoc 8 (setq ent (entget (ssname ss (setq i (1- i))))))
ent
)
)
)
)

; ;
; mk_elbow by ymg ;
; ;
; This routine Draws All Elbows ;
;; ;
;; Parameters: ip, Insertion Point ;
;; rc, Dimension A or D from pipe data list ;
;; od, Outside Diameter of Elbow ;
;; thk, Wall Thickness ;
;; sta, Start Angle ;
;; ena, End Angle ;
;; ;
;; Returns: Selection Set of All Entities Created. ;
;; ;
;; Notes: Requires mk_arc, mk_lin and mk_layer ;
;; Variables outside, inside and center are defined in Main Program ;
;; ;

(defun mk_elbow (elbang ipdir rc od thk / ** a1 a2 ang cp dir ena i ip l1 l2
od/2 od/4 p3 p4 r1 r2 r3 r4 rda ss sta tmp)
(setq ip (car ipdir)
dir (cadr ipdir)
ang (dtr elbang)
rda (+ dir (* pi/2 (signum ang)))
sta (+ rda pi)
ena (+ sta ang)
)

(if (minusp ang)
(setq tmp sta sta ena ena tmp)
)

(setq ip (car ipdir)
ss (ssadd)
od/2 (/ od 2)
od/4 (/ od 4)
cp (polar ip rda rc)
r1 (- rc od/2) r2 (+ rc od/2)
r3 (+ r1 thk) r4 (- r2 thk)
** (mk_layer outside)
a1 (mk_arc cp r1 sta ena)
a2 (mk_arc cp r2 sta ena)
l1 (mk_lin (vlax-curve-getStartPoint a1) (vlax-curve-getStartPoint a2))
l2 (mk_lin (vlax-curve-getEndPoint a1) (vlax-curve-getEndPoint a2))
)
(setvar 'PEDITACCEPT 1)
(command "_PEDIT" "_M" a1 a2 l1 l2 "" "_J" "" "")
(ssadd (setq entr (entlast)) ss)
(mk_layer inside)
(ssadd (mk_arc cp r3 sta ena) ss)
(ssadd (mk_arc cp r4 sta ena) ss)
(mk_layer center)
(setq a1 (mk_arc cp rc sta ena)
l1 (if (not (caddr ipdir)) (mk_lin ip (polar ip dir (- od/4))))
p3 (if (minusp ang) (vlax-curve-getstartPoint a1) (vlax-curve-getEndPoint a1))
p4 (if (minusp ang) (polar p3 (- sta pi/2) od/4) (polar p3 (+ ena pi/2) od/4))
l2 (mk_lin p3 p4)
)
(if (caddr ipdir)
(command "_PEDIT" "_M" a1 l2 "" "_J" "" "")
(command "_PEDIT" "_M" a1 l1 l2 "" "_J" "" "")
)
(ssadd (entlast) ss)

(setq pdir (polar ip dir 100)
loop t
)
(while loop
(setq code (grread t 8))
(cond
((= (car code) 5) (cond
((minusp ang) (if (onleft_p (cadr code) ip pdir)
(progn
(repeat (setq i (sslength ss))
(entdel (ssname ss (setq i (1- i))))
)

(mk_elbow (- (rtd ang)) ipdir rc od thk)
)
))
(t (if (not (onleft_p (cadr code) ip pdir))
(progn
(repeat (setq i (sslength ss))
(entdel (ssname ss (setq i (1- i))))
)
(mk_elbow (- (rtd ang)) ipdir rc od thk)
)
))
))
((= (car code) 3) (setq loop nil)) ; Left Click, Exit the loop ;
((= (car code) 25) (setq loop nil)) ; Right Click, Exit the loop ;
((equal code '(2 13)) (setq loop nil)) ; Enter, Exit the loop. ;
((equal code '(2 32)) (setq loop nil)) ; Space, Exit the loop. ;
)
)
)

;; ;
;; get_ip-dir by ymg ;
;; ;
;; On picking an insertion point, the routine computes the direction of ;
;; the nearest endpoint on the Center line on a fitting or oipe length. ;
;; ;
;; Returns: A list of 3 items: (Insertion point, Direction to Endpoint ;
;; Ename of Pickked center line) ;

(defun get_ip-dir (/ ang en ep ip ll sp ss sz ur)
(setq ip (getpoint "\nPick Insertion Point: ")
od/4 (/ od 4)
ll (list (- (car ip) od/4) (- (cadr ip) od/4))
ur (list (+ (car ip) od/4) (+ (cadr ip) od/4))
ss (ssget "_C" ll ur (list (cons 8 (car center))))
)
(cond
((not ss) (setq ang 0))
(t (setq en (ssname ss 0)
pl (listpol en)
sp (vlax-curve-getstartpoint en)
ep (vlax-curve-getendpoint en)
)
(if (< (distance ip sp) (distance ip ep))
(setq ang (angle ip sp) ent (delvertex sp en))
(setq ang (angle ip ep) ent (delvertex ep en))
))
)

(list ip ang en)
)

(defun spipe (/ ang ep ipdir len od/2 os p1 p2 p3 p4 sp ss)
(vla-startundomark *acdoc*)
(setq ipdir (get_ip-dir)
sp (car ipdir)
ep (if (not (caddr ipdir))
(getpoint sp "\n Pick End point of Pipe: ")
(getpoint sp "\n Pick End point of Pipe: ")
)
od/2 (/ od 2)
os (- od/2 thk)
len (* (distance sp ep) fac)
ang (angle sp ep)
ss (ssadd)
)

;drawout of center line
(setq p1 (polar sp ang (- od/2)))
(setq p2 (polar ep ang od/2))
(mk_layer center)
(if (caddr ipdir)
(ssadd (mk_lwp (list sp ep p2)) ss)
(ssadd (mk_lwp (list p1 sp ep p2)) ss)
)
(mk_layer outside)
(setq p1 (polar sp (+ ang pi/2) od/2)
p2 (polar ep (+ ang pi/2) od/2)
p3 (polar sp (- ang pi/2) od/2)
p4 (polar ep (- ang pi/2) od/2)
)
(ssadd (mk_lwp (list p3 p1 p2 p4 p3)) ss)

(mk_layer inside)
(setq p1 (polar sp (- ang pi/2) os)
p2 (polar ep (- ang pi/2) os)
)
(ssadd (mk_lin p1 p2) ss)
(setq p1 (polar sp (+ ang pi/2) os)
p2 (polar ep (+ ang pi/2) os)
)
(ssadd (mk_lin p1 p2) ss)
(vla-endundomark *acdoc*)
)

;-----------------------------------------------------------------------------;

(defun elbow90l () (vla-startundomark *acdoc*) (mk_elbow 90 (get_ip-dir) A od thk) (vla-endundomark *acdoc*))

(defun elbow90s () (vla-startundomark *acdoc*)(mk_elbow 90 (get_ip-dir) D od thk) (vla-endundomark *acdoc*))

(defun elbow180l () (vla-startundomark *acdoc*)(mk_elbow 180 (get_ip-dir) A od thk) (vla-endundomark *acdoc*))

(defun elbow180s () (vla-startundomark *acdoc*)(mk_elbow 180 (get_ip-dir) D od thk) (vla-endundomark *acdoc*))

(defun tee () (vla-startundomark *acdoc*) (mk_tee (get_ip-dir))(vla-endundomark *acdoc*))

(defun mk_tee (ipdir / a1 a2 am code ctr ctra dd dir dm ip ipa ipb l1 l2 l3 l4 loop
od/2 od/4 p1 p10 p11 p12 p2 p3 p4 p5 p6 p7 p8 p9 pdir pm ss up)
(mk_layer outside)
(setvar 'FILLETRAD thk)

(setq ip (car ipdir)
dir (cadr ipdir)
ss (ssadd)
od/2 (/ od 2)
od/4 (/ od 4)
dd (- C od/2)
p1 (polar ip (+ dir pi/2) od/2)
p2 (polar p1 dir dd)
p3 (polar p2 (+ dir pi/2) dd)
p4 (polar p3 dir od)
p5 (polar p4 (+ dir 3pi/2) dd)
p6 (polar p5 dir dd)
p7 (polar p6 (+ dir 3pi/2) od)
p8 (polar p7 (+ dir pi) (+ dd od dd))
a1 (mk_lwp (list p1 p2 p3))
l1 (mk_lin p3 p4)
a2 (mk_lwp (list p4 p5 p6))
l2 (mk_lin p6 p7)
l3 (mk_lin p7 p8)
l4 (mk_lin p8 p1)
ipa (midpoint p3 p4)
ipb (midpoint p6 p7)
pm (midpoint ip ipb)
am (angle pm ipa)
dm (distance pm ipa)
p9 (polar ip (+ dir pi) od/4)
p10 (polar ipb (+ dir 0) od/4)
p11 (polar ipa (+ dir pi/2) od/4)
p12 (polar ipa (+ dir 3pi/2) (+ dd od od/4))
)
(command "_FILLET" "_P" a1)
(command "_FILLET" "_P" a2)
(command "_OFFSET" thk a1 ip "") (ssadd (entlast) ss)
(command "_OFFSET" thk a2 ip "") (ssadd (entlast) ss)
(command "_OFFSET" thk l3 ip "") (ssadd (entlast) ss)
(tolayer (car inside) ss)
(setvar 'PEDITACCEPT 1)
(command "_PEDIT" "_M" a1 l1 a2 l2 l3 l4 "" "_J" "" "")
(ssadd a1 ss)
(mk_layer center)
(ssadd (setq ctr (mk_lwp (list p9 ip ipb p10))) ss)
(ssadd (setq ctra (mk_lwp (list p11 ipa p12))) ss)
(setq pdir (polar ip dir 100)
loop t
up t
)
(while loop
(setq code (grread t 8))
(cond
((= (car code) 5) (if (and up (not (onleft_p (cadr code) ip pdir)))
(progn
(command "_mirror" ss "" ip pdir "_Y")
(setq up nil ipa (polar pm (+ am pi) dm))
)
)
(if (and (not up) (onleft_p (cadr code) ip pdir))
(progn
(command "_mirror" ss "" ip pdir "_Y")
(setq up t ipa (polar pm am dm))
)
))

((= (car code) 3) (if (caddr ipdir) (delvertex p9 ctr)) ; Left Click, Exit the loop ;
(setq loop nil))

((= (car code) 25) (vl-cmdf "_MOVE" ss "" ipa ip) ; Right Click, Insert Tee at Center Outlet, ;
(vl-cmdf "_ROTATE" ss "" ip (if up 90 -90)) ; and Exit the loop ;
(if (caddr ipdir) (delvertex p9 ctra))
(setq loop nil))

((equal code '(2 13)) (setq loop nil)) ; Enter, Exit the loop. ;

((equal code '(2 32)) (setq loop nil)) ; Space, Exit the loop. ;
)
)
)

(defun c:pp () (c:pipe))
(defun c:pipe (/ DDIAG)
(vl-load-com)

;;; Error Handler by ElpanovEvgenyi ;
(defun *error* (msg)
(mapcar 'eval varl)
(if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")))
(princ (strcat "\nError: " msg))
)
(princ)
)

(setq varl '("CLAYER" "OSMODE" "CMDECHO" "PEDITACCEPT" "PICKBOX" "ORTHOMODE")
varl (mapcar (function (lambda (a) (list 'setvar a (getvar a)))) varl)
)
(or *acdoc* (setq *acdoc* (vla-get-activedocument (vlax-get-acad-object))))
(setvar 'CMDECHO 0)
(LoadlineTypes "HIDDEN" "ACAD.LIN")
(LoadlineTypes "CENTER" "ACAD.LIN")
(if (= (getvar "LUNITS") 2) (setq fac 25.4) (setq fac 1.0))
(setq sizl (mapcar 'car pipe))
(setq ddiag nil)
(while (not (equal ddiag "cancel"))
(setvar 'ORTHOMODE 1)
(setvar 'OSMODE 32)

(princ "\n!!Choose Command in Dialog Box!! ")
(princ)
(setq dcl_id (generatedcl))
(if (not (new_dialog "pipe" dcl_id "3" (if dlgpos dlgpos '(-1 -1)))) (exit))
(start_list "siz" )
(mapcar 'add_list sizl)
(end_list)
(if (not sizn) (setq sizn "4" sizp (itoa (vl-position sizn sizl)) sch "40"))
(setq size (cdr (assoc sizn pipe))
sizp (itoa (vl-position sizn sizl))
schl (mapcar 'car (cdr (trunc (car (member (assoc "A" size) size)) size)))
schp (if (setq pos (vl-position sch schl)) (itoa pos) "0")
thk (* (cadr (assoc sch size)) fac)
od (* (cadr (assoc "OD" size)) fac)

A (cadr (assoc "A" size))
D (cadr (assoc "D" size))
C (cadr (assoc "C" size))
)
(if A
(progn (setq A (* A fac)) (mode_tile "elbow90l" 0) (mode_tile "elbow180l" 0))
(progn (mode_tile "elbow90l" 1) (mode_tile "elbow180l" 1))
)
(if D
(progn (setq D (* D fac)) (mode_tile "elbow90s" 0) (mode_tile "elbow180s" 0))
(progn (mode_tile "elbow90s" 1) (mode_tile "elbow180s" 1))
)
(if C (progn (setq C (* C fac))(mode_tile "tee" 0)) (mode_tile "tee" 1))

(set_tile "siz" sizp)
(start_list "sch" )
(mapcar 'add_list schl)
(end_list)
(set_tile "sch" schp)

(action_tile "siz" "(setq sizp $value
sizn (nth (atoi sizp) sizl)
size (cdr (assoc sizn pipe))
schl (mapcar 'car (cdr (trunc (car (member (assoc \"A\" size) size)) size)))
schp (if (setq pos (vl-position sch schl)) (itoa pos) \"0\")
sch (nth (atoi schp) schl)
thk (* (cadr (assoc sch size)) fac)
od (* (cadr (assoc \"OD\" size)) fac)

A (cadr (assoc \"A\" size))
D (cadr (assoc \"D\" size))
C (cadr (assoc \"C\" size))
)

(if A
(progn (setq A (* A fac)) (mode_tile \"elbow90l\" 0) (mode_tile \"elbow180l\" 0))
(progn (mode_tile \"elbow90l\" 1) (mode_tile \"elbow180l\" 1))
)
(if D
(progn (setq D (* D fac)) (mode_tile \"elbow90s\" 0) (mode_tile \"elbow180s\" 0))
(progn (mode_tile \"elbow90s\" 1) (mode_tile \"elbow180s\" 1))
)
(if C (progn (setq C (* C fac))(mode_tile \"tee\" 0)) (mode_tile \"tee\" 1))

(start_list \"sch\" )
(mapcar 'add_list schl)
(end_list)
(set_tile \"sch\" schp)"
)
(action_tile "sch" "(setq schp (get_tile \"sch\")
sch (nth (atoi schp) schl)) ")

(action_tile "elbow90l" "(setq ddiag '(elbow90l) dlgpos (done_dialog))")
(action_tile "elbow90s" "(setq ddiag '(elbow90s) dlgpos (done_dialog))")
(action_tile "elbow180l" "(setq ddiag '(elbow180l) dlgpos (done_dialog))")
(action_tile "elbow180s" "(setq ddiag '(elbow180s) dlgpos (done_dialog))")
(action_tile "tee" "(setq ddiag '(tee) dlgpos (done_dialog))")
(action_tile "pipe" "(setq ddiag '(spipe) dlgpos (done_dialog))")
(action_tile "cancel" "(setq ddiag $key dlgpos (done_dialog))")
(start_image "avatar")
(fill_image 0 0 (dimx_tile "avatar") (dimy_tile "avatar") -15)
(setq i 0)
(foreach c avatar
(setq i (1+ i) x (/ i 32) y (- i (* x 32)))
(fill_image x y 1 1 c)
)
(end_image)

(start_dialog)
(unload_dialog dcl_id)

(eval ddiag)

)
(*error* nil)
)
(princ (strcat "\nPipe.lsp " pipeversion))
(princ "\nType PIPE or PP to Start: ")

(c:pp)

;-----------------------------------------------------------------------------;
; THE END ;
;-----------------------------------------------------------------------------;

Draw Arcs between electrical devices for Electrical Plans


;;; Draw Arcs between electrical devices for Electrical Plans
;;; Created by Beekee CZ http://forums.autodesk.com/t5/user/viewprofilepage/user-id/1779365
;;; Based on Kent Cooper's routine WA
;;; http://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/connecting-blocks-with-line-or-arc-for-electrical-plans/m-p/5511255#M330024

(vl-load-com)

(defun C:WA (/ *error* _SortPtListByDist MidObjectsBoundingBox oCMDECHO oOSMODE doc pt pt1 pt2 ptm ptl ss i high)
(alert "\nSelect INSERTs or CIRCLEs and single POLYLINE conecting it")
;-------
(defun *error* (errmsg)
(if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
(princ (strcat "\nError: " errmsg)))
(setvar 'CMDECHO oCMDECHO)
(setvar 'OSMODE oOSMODE)
(vla-endundomark doc)
(princ))

;-------
(defun _SortPtListByDist (ptList)
;; Argument: Point list
;; Returns: Point list, sorted by distance from curve
;; By BlackBox
;; http://www.cadtutor.net/forum/showthread.php?61433-Help-Sort-a-list-point-by-distance
(mapcar
'(lambda (x / ptList2)
(setq ptList2 (append (cdr x) ptList2)))
(vl-sort
(mapcar
'(lambda (x / pt ptlist2)
(setq ptlist2
(append
(cons
(vlax-curve-getDistAtPoint
(ssname sspl 0)
(vlax-curve-getClosestPointTo (ssname sspl 0) x T))
x)
ptlist2)))
ptList)
'(lambda (x y)
(vla-object en) 'PtArMin 'PtArMax)
(setq Bmin (vlax-safearray->list PtArMin)
Bmax (vlax-safearray->list PtArMax))
(polar Bmin
(angle Bmin Bmax)
(/ (distance Bmin Bmax) 2))
)

;---------------------------------------------------------------------------------
;---------------------------------------------------------------------------------

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

(setq oCMDECHO (getvar 'CMDECHO))
(setq oOSMODE (getvar 'OSMODE))
(setvar 'OSMODE 0)

(if (and (setq ss (ssget '((0 . "INSERT,CIRCLE,*LINE"))))
(<= 3 (sslength ss))
(= 1 (sslength (setq sspl (ssget "_p" '((0 . "*LINE"))))))
(setq i (sslength ss))
(while (not (minusp (setq i (1- i))))
(if (wcmatch (cdr (assoc 0 (entget (ssname ss i)))) "CIRCLE,INSERT")
(setq pt (MidObjectsBoundingBox (ssname ss i))
ptl (if ptl
(append (list pt) ptl)
(list pt)))
T))
ptl
(setq ptl (_SortPtListByDist ptl)
i 0))
(repeat (1- (length ptl))
(setq pt1 (nth i ptl)
pt2 (nth (1+ i) ptl)
ptm (polar (polar pt1
(angle pt1 pt2)
(/ (distance pt1 pt2) 2))
(+ (angle pt1 pt2) (* pi 0.5)) ;for OPPOSITE BULGE set 1.5 instead of 0.5
(cond (high)
(T (setq high (* (distance pt1 pt2) 0.18)))))) ;change 0.18 for MORE BULGE
(command "_.ARC" pt1 ptm pt2
"_.TRIM" "" pt1 pt2 "")
(setq i (1+ i)))
(princ "\nWrogn selection. Need INSERTs or CIRCLEs and single POLYLINE conecting it"))

(setvar 'CMDECHO oCMDECHO)
(setvar 'OSMODE oOSMODE)
(vla-endundomark doc)
(princ)

)
(c:wa)

Draw Continuous Arcs (Connecting blocks with arcs for electrical plans)


;;; Draw Continuous Arcs (Connecting blocks with arcs for electrical plans)
;;; Created by Scot-65
;;; Saved from: http://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/connecting-blocks-with-line-or-arc-for-electrical-plans/td-p/5494374

(defun c:Ca ( / a )
(graphscr)
(setq usercw (getpoint "Continuous Arc \nSpecify start point of arc: "))
(while usercw
(setq a (getpoint usercw "\nSpecify second point of arc: "))
(if a
(progn
(command "arc" usercw a pause)
(setq usercw (getvar "lastpoint"))
);progn
(setq usercw nil)
);if
(setq a nil)
);while
);endCW
(c:ca)

Draw offseted by user defined distance Bounding Box around selection set of entities


;;; Draw offseted by user defined distance Bounding Box around selection set of entities ( based on Lee Mac Routine)
;;; Modified by Igal Averbuh 2017
;;; Saved from here: http://www.lee-mac.com/ssboundingbox.html

;; Selection Set Bounding Box - Lee Mac
;; Returns a list of the lower-left and upper-right WCS coordinates of a
;; rectangular frame bounding all objects in a supplied selection set.
;; sel - [sel] Selection set for which to return bounding box

(defun LM:ssboundingbox ( sel / idx llp ls1 ls2 obj urp )
(repeat (setq idx (sslength sel))
(setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))))
(if (and (vlax-method-applicable-p obj 'getboundingbox)
(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'llp 'urp))))
)
(setq ls1 (mapcar 'min (vlax-safearray->list llp) (cond (ls1) ((vlax-safearray->list llp))))
ls2 (mapcar 'max (vlax-safearray->list urp) (cond (ls2) ((vlax-safearray->list urp))))
)
)
)
(if (and ls1 ls2) (list ls1 ls2))
)

(defun c:bbx ( / box obj sel spc )
(if (and (setq sel (ssget))
(setq box (LM:ssboundingbox sel))
)
(progn
(setq spc
(vlax-get-property (vla-get-activedocument (vlax-get-acad-object))
(if (= 1 (getvar 'cvport))
'paperspace
'modelspace
)
)
)
(if (equal 0.0 (apply '- (mapcar 'caddr box)) 1e-6)
(progn
(setq obj
(vlax-invoke spc 'addlightweightpolyline
(apply 'append
(mapcar '(lambda ( x ) (mapcar '(lambda ( y ) ((eval y) box)) x))
'(
(caar cadar)
(caadr cadar)
(caadr cadadr)
(caar cadadr)
)
)
)
)
)
(vla-put-closed obj :vlax-true)
(vla-put-elevation obj (caddar box))
)
(apply 'vlax-invoke
(vl-list* spc 'addbox
(apply 'mapcar (cons '(lambda ( a b ) (/ (+ a b) 2.0)) box))
(apply 'mapcar (cons '- (reverse box)))
)
)
)
)
)
(princ)
)
(vl-load-com) (princ)

(defun C:OEL (/ ent)
; for Offset and Erase Last object
(setq ent (entlast))
(command
"_.offset"
(cond ((getdist)) (T ""))
ent
pause ; select side
""
); end command
(entdel ent)
)

(defun c:bx ( )

(c:bbx)
(setvar 'OFFSETDIST
(cond ((getdist (strcat "\nSpecify offset distance : ")))
((getvar 'OFFSETDIST))
)
)

(setq ent (entlast))
(command "_.offset" "_E" "_Y" (getvar 'OFFSETDIST) ent pause "")
;(entdel ent)
)
(c:bx)

Generate a contour that delimits contour lines


;;; Generate a contour that delimits contour lines
;;; Created by ronjonp
;;; Saved from: https://www.theswamp.org/index.php?topic=52076.0

(defun c:ot (/ _daisychainsort e i l ss)
(defun _daisychainsort (pt lst / tmp newlst dsort)
(defun dsort (pt lst / d1 d2)
(vl-sort lst (function (lambda (d1 d2) (< (distance pt d1) (distance pt d2)))))
)
(setq tmp (dsort pt lst))
(while (setq tmp (dsort (car tmp) (cdr tmp))) (setq newlst (cons (car tmp) newlst)))
(reverse newlst)
)
(if (setq ss (ssget '((0 . "LWPOLYLINE"))))
(progn (repeat (setq i (sslength ss))
(setq e (ssname ss (setq i (1- i))))
(setq l (cons (vlax-curve-getstartpoint e) l))
(setq l (cons (vlax-curve-getendpoint e) l))
)
(setq l (_daisychainsort (car l) l))
(entmakex (apply 'append
(list (list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(8 . "Boundary")
'(100 . "AcDbPolyline")
(cons 90 (length l))
'(70 . 1)
)
(mapcar '(lambda (x) (cons 10 x)) l)
)
)
)
)
)
(princ)
)
(c:ot)