Star Lisp is an exercise & a way to show how to use the grread & grvecs functions.
I used subroutines I already had for most but did have to create one or two.
As this is a quick assembly of the code there may be a bug or two lurking.
I used the command circle to allow the use of osnaps with the radius but may
change that part of the code to grread as well. Note that the star pick for the
final size can be inside the first radius or you may drag outside the radius.
The star is created simply by dividing 360 degrees by the number of points chosen.
Have fun.
PS This is not a Star Polygon as that form has a fixed interior shape. This one is more fun.
I may add code for the Star Polygon if anyone need it.
<edit: Replaced lisp, bug fix.>
;;;=======================[ Star.lsp ]=======================
;;; Author: Copyright© 2009 Charles Alan Butler
;;; Version: 1.1 Mar. 07, 2009
;;; Purpose: To draw a pline star
;;; Sub_Routines: -See included
;;; Description: User enters the number of points, picks the
;;; center point, picks or enters the inner/outer radius
;;;
;;;==========================================================
(defun C:STAR (/ np cp ent lastent rad usercmd
;; localized functions
*error* makePline activespace txt2num StarCalc GetUserPoint
)
(vl-load-com)
;; --+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
;; Local Functions Start Here
;; --+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
(defun *error* (msg)
(if (not
(member msg '("console break" "Function cancelled" "quit / exit abort" "" nil))
)
(princ (strcat "\nError: " msg))
) ; if
(and usercmd (setvar "CMDECHO" usercmd))
(princ)
) ; end error function
;; by CAB 10/05/2007
;; Expects pts to be a list of 2D or 3D points
;; Returns new pline object
(defun makePline (spc pts)
;; 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
)
)
)
(vla-addlightweightpolyline spc pts)
)
;;; Returns object for active space (ModelSpace or PaperSpace )
;; CAB 05/31/07
(defun activespace (doc)
(if (or (= acmodelspace (vla-get-activespace doc))
(= :vlax-true (vla-get-mspace doc)))
(vla-get-modelspace doc)
(vla-get-paperspace doc)
)
)
;; CAB
;;+++++++++++++++++++++++++++++++
;; convert the text to a number
;;+++++++++++++++++++++++++++++++
(defun txt2num (txt / num)
(or (setq num (distof txt 5))
(setq num (distof txt 2))
(setq num (distof txt 1))
(setq num (distof txt 4))
(setq num (distof txt 3))
)
num
)
;; calc points for star & return the list
(defun StarCalc (cp np orad ip / ang iang irad 1stpt plst)
(setq ang (angle cp ip)
iang (/ (* 2 pi) np)
irad (distance cp ip)
1stpt (polar cp ang orad)
)
(repeat np
(setq nxtpt (polar cp ang orad)
plst (cond (plst (cons nxtpt plst))
((list nxtpt))
)
plst (cons (polar cp (+ ang (/ iang 2)) irad) plst)
ang (+ ang iang)
)
)
(cons 1stpt plst)
)
;; grread subroutine to get user input & draw star w/ grvecs
;; point picked will draw a pline star with picked inside diameter
;; user may enter a number for the inside radius & press enter
;; in this case the angle used to get the outer radius is used for
;; the pline creation & not the angle from the grread
(defun GetUserPoint (cp np orad lp msg / key str grr ip pr plst nLst lastpt doc num)
(setq str "")
(or msg (setq msg "\n"))
(if (not (vl-string-search "\n" msg))
(setq msg (strcat "\n" msg))
)
(princ msg)
(while ; get the string from user, exit only for ENTER
(cond
((eq 2 (car (setq grr (grread t 7 0)))) ; keyboard input
(setq key (cadr grr))
(cond
((= key 8) ; backspace
(if (/= str "")
(progn
(setq str (substr str 1 (1- (strlen str))))
(prompt (strcat (chr 8) " " (chr 8)))
)
)
t ;stay in loop
)
((= key 13) ; ENTER- where done here
(if (and str (/= str "") (setq num (txt2num str)))
(progn
(setq plst (StarCalc cp np orad (polar cp (angle cp lp) num)))
(setq Doc (vla-get-activedocument (vlax-get-acad-object)))
(setq obj (makePline (activespace doc) (cdr pLst)))
(vla-put-Closed obj :vlax-true)
)
(princ "\nUser Quit.")
)
nil ; exit loop
)
((member (chr key) '("H" "h"))
;;--------------------------------------
;; H E L P message for dialog box.
;;--------------------------------------
(alert
(strcat
"Star.lsp (c) 2009 Charles Alan Butler"
"\nAbbreviated help at this time."
"\nThis LISP routine will allow you to draw a pline star."
"\nUser enters the number of points the picks the center for the"
"\nstar pline. The next radius is chossen with the mouse."
"\nPoint picked will draw a pline star with picked fixed diameter"
"\nuser may enter a number for the other radius & press enter"
"\nin this case the angle used to get the outer radius is used for"
"\nthe pline creation & not the angle from the grread"
"Please report any problems you may have. CAB at TheSwamp.org\n"
)
)
t ; stay in loop
)
;; if a valid key press add to string
((wcmatch (chr key) "[hH],[0-9],-,`#,` ,`,,`.")
(if (or (null str) (= str ""))
(setq str (chr key))
(setq str (strcat str (chr key)))
)
(princ (chr key))
)
((princ "\nInvalid Keypress.") (princ (strcat msg str)))
) ; end cond
)
((eq 3 (car grr)) ; point picked, make final star
(setq ip (cadr grr))
(setq plst (StarCalc cp np orad ip))
(setq Doc (vla-get-activedocument (vlax-get-acad-object)))
(setq obj (makePline (activespace doc) (cdr pLst)))
(vla-put-Closed obj :vlax-true)
nil ; exit
)
((eq 5 (car grr)) ; point from mouse, update star
(setq ip (cadr grr))
(if (or (null lastpt)
(> (distance ip lastpt) 0.00001)
)
(progn
(setq plst (StarCalc cp np orad ip)
nLst nil
pr nil
)
(mapcar
'(lambda (x)
(cond
(pr (setq nLst (cons x (cons pr nlst))
pr x )
)
(nLst (setq nLst (cons x nlst)
pr x )
)
((setq nLst (list x)))
)
)
plst
)
(redraw)
(grvecs (cons 256 nLst))
)
)
(setq lastpt ip)
)
;;((princ "\nKeyboard entry only."))
) ; end cond 1
) ; while
(redraw)
(princ)
)
;; --+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
;; Routine Starts here
;; --+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
(setq usercmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(while
(progn
(initget 7)
(setq np (getint "\nEnter the number of points >2 "))
(or (null np)
(and (< np 3)
(princ "\nMust enter >2."))
)
)
)
(setq lastent (entlast))
(if (and (setq cp (getpoint "\nPick the center point."))
(listp cp)
)
(progn
(command "_.circle" "_non" cp pause)
(setq ent (entlast) ; get the circle ename
lp (getvar "lastpoint") ; get the point used to pick the raidus
)
(if (not (equal ent lastent)) ; make sure the circle was created
(progn
(setq rad (cdr (assoc 40 (entget ent))))
(or (entdel ent) (princ)) ; debug CAB
(getuserpoint cp np rad lp "\nPick size and angle or enter radius. ")
)
(princ) ; debug CAB
)
)
)
(*error* "")
(princ)
) ; end defun Star
(prompt "\nStar Loaded, enter Star to run.")
(princ)