acad.lsp

(prompt "\nLoading Maximizing AutoLISP Tools...")
(setq #dwgsc (getvar "DIMSCALE"))

;;;* ANGTOC is an angle formatting function that takes an angle
;;;* argument in radians and returns it with 6 decimal places
;;;* in a form universally acceptable to AutoCAD command input.
;;;*
(defun angtoc (ang)
(setq ang
(rtos (atof (angtos ang 0 8)) 2 6)
)
(strcat "<<" ang)
);defun

;;;* UDIST User interface distance function
;;;* BIT (0 for none) and KWD key word ("" for none) are same as for INITGET.
;;;* MSG is the prompt string, to which a default real is added as <DEF> (nil
;;;* for none), and a : is added. BPT is base point (nil for none).
;;;*
(defun udist (bit kwd msg def bpt / inp)
(if def ;Test for a default
(setq msg (strcat "\n" msg "<" (rtos def) ">: ") ;String'em with default
bit (- bit (boole 1 bit 1)) ;A default and no-null bit code
);setq ;conflict, so reduce BIT by 1
;if 1 bit is set, to allow null
(if (= " " (substr msg (strlen msg) 1)) ;No def, if last char is space
(setq msg (strcat "\n" (substr msg 1 (1- (strlen msg))) ": ")) ;Then strip
;space
(setq msg (strcat "\n" msg ": ")) ;Else msg is OK
) );if,if
(initget bit kwd)
(setq inp
(if bpt ;Check for a base point
(getdist msg bpt) ;and use it in the GET functions
(getdist msg)
) );setq&if
(if inp inp def) ;Compare the results, return appropriate value
);defun
;;;*

;;;* UKWORD User key word. DEF, if any, must match one of the KWD strings
;;;* BIT (1 for no null, 0 for none) and KWD key word ("" for none) are same as
;;;* for INITGET. MSG is the prompt string, to which a default string is added
;;;* as <DEF> (nil or "" for none), and a : is added.
;;;*
(defun ukword (bit kwd msg def / inp)
(if (and def (/= def "")) ;Test both nil and null string
(setq msg (strcat "\n" msg "<" def ">: ") ;String'em with default
bit (- bit (boole 1 bit 1)) ;A default and no null bit code
);setq ;conflict, so reduce BIT by 1
;if 1 bit is set, to allow null
(if (= " " (substr msg (strlen msg) 1)) ;No def, if last char is space
(setq msg (strcat "\n" (substr msg 1 (1- (strlen msg))) ": "))
;Then strip space
(setq msg (strcat "\n" msg ": ")) ;Else msg is OK
) );if,if
(initget bit kwd) ;Initialize the key words
(setq inp (getkword msg)) ;and use the GET function
(if inp inp def) ;Compare results, return appropriate value
);defun

;;;* USTR User interface string
;;;* If BIT=1 no null "" input allowed, 0 for none, BIT ignored if DEF present.
;;;* MSG is the prompt string, to which a default string is added as <DEF> (nil
;;;* or "" for none), and a : is added. If SPFLAG is non-nil, spaces are
;;;* allowed in string.
;;;*
(defun ustr (bit msg def spflag / inp nval)
(if (and def (/= def "")) ;Test both nil and null string
(setq msg (strcat "\n" msg "<" def ">: ") ;Then include default string
inp (getstring msg spflag) ;Get input, ignore no null bit
inp (if (= inp "") def inp) ;If null input, return default
);setq
(progn
(if (= " " (substr msg (strlen msg) 1)) ;No def, if last char is space
(setq msg (strcat "\n" (substr msg 1 (1- (strlen msg))) ": "))
;Then strip space
(setq msg (strcat "\n" msg ": ")) ;Else msg is OK
);if
(if (= bit 1) ;If no null bit, set to 1
(while (= "" (setq inp (getstring msg spflag))) ;Then get input, no ""
(prompt "\nInvalid string.")
)
(setq inp (getstring msg spflag)) ;Else get input, "" ok
) );progn&if
);if
inp
);defun
;;;*

;;;* UINT User interface integer function
;;;* BIT (0 for none) and KWD key word ("" for none) are same as for INITGET.
;;;* MSG is the prompt string, to which a default integer is added as <DEF>
;;;* (nil for none), and a : is added.
;;;*
(defun uint (bit kwd msg def / inp)
(if def ;Test for a default
(setq msg (strcat "\n" msg "<" (itoa def) ">: ") ;String'em with default
bit (- bit (boole 1 bit 1)) ;A default and no null bit code
;conflict, so reduce BIT by 1
);setq ;if 1 bit is set, to allow null
(if (= " " (substr msg (strlen msg) 1)) ;No def, if last char is space
(setq msg (strcat "\n" (substr msg 1 (1- (strlen msg))) ": "))
;Then strip space
(setq msg (strcat "\n" msg ": ")) ;Else msg is OK
) );if,if
(initget bit kwd)
(setq inp (getint msg)) ;Use the GETINT function
(if inp inp def) ;Compare results, return appropriate value
);defun
;;;*

;;;* UREAL User interface real function
;;;* BIT (0 for none) and KWD key word ("" for none) are same as for INITGET.
;;;* MSG is the prompt string, to which a default real is added as <DEF> (nil
;;;* for none), and a : is added.
;;;*
(defun ureal (bit kwd msg def / inp)
(if def ;Test for a default
(setq msg (strcat "\n" msg "<" (rtos def 2) ">: ") ;String'em w/ default
bit (- bit (boole 1 bit 1)) ;A default and no null bit code
);setq ;conflict, so reduce BIT by 1
;if 1 bit is set, to allow null
(if (= " " (substr msg (strlen msg) 1)) ;No def, if last char is space
(setq msg (strcat "\n" (substr msg 1 (1- (strlen msg))) ": "))
;Then strip space
(setq msg (strcat "\n" msg ": ")) ;else msg is OK
) );if,if
(initget bit kwd)
(setq inp (getreal msg)) ;Use the GETREAL function
(if inp inp def) ;Compareresults, return appropriate value
);defun
;;;*

;;;* UPOINT User interface point function
;;;* BIT (1 for no null, 0 for none) and KWD key word ("" for none) are same as
;;;* for INITGET. MSG is the prompt string, to which a default point variable
;;;* is added as <DEF> (nil for none), and a : is added. BPT is base point
;;;* (nil for none).
;;;*
(defun upoint (bit kwd msg def bpt / inp)
(if def ;Check for a default
(setq pts (strcat
(rtos (car def)) ;Formats X,Y 2D point
"," (rtos (cadr def)) ;as a string
(if ;Formats 3D ",Z"
(and (caddr def) (= 0 (getvar "FLATLAND"))) ;if supplied and
(strcat "," (rtos (caddr def))) ;FLATLAND off
""
) );if&strcat
msg (strcat "\n" msg "<" pts ">: ") ;String 'em with default
bit (- bit (boole 1 bit 1)) ;A default and no null bit code
);setq ;conflict, so reduce BIT by 1
;if 1 bit is set, to allow null
(if (= " " (substr msg (strlen msg) 1)) ;No def, if last char is space
(setq msg (strcat "\n" (substr msg 1 (1- (strlen msg))) ": "))
;Then strip space
(setq msg (strcat "\n" msg ": ")) ;Else msg is OK
) );if,if
(initget bit kwd)
(setq inp
(if bpt ;Check for base point
(getpoint msg bpt) ;and use it
(getpoint msg) ;but not if nil
) );setq&if
(if inp inp def) ;Evaluate results and return proper value
);defun
;;;*

;;;* UANGLE User interface angle function
;;;* BIT (1 for no null, 0 for none) and KWD key word ("" for none) are same as
;;;* for INITGET. MSG is the prompt string, to which a default real in rads is
;;;* added as <DEF> (nil for none), and a : is added. BPT is base point
;;;* (nil for none).
;;;*
(defun uangle (bit kwd msg def bpt / inp)
(if def
(setq msg (strcat "\n" msg "<" (angtos def) ">: ")
bit (- bit (boole 1 bit 1)) ;A default and no null bit code
);setq ;conflict, so reduce BIT by 1
;if 1 bit is set, to allow null
(if (= " " (substr msg (strlen msg) 1)) ;No def, if last char is space
(setq msg (strcat "\n" (substr msg 1 (1- (strlen msg))) ": "))
;Then strip space
(setq msg (strcat "\n" msg ": ")) ;Else msg is OK
) );if,if
(initget bit kwd)
(setq inp
(if bpt
(getangle msg bpt)
(getangle msg)
) )
(if inp inp def)
);defun
;;;*

;;;* DXF takes an integer dxf code and an entity data list.
;;;* It returns the data element of the association pair.
;;;*
(defun dxf(code elist)
(cdr (assoc code elist)) ;Finds the association pair, strips 1st element
);defun
;;;*

;;;* RESET is a command to clean up the environment when you are testing
;;;* functions and they fail, sometimes leaving the following setting at
;;;* non-default values.
;;;*
(defun C:RESET ()
(setvar "CMDECHO" 1) ;These are the book's defaults
(setvar "MENUECHO" 0)
(setvar "HIGHLIGHT" 1)
(princ)
);defun C:RESET

;;;* C:LISP? is an AutoLISP and DIESEL help file access function.
;;;* Enter LISP? at the command prompt or 'LISP? during a command.
;;;* The help file is AUTOLISP.HLP.
;;;*
(defun C:LISP? () (acad_helpdlg "AUTOLISP.HLP" ""))

(defun S::STARTUP ()
(command "_.ABOUT") ;Delete this line to not display ACAD.MSG file
(princ)
)

(princ)
;;;* end of ACAD.LSP
----------------------------------------------------------------------------------------

;
(if (not angtoc) ;Test subroutines
(prompt "\nRequires ANGTOC function. Load aborted. ")

;;;* ATEXT types text in an arc. The function gets the midpoint of the txt, the
;;;* radius point, and the orientation. This version determines if the text style
;;;* height is fixed and prompts for height if not. It uses the ANGTOC function.

(defun C:ATEXT ( / midp radp txt radi txtlen txtspc txthgt cmd arclen
arcang sang orent txtang txtp char)
(setq cmdech (getvar "CMDECHO")) ;Save command echo
(setvar "CMDECHO" 0) ;Turn command echo off
(graphscr)
(setq ;Assign variables
radp (getpoint "\nPick radius point: " ) ;Get radius point of text
midp (getpoint "\nPick middle point of text: " radp) ;Get midpoint of text
cmd
(if (= 0 (setq txthgt
(cdr (assoc 40 (tblsearch "STYLE" (getvar "TEXTSTYLE")))
) ) )
(progn ;If height not fixed...
(setq txthgt
(getdist (strcat "\nText height <" ;Get text height
(rtos (setq txt (getvar "TEXTSIZE"))) ;Default
">: "
) )
txthgt (if txthgt txthgt txt) ;Set to default if nil
);setq
'(command "TEXT" "C" txtp txthgt txtang char) ;Assign command list
);progn
'(command "TEXT" "C" txtp txtang char) ;Else fixed ht command list
);end if
txt (getstring "\nText: " T) ;Get text string
radi (distance radp midp) ;Determine radius
txtlen (strlen txt) ;Determine string length
txtspc (cdr (assoc 41 (tblsearch "STYLE" (getvar "TEXTSTYLE")))) ;Char width
);end variable assignment

(setq orent ;Get text orientation
(strcase (getstring "\nIs base of text towards radius point <Y>: ")) ;Upper
)

;; Calculate new radius length based on orientation
(if (or (= orent "") (= orent "Y"))
(setq radi (- radi (/ txthgt 2)))
(setq radi (+ radi (/ txthgt 2)))
);end if

(setq ;Calculate variables
arclen (* txtlen txtspc txthgt) ;Arc length
txtspc (/ arclen txtlen) ;Arc length of one character
arcang (/ arclen radi) ;Arc angle of one character
sang (- (+ (angle radp midp) (/ arcang 2)) ;Start angle of text
(/ txtspc radi 2)
)
count 1 ;Initialize counter
)

(repeat txtlen ;Insert character loop
(if (or (= orent "") (= orent "Y")) ;Test text angle
;; Preface angle w/ << for universal angular units in dec. string
(setq txtang (angtoc
(- sang (/ pi 2)) ;Convert start angle minus 90 deg
)
txtpos count
)
;; Calc angle for character towards radius and
;; character position in string
(setq txtang (angtos (- sang (* pi 1.5)) 0) ;angle to command function
txtpos (- (1+ txtlen) count)
)
;; Calc angle for character away from radius and
;; character position in string
)
(setq txtp (polar radp sang radi)) ;Calculate character point
(setq char (substr txt txtpos 1)) ;Get text character
(eval cmd) ;Execute command list
(setq count (1+ count)) ;Increment counter
(setq sang (- sang (/ txtspc radi))) ;Calculate new start angle
);End repeat loop
(setvar "CMDECHO" cmdech) ;Turn command echo on
(princ) ;Ends program cleanly
);End defun
;*end of ATEXT2.LSP
;*
);test subroutines
-----------------------------------------------------------------------------------------------------------------------------------

 AUTOBLK.LSP contains routines that allow the placement of a BLOCK on a
;;;* PLINE or LINE and automatically break the line out of the Block area.
;;;* The block must be built with its first entity a constant invisible
;;;* attribute tagged BREAKDIM, containing a value equal to the length
;;;* of break required. The insertion point must be in the center of the
;;;* horizontal BREAKDIM location. The DXF, NO-PATH and USTR functions,
;;;* and the global #DWGSC scale factor are required.

;;;* GETBK prompts for block name, searches & returns block name &
;;;* breakdim data. If BLNAME argument is non-nil it serves as the
;;;* prompt default. It must be supplied a valid BKDIST argument if
;;;* supplied a name as BLNAME.
(defun getbk (blname bkdist / ok tbdata bldata tmp)
(setq expert (getvar "EXPERT")) (setvar "EXPERT" 2)
(while (not ok)
;;get BLOCK name
(while (not (setq tmp (ustr 0 "Block name " blname nil))))
(if (/= tmp blname) ;If new block name given
(progn ;Then
(while
(not
(if
(and
(= tmp (no-path tmp)) ;No path supplied and
(setq tbdata (tblsearch "BLOCK" tmp)) ;search for BLOCK name
)
(setq bldata (entget (dxf -2 tbdata))) ;Get first subentity
(progn ;Else
(command "_.INSERT" tmp nil) ;Insert BLOCK in database
(setq tmp (no-path tmp)) ;Strip path if any from block name
nil ;Return NIL to cause loop
)
) ) );while not if
(setq attag (dxf 2 bldata))
(if ;If it's an attribute and has the proper format
(and (= (dxf 0 bldata) "ATTDEF") (= (dxf 2 bldata) "BREAKDIM"))
(setq bkdist (atof (dxf 1 bldata)) ;Then get breakdim data
blname tmp ;and save blname
ok T ;Exit flag
)
(prompt "\nBlock must have BREAKDIM attribute as 1st entity.")
);if an attrib...
);progn then
(setq ok T) ;Else used same block name
);if new
);while
(list blname bkdist) ;Return block name and break dist
);defun GETBK
;;;*

;;;*NO-PATH strips path from a fully qualified file or block name.
;;;*
(defun no-path (fname / lngth str char)
;;initialize, lngth is filename length
(setq lngth (1+ (strlen fname)) str "")
(while ;Loops until AND is non-NIL
(and
(/= 1 lngth) ;Exit to avoid invalid substr
;;get next char in reverse
(setq lngth (1- lngth) char (substr fname lngth 1))
(/= "/" char) ;Find "/" and exit
(/= "\\" char) ;Find "\" and exit
(setq str (strcat char str)) ;Otherwise add last char to str
) )
str
);defun NO-PATH
;;;*
------------------------------------------------------------------------------------------------------------------------------------
;;;* C:BLINE gets a block name, gets its data, draws a line and
;;;* calls LINEBLK to insert the block and break the line.
(defun C:BLINE ( / linent blkprmt spt ept)
;;#bname and #bdist global for defaults
(setq bkdata (getbk #bname #bdist) ;Get block name and break data
#bname (car bkdata)
#bdist (cadr bkdata)
)
;;get first point of line
(setq spt (getpoint "\nStart point of line: "))
(if spt
;;get 2nd point of line
(while (setq ept (getpoint "\nPick end point of line: " spt))
(command "_.LINE" spt ept "") ;Draw LINE
(setq linent (entlast)) ;Get insert point
(setq pt1 (osnap ept "MIDP,QUI")) ;Determine midpoint of LINE
(if (> (* 2 (distance spt ept)) #bdist) ;Only insert if twice length
(lineblk #bname #bdist pt1 linent) ;Perform Block insert routine
)
(setq spt ept) ;Establish a new start point
);while
);if
(setvar "LASTPOINT" spt) ;Resets properly to end of line
(princ)
);defun C:BLINE
;;;*

;;;* LINEBLK inserts the autobreaking block and breaks the line or pline
;;;* To force to 0 degrees or a range -15 to 105 deg, replace the
;;;* (command "_.INSERT"...) line with one of the following (the second
;;;* one requires the ROTANG function, to force block to read from
;;;* horizontal or right side).
;;; ;; Alt. to force angle to 0 degrees
;;; (command "_.INSERT" blname pt1 #dwgsc "" 0)
;;; ;; Restrict angle
;;; (command "_.INSERT" blname pt1 #dwgsc "" (angtos (rotang ang nil)))
;;;* Or revise programs to use a second attribute in block to control
;;;* insertion angle.
;;;
(defun lineblk (blname bkdist pt1 linent / blname brkdim
blkname blkent validatt atttag ang)
(setq pt2 (osnap pt1 "ENDP,QUI")) ;Get end point for rotation
(setq ang (angle pt1 pt2)) ;Get angle of line
(command "_.INSERT" blname pt1 #dwgsc "" pt2) ;Insert BLOCK
(setq pt1 (polar pt1 ang (* (/ bkdist 2) #dwgsc))) ;Calculate 1st break point
(setq pt2 (polar pt1 (+ ang pi) (* bkdist #dwgsc)));Calculate 2nd break point
(command "_.BREAK" linent pt1 pt2) ;Break LINE or PLINE
);defun LINEBLK
;;;*

;;;* ROTANG converts ANG argument in radians to -15 to 105 degree range,
;;;* in radians. If align FLAG is True, angles from 105 to 285 are
;;;* flipped 180 degrees. Note: this is in radians but comments are
;;;* in degrees for ease of reading.
;;;*
(defun rotang (ang flag)
;;adj to 0 to 2pi 360 range
(while (>= ang 6.28318531) (setq ang (- ang 6.28318531)))

(while (<= ang 0) (setq ang (+ ang 6.28318531)))
(cond
((and (>= ang 3.92699081) (<= ang 6.02138591)) ;225-345
(cond
((not flag) (setq ang 0)) ;To 0
((< ang 4.974188368) (setq ang (- ang pi))) ;225-285 flip 180 deg
(ang)
) )
((and (>= ang 1.83259571) (< ang 3.92699081)) ;105-225
(if flag
(setq ang (- ang pi)) ;Flip 180
(setq ang 1.570796327) ;to 90
)
)
(ang)
)
);defun ROTANG
;;;*

;;;* C:BBLOCK uses GETBK and LINEBLK to insert an autobreaking
;;;* block on existing entities.
;;;* #bname and #bdist global for defaults
(defun C:BBLOCK ( / linent bkdata)
(setq linent (entsel "\nPick BLOCK insert point: ")) ;Get entity and point
(if linent
(progn
(setq bkdata (getbk #bname #bdist) ;Get the block data
#bname (car bkdata) ;Store the block name
#bdist (cadr bkdata) ;and its break distance
)
(setq pt1 (osnap (cadr linent) "NEA")) ;Get nearest point on line
(lineblk #bname #bdist pt1 (car linent));Perform BLOCK insert & break
);progn
(prompt "\nMust select Line or Pline. ")
);if
(princ)
);defun C:BBLOCK
------------------------------------------------------------------------------------------------------------------------------------

(if (not (and upoint udist)) ;Test subroutines
(prompt "\nRequires UPOINT and UDIST functions. Load aborted. ")
(progn ;Else load OK

;;;* C:DDRAW automates drawing line segments at specific angles,
;;;* acting like a 22.5 degree ortho, or angular snap. It requires
;;;* DXF and the user get functions to be loaded, and the following STRIP.
;;;* It requires the COMPASS.DWG block.
;;;*
;;;* STRIP returns the entity data list DATA with the assoc. data group
;;;* specified by CODE stripped from the entity data list.
(defun strip (code data)
(cdr ;Remove duplicate 1st group and return rest
(subst (car data) ;Substitute (duplicate) 1st group
(assoc code data) ;for group specified by CODE
data ;in the DATA list
) )
);defun

;;;*
(defun C:DDRAW ( / prmpt anginc maxd pt1 esub more inside gd ang d1 pt2)
(setq prmpt "\nQuit, press ENTER to reset angle, or enter length."
;One-time prompt
anginc (/ pi 8) ;22.5 Angle increment
maxd (* (getvar "VIEWSIZE") 0.15) ;Symbol height & max
pt1 (upoint 1 "" "Starting point" nil nil) ;Critical distance
);setq
(command "_.insert" "compass" pt1 maxd "" 0.0 "_.line" pt1) ;Puts in compass
;& starts line
(setq esub (strip 10 (entget (entlast)))) ;Strips ent data list of
;insert point
(setvar "ORTHOMODE" 0) ;Turn off ortho mode
(setq more T)
(while more ;Loop
(setq inside T) ;Inside of compass flag
(prompt "Drag to angle: ")
;Get the dynamic rotation angle...
(while inside ;Loops until flag is nil
(setq gd (grread t)) ;Samples coordinates
(if (= (car gd) 5) ;If a real sampling (not a key press...)
(if (> (distance pt1 (cadr gd)) maxd) ;If outside calc circle distance
(setq inside nil) ;set flag to nil to kill while
)
);if=
);while-inside
; Set up for the new angle, calc the angle...
(setq ang ;Constant increment
(* (fix (+ (/ (angle pt1 (cadr gd)) anginc) (/ anginc 2.0))) anginc)
)
(setvar "SNAPANG" ang) ;Change rotation angle, specific angle list
(setvar "SNAPBASE" ;Reset base point
(list (car pt1) (cadr pt1)) ;Convert to 2D point
)
(setvar "ORTHOMODE" 1) ;Turn on ortho mode
; Get line length, draw it and move compass symbol
(if prmpt (progn (prompt prmpt) (setq prmpt nil))) ;Issue one-time prompt
(setq d1 (udist 0 "Q" "Q/ENTER/<length>" nil pt1)) ;Find out the length
(cond
((numberp d1) ;Cond1 see if it's nil
(setq pt2 (polar pt1 ang d1)) ;Calc the new point
(entmod (append esub (list (cons 10 pt2)))) ;Changes compass
(entupd (entlast)) ;Redraw last line
(command (setq pt1 pt2)) ;Pass point to line command
);cond1
((= d1 "Q") ;Cond2 finish and quit
(command "" "_.snap" "_r" "0,0" "0" ;End line, restore snap
"erase" (ssget "X" '((2 . "COMPASS"))) "" ;Erase COMPASS
)
(setq more nil inside nil) ;Set flags nil to kill whiles
);cond2
);cond
(setvar "ORTHOMODE" 0) ;Turn off ortho
);while-more
(princ)
);defun
;;;*
));test subroutines
 

----------------------------------------------------------------------------------------;
(if (not dxf) ;Test subroutines
(prompt "\nRequires functions. Load aborted. ")
(progn ;Else load OK

;;;* C:DELVTX deletes a vertex that you select from a polyline. It won't
;;;* delete the ending vertex. It uses the DXF function which must be loaded.
;;;*
(defun C:DELVTX ( / vname ent edata ename)
(while (not (and ;Get name of vertex, reprompt
;if not vertex
(setq vname (nentsel "\nSelect polyline vertex to delete: "))
(equal "VERTEX" (dxf 0 (entget (setq vname (car vname)))))
(setq ent vname) ;Save name for looping to seqend
) ) );while not and
(while (not (equal "SEQEND" ;Loop until seqend is found
(dxf 0 (setq edata (entget (setq ent (entnext ent)))))
) ) );while not equal
(setq ent (dxf -2 edata) ;Get head entity from seqend
edata (entget ent) ;Get data list for entmake
ename ent ;Save original entity name to delete
)
(entmake edata) ;Make head
(while (not (equal "SEQEND" ;Loop until seqend is found
(dxf 0 (setq edata (entget (setq ent (entnext ent)))))
) );not equal
(if (not (equal ent vname)) ;If not selected vertex
(entmake edata) ;Then make vertex
);if
);while
(entmake '((0 . "SEQEND"))) ;Make seqend
(entdel ename) ;Delete original entity
(redraw (entlast)) ;Redraw new entity
(princ)
);defun C:DELVTX

(princ)
;;;* end of DELVTX.LSP
) );test subroutines