Average Lisp Function

I was wondering if any of you could help me.
I have upgraded my AutoCAD 2002 to 2004, I was given a lisp routine for a snap to return the average point from any number of given points. (I got it
of an Andrew Bichard when he wrote for Cad Desk magazine)
The thing is, it doesn't work with AutoCAD 2004 at all.
I was wondering if anyone here had either got it to work, or found something else that does the job as I used it all the time.
Andrew Bichard has not upgraded his ver yet, so has not looked at it.
Add pictures here
<% if( /^image/.test(type) ){ %>
<% } %>
<%-name%>
Add image file
Upload
Damn.
Just thought..........
Perhaps Mr. Bichard wouldn't want his name plastered over Usenet.
Damn.
Apologies
Add pictures here
<% if( /^image/.test(type) ){ %>
<% } %>
<%-name%>
Add image file
Upload
Try this:
(defun c:avpoint (/ p0 plist x xsum ysum zsum) (while (setq p0 (getpoint "\nPoint: ")) (setq plist (cons p0 plist)) ) (setq xsum 0 ysum 0 zsum 0 np (length plist) ) (foreach x plist (progn (setq xsum (+ xsum (car x))) (setq ysum (+ ysum (cadr x))) (setq zsum (+ zsum (caddr x))) ) ) (setq avp (list (/ xsum np) (/ ysum np) (/ zsum np))) )
HTH Juergen
Steve Yoxon schrieb:

Add pictures here
<% if( /^image/.test(type) ){ %>
<% } %>
<%-name%>
Add image file
Upload
(changed by me to stop spam)
Copyright Andrew Bichard 1996 ............... I hope this explains my problem better, I can't get this to work in AutoCAD 2004, (it was fine in R14 & A2K.
Add pictures here
<% if( /^image/.test(type) ){ %>
<% } %>
<%-name%>
Add image file
Upload
Are you able to post "Subrout1.lsp" to go with that? It'd be great if you could, thanks.

Add pictures here
<% if( /^image/.test(type) ){ %>
<% } %>
<%-name%>
Add image file
Upload
message Are you able to post "Subrout1.lsp" to go with that? It'd be great if you could, thanks.

Subrout1.lsp
(PRINC ".")
;|========================================================== (MODES (A1)) MODE Store Stores modes for use by (MODER (A1) with variable name MODE-V as in (MODES '("BLIPMODE" "HIGHLIGHT")) used in (preset) add MODE-V to local variables DO NOT USE FOR READ ONLY VARIABLES OR MODER WILL CRASH ==============================================================|;
(DEFUN modes (a1) (IF (NOT mode-v) (SETQ mode-v '()) ) (REPEAT (LENGTH a1) (SETQ mode-v (APPEND mode-v (LIST (LIST (CAR a1) (GETVAR (CAR a1))))) a1 (CDR a1) ) ) )
(PRINC ".")
;|=========================================================== (MODER) MODE Restore Used in (reset) to reset variables set by (MODES (A1)) ==============================================================|;
(DEFUN moder () (REPEAT (LENGTH mode-v) (IF (CADAR mode-v) (SETVAR (CAAR mode-v) (CADAR mode-v)) ) ;_ if (SETQ mode-v (CDR mode-v)) ) ;_ repeat ) ;_ DEFUN (PRINC ".")
;|===================================================== (PRESET) and (RESET) RECORDS CURRENT SYSTEM VARIABLES and RESTORES If debug set T, all routines enter debug mode with full echo to screen If debug set nil, functions work normally old_error to local variables in calling routine ==========================================================|;
(DEFUN preset () (IF (= (BOOLE 1 (GETVAR "cmdactive") 3) 0) (COMMAND "_.undo" "_mark") ) (IF debug (SETQ *error* nil) (PROGN (SETQ old_error *error*) (DEFUN *error* (s) (moder) (IF (OR (= s "Function cancelled") (= (STRCASE (SUBSTR s 1 4)) "QUIT") ) (PRINC) (PRINC (STRCAT "\nError: " s)) ) (IF old_error (SETQ *error* old_error) ) (REDRAW) (PRINC) ) ) ) )
(PRINC ".")
(DEFUN reset () (moder) (IF old_error (SETQ *error* old_error) ) ;_ if (IF debug (TEXTSCR) ) (PRINC) ) ;defun
(PRINC ".")
;**************************************************************** ;* (dxf (code elist)) ;* returns dxf code traditional version ;****************************************************************
(DEFUN dxf (code elist) (CDR (ASSOC code elist)) )
(PRINC ".") ;**************************************************************** ;* (dxf (code elist)) ;* returns dxf code enhanced version ;****************************************************************
;| ;;;Useful function, Not currently used ;;;this was the definition of dxf that I used until recently. ;;;see read.me ;;; returns the first group value of an entity. ;;; like the wellknown (dxf) function but accepts all kinds of ;;; entity representations (ename, entget list, entsel list) ;;; NOTE: For getting 10 groups in LWPOLYLINE's not usable! (defun GETVAL (code ele) ;"dxf value" of any ent... (cond ((= (type ele) 'ENAME) ;ENAME (cdr (assoc code (entget ele)))) ((not ele) nil) ;empty value ((not (listp ele)) nil) ;invalid ele ((= (type (car ele)) 'ENAME) ;entsel-list (cdr (assoc code (entget (car ele))))) (T (cdr (assoc code ele))))) ;entget-list
|;
(PRINC ".") ;**************************************************************** ;* (round (num sig)) ;* rounds of num to sig figures ;****************************************************************
(DEFUN round (num sig) (ATOF (RTOS num 1 (1- sig))))
(PRINC ".") ;**************************************************************** ;* (dtr (a)) ;* converts degrees to radians ;****************************************************************
(DEFUN dtr (a) (* PI (/ a 180.0)))
(PRINC ".")
;**************************************************************** ;* (not0 (lst)) ;* used with dxflst to find non "0" value in list of layers ;* used in match and offlayer ;****************************************************************
(DEFUN not0 (lst / va) (WHILE (EQUAL (CAR lst) "0") (SETQ lst (CDR lst))) (IF lst (SETQ va (CAR lst)) (SETQ va "0") ) ;_ if ) ;_ defun
(PRINC ".")
;**************************************************************** ;* (DXFLST (code nent)) ;* returns assoc code matches for all nested entities as list ;* used in match and offlayer ;****************************************************************
(DEFUN dxflst (code nent / va vb) (SETQ va (LIST (dxf code (ENTGET (CAR nent)))) vb (CAR (REVERSE nent)) ) ;_ setq (WHILE (= (TYPE (CAR vb)) 'ename) (SETQ va (APPEND va (LIST (dxf code (ENTGET (CAR vb))))) vb (CDR vb) ) ;_ setq ) ;_ while (SETQ va va) ;returns value of VA to calling routine ) ;_ defun
(PRINC ".")
;**************************************************************** ;* (toasc (str)) ;* Converts str to string using itoa or rtos. ;****************************************************************
(DEFUN toasc (str) (COND ((= (TYPE str) 'real) (RTOS str 2 (GETVAR "LUPREC"))) ((= (TYPE str) 'int) (ITOA str)) ((= (TYPE str) 'str) str) (T (TYPE str)) ) )
(PRINC ".")
;**************************************************************** ;* (warn (strng)) ;* displays message as prompt or alert ;* depending on ACAD release and DEBUG state ;****************************************************************
;| (DEFUN warn (strng) (IF (AND ALERT (NULL debug)) (ALERT strng) (PROMPT (STRCAT "\n" strng)) ) ) |;
;;;Revised definition of warn that always echoes to text screen (DEFUN warn (strng) (IF (AND ALERT (NULL debug)) (PROGN (PRINC);(princ) is a work-around for an R14 bug (ALERT strng) ) ) (PROMPT (STRCAT "\n" strng)) ) (PRINC ".")
;**************************************************************** ;* (ptom) ;* automatically changes focus to graphics screen ;* useful when debugging ;* offers to change to model space if paper space current ;****************************************************************
(DEFUN ptom () (GRAPHSCR) (IF (AND GETKWORD (= (GETVAR "CVPORT") 1) (= (GETVAR "TILEMODE") 0) ) (IF (confirm "Paper to Model" "Do you want to change to Model Space?" ) (COMMAND "._MSPACE") ) ;_ if ) ) ;;Remove ; to define PTOM as princ ;;this will disable PTOM function in all routines that use it
;(setq PTOM princ)
(PRINC ".")
;**************************************************************** ;* (mtop) ;* automatically changes focus to graphics screen ;* useful when debugging ;* offers to change to paper space if model space current anf TILEMODE=0 ;****************************************************************
(DEFUN mtop () (GRAPHSCR) (IF (AND GETKWORD (/= (GETVAR "CVPORT") 1) (= (GETVAR "TILEMODE") 0) ) (IF (confirm "Model to Paper" "Do you want to change to Paper Space?" ) (COMMAND "._PSPACE") ) ;_ if ) ) ;;Remove ; to define MTOP as princ ;;this will disable MTOP function in all routines that use it
;(setq MTOP princ)
(PRINC ".") ;**************************************************************** ;* (confirm (title string)) ;* asks for confirmation ;* and returns T or nil ;****************************************************************
(DEFUN confirm (title strng1 / yes) (COND ((< (SETQ supp_id (LOAD_DIALOG "supp.dcl")) 0) (PRINC "\nsupp.dcl not found! ") ) ((NULL (NEW_DIALOG "confirm_dlg" supp_id)) (PRINC "\nError in supp.dcl. ") ) (T (SET_TILE "confirm_title" title) (SET_TILE "confirm_text1" strng1) (ACTION_TILE "cancel" "(done_dialog 0)") (ACTION_TILE "accept" "(done_dialog 1)(setq YES T)") (START_DIALOG) ) ) (IF supp_id (UNLOAD_DIALOG supp_id) ) (EVAL yes) )
(PRINC ".")
;**************************************************************** ;* (mklay name colour linetype) ;* makes a layer if it does not already exist ;* uses (command "_.layer if R12 or earlier, otherwise entmake ;****************************************************************
(DEFUN mklay (name colour linetype) (IF (NOT (TBLSEARCH "LAYER" name)) (IF (<= (ATOI (SUBSTR (GETVAR "acadver") 1 2)) 12) (COMMAND "._layer" "_n" name "_c" colour "_lt" linetype "") (ENTMAKE (LIST '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord") (CONS 2 name) '(70 . 0) (CONS 62 colour) (CONS 6 linetype) ) ) ) ) )
(PRINC ".") (PRINC)
;3.00 23/8/97 Extra flexibility added to dxf ;3.01 29/8/97 Undo mark added ;3.02 14/12/97 Undo mark made dependant on no active command ;3.03 28/2/98 mtop round and dtr added ;3.04 26/4/98 mklay added ;3.05 4/7/98 dxf redefined ;3.06 22/8/98 (princ) work-around for R14 bug added to (warn...
Add pictures here
<% if( /^image/.test(type) ){ %>
<% } %>
<%-name%>
Add image file
Upload
Steve Yoxon schrieb:

I see a copyright note! Are you allowed to public all the code??
Juergen
Add pictures here
<% if( /^image/.test(type) ){ %>
<% } %>
<%-name%>
Add image file
Upload

Polytechforum.com is a website by engineers for engineers. It is not affiliated with any of manufacturers or vendors discussed here. All logos and trade names are the property of their respective owners.