Code Red > AutoLISP (Vanilla / Visual)
Examples of usage GRREAD - let's share
ElpanovEvgeniy:
At this forum, many programs with usage of function GRREAD are published, but I have decided to show some more simple, from the stores...
I hope, you too show the variants. :-)
Drawing of a line under a corner of 45 degrees
--- Code: ---(defun line<45 (/ GR LST PT)
; Drawing of a line under a corner of 45 degrees
; by ElpanovEvgeniy
; (2005-03-22 10:43:02)
;(line<45)
(setq lst (entget
(entmakex
(list
'(0 . "LINE")
(cons 8 (getvar "CLAYER"))
(cons 10 (setq pt (getpoint "\n Specify the first point ")))
(cons 11 pt)
) ;_ list
) ;_ entmakex
) ;_ entget
) ;_ setq
(princ "\n Specify the second point ")
(while (and (setq gr (grread 5)) (= (car gr) 5))
(entmod (subst
(cons 11 (polar pt (/ pi 4) (distance pt (cadr gr))))
(assoc 11 lst)
lst
) ;_ subst
) ;_ entmod
(entupd (cdr (assoc -1 lst)))
) ;_ while
) ;_ defun
--- End code ---
Change of radius of an arc
--- Code: ---(defun arc-radius (/ GR LST PT)
; Change of radius of an arc
; by ElpanovEvgeniy
; (2005-03-22 11:21:30)
;(arc-radius)
(setq lst (entget
(car (entsel "\n Select an arc "))
) ;_ entget
pt (cdr (assoc 10 lst))
) ;_ setq
(princ "\n Select new radius ")
(while (and (setq gr (grread 5)) (= (car gr) 5))
(entmod (subst
(cons 40 (distance pt (cadr gr)))
(assoc 40 lst)
lst
) ;_ subst
) ;_ entmod
(entupd (cdr (assoc -1 lst)))
) ;_ while
) ;_ defun
--- End code ---
Sequential choice of points
--- Code: ---(defun VECTORS (/ PT PTLIST)
; Sequential choice of points
; by ElpanovEvgeniy
; (2005-10-19 17:59:01)
; (VECTORS)
(setq PTLIST (list
(setq PT (getpoint "\n Specify the first point "))
) ;_ list
) ;_ setq
(princ "\n Specify the following point ")
(princ)
(while
(setq PT
(progn (while
(and (setq PT (grread 5))
(= (car PT) 5)
) ;_ and
(redraw)
(mapcar
(function
(lambda (x1 x2)
(grdraw x1 x2 6 5)
) ;_ lambda
) ;_ function
(cons (cadr PT) PTLIST)
PTLIST
) ;_ mapcar
) ;_ while
(if (listp (cadr PT))
(cadr PT)
) ;_ if
) ;_ progn
) ;_ setq
(setq PTLIST (cons PT PTLIST))
) ;_ while
) ;_ defun
--- End code ---
Clone Select CP
--- Code: ---(defun lst-ent-wp (/ PT PTLIST SS)
; Clone Select CP
; by ElpanovEvgeniy
; (2006-05-11 11:05:52)
; (lst-ent-wp)
(setq
PTLIST (list (setq PT (getpoint "\n Specify the first point ")))
) ;_ setq
(princ "\n Specify the following point ")
(princ)
(while
(setq
PT (progn
(while
(and
(setq PT (grread 5))
(= (car PT) 5)
) ;_ and
(redraw)
(mapcar
(function
(lambda (x1 x2)
(grdraw x1 x2 6 5)
) ;_ lambda
) ;_ function
(cons (cadr PT) PTLIST)
(append PTLIST (cdr PT))
) ;_ mapcar
) ;_ while
(if (listp (cadr PT))
(cadr PT)
) ;_ if
) ;_ progn
) ;_ setq
(setq PTLIST (cons PT PTLIST))
) ;_ while
(redraw)
(vla-ZoomExtents (vlax-get-acad-object))
(if (setq ss (ssget "CP" PTLIST))
(vl-remove-if
(function listp)
(mapcar (function cadr) (ssnamex ss))
) ;_ vl-remove-if
) ;_ if
) ;_ defun
--- End code ---
Example of usage of various matrixes in LISP
--- Code: ---(defun c:test (/ A LST P P1 S X Y)
; Example of usage of various matrixes in LISP
; by ElpanovEvgeniy
; (2006-10-01)
; (c:test)
(setq lst '((0. 0.) (0. 1.) (1. 1.) (1. 0.))
p1 (trans (setq p (getpoint "\n Get base point")) 1 3)
x (car p1)
y (cadr p1)
) ;_ setq
(while (= (car (setq p (grread nil 5))) 5)
(setq p (trans (cadr p) 1 3)
p (list (- (car p) x) (- (cadr p) y))
a 0. ;(angle p1 p)
s (/ (getvar "viewsize") 10.)
) ;_ setq
(if (> (abs (car p)) (abs (cadr p)))
(setq p (list
(if (minusp (car p))
-1.
1.
) ;_ if
(if (zerop (car p))
0.
(/ (cadr p) (abs (car p)))
) ;_ if
) ;_ list
) ;_ setq
(setq p (list
(if (zerop (cadr p))
0.
(/ (car p) (abs (cadr p)))
) ;_ if
(if (minusp (cadr p))
-1.
1.
) ;_ if
) ;_ list
) ;_ setq
) ;_ if
(redraw)
(grvecs
(apply
(function append)
(cons (list 3 '(0 0) p)
(mapcar
(function
(lambda (l)
(apply
(function append)
(mapcar
(function
(lambda (x x1) (list 1 x x1))
) ;_ function
l
(cons (last l) l)
) ;_ mapcar
) ;_ apply
) ;_ lambda
) ;_ function
(mapcar
(function
(lambda (n)
(setq
n (list
(+ (* (car n) (car p)) (* (cadr n) (cadr p)))
(+ (* (car n) (cadr p)) (* (cadr n) (- (car p))))
) ;_ list
) ;_ setq
(mapcar (function (lambda (x1) (mapcar (function +) x1 n))) lst)
) ;_ lambda
) ;_ function
'((-2 -2)(-1 -2)(0 -2)(1 -2)(2 -2)
(-2 -1)(-1 -1)(0 -1)(1 -1)(2 -1)
(-2 0)(-1 0)(0 0)(1 0)(2 0)
(-2 1)(-1 1)(0 1)(1 1)(2 1)
(-2 2)(-1 2)(0 2)(1 2)(2 2)
)
) ;_ mapcar
) ;_ mapcar
) ;_ cons
) ;_ apply
(list
(list (* (cos a) s) (* (- (sin a)) s) 0. (- (+ x x) (* x (cos a)) (* y (- (sin a)))))
(list (* (sin a) s) (* (cos a) s) 0. (- (+ y y) (* x (sin a)) (* y (cos a))))
(list 0. 0. s 0.)
'(0. 0. 0. 1.)
) ;_ list
) ;_ grvecs
) ;_ while
(redraw)
) ;_ defun
--- End code ---
ElpanovEvgeniy:
Has found two more programs which are not published at this forum...
:-)
Addition of a point in a polyline
--- Code: ---(defun C:LW_pt (/ ENT I LST LW PAR PT)
; Addition of a point in a polyline
; by ElpanovEvgeniy
; (2005-11-09 15:05:39)
; (C:LW_pt)
(setq pt (getpoint " \n Specify a new point polylines. "))
(if (and pt (setq lw (ssget pt '((0 . "LWPOLYLINE")))) (setq lw (ssname lw 0)))
(progn
(setq par (vlax-curve-getParamAtPoint lw (vlax-curve-getClosestPointTo lw pt))
ent (entget lw)
ent (subst (cons 90 (1+ (cdr (assoc 90 ent)))) (assoc 90 ent) ent)
i 0
lst nil
) ;_ setq
(while (or (/= (caar ent) 41)
(if (< i (fix par))
(setq i (1+ i))
) ;_ if
) ;_ or
(setq lst (cons (car ent) lst)
ent (cdr ent)
) ;_ setq
) ;_ while
(setq lst (cons (cons 41
(+ (cdr (assoc 40 lst))
(* (- (cdr (assoc 41 ent)) (cdr (assoc 40 lst))) (- par (fix par)))
) ;_ +
) ;_ cons
lst
) ;_ cons
lst (cons (cons 42
(/ (sin (setq i
(- (angle (vlax-curve-getPointAtParam lw (fix par)) pt)
(angle
(vlax-curve-getPointAtParam lw (fix par))
(vlax-curve-getPointAtParam lw (+ (fix par) (/ (- par (fix par)) 2.)))
) ;_ angle
) ;_ -
) ;_ setq
) ;_ sin
(cos i)
) ;_ /
) ;_ cons
lst
) ;_ cons
lst (cons (assoc 41 ent)
(cons (cons 40 (cdr (assoc 41 lst))) (cons (list 10 (car pt) (cadr pt)) lst))
) ;_ cons
lst (cons
(cons
42
(/
(sin (setq
i (- (angle pt (vlax-curve-getPointAtParam lw (1+ (fix par))))
(angle
pt
(vlax-curve-getPointAtParam lw (+ par (/ (- (1+ (fix par)) par) 2.)))
) ;_ angle
) ;_ -
) ;_ setq
) ;_ sin
(cos i)
) ;_ /
) ;_ cons
lst
) ;_ cons
) ;_ setq
(vla-StartUndoMark (vla-get-activedocument (vlax-get-acad-object)))
(entmod (append (reverse lst) (cddr ent)))
(entupd lw)
(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))
) ;_ progn
(princ " \n Specified point does not lay on a polyline. ")
) ;_ if
(princ)
) ;_ defun
--- End code ---
Addition of a point in a lwpolyline, line, arc, circle
--- Code: ---(defun c:lw_pt_1 (/ ent i gr lst lw par pt)
; Addition of a point in a lwpolyline, line, arc, circle
; by ElpanovEvgeniy
; (2005-11-10 12:48:04)
; (c:lw_pt_1)
(princ " \n Specify a new point polylines. ")
(while (and (setq gr (grread 5)) (= (car gr) 5))
(if lw
(redraw lw 4)
) ;_ if
(if (and (setq pt (osnap (cadr gr) "_nea,_end"))
(setq lw (ssget pt '((0 . "LWPOLYLINE,LINE,ARC,CIRCLE"))))
(setq lw (ssname lw 0))
(setq ent (entget lw))
) ;_ and
(redraw lw 3)
) ;_ if
) ;_ while
(cond
((= (cdr (assoc 0 ent)) "LWPOLYLINE")
(setq par (vlax-curve-getparamatpoint
lw
(vlax-curve-getclosestpointto
lw
pt
) ;_ vlax-curve-getclosestpointto
) ;_ vlax-curve-getparamatpoint
ent (subst (cons 90 (1+ (cdr (assoc 90 ent))))
(assoc 90
ent
) ;_ assoc
ent
) ;_ subst
i 0
lst nil
) ;_ setq
(if (/= par (fix par))
(progn (while (or (/= (caar ent) 41)
(if (< i (fix par))
(setq i (1+ i))
) ;_ if
) ;_ or
(setq lst (cons (car ent) lst)
ent (cdr ent)
) ;_ setq
) ;_ while
(setq lst (cons
(cons
41
(+ (cdr (assoc 40 lst))
(* (- (cdr (assoc 41 ent)) (cdr (assoc 40 lst)))
(-
par
(fix par)
) ;_ -
) ;_ *
) ;_ +
) ;_ cons
lst
) ;_ cons
lst (cons
(cons
42
(/
(sin
(setq i (-
(angle
(vlax-curve-getpointatparam
lw
(fix par)
) ;_ vlax-curve-getpointatparam
pt
) ;_ angle
(angle (vlax-curve-getpointatparam lw (fix par))
(vlax-curve-getpointatparam
lw
(+ (fix par)
(/ (-
par
(fix par)
) ;_ -
2.
) ;_ /
) ;_ +
) ;_ vlax-curve-getpointatparam
) ;_ angle
) ;_ -
) ;_ setq
) ;_ sin
(cos i)
) ;_ /
) ;_ cons
lst
) ;_ cons
lst (cons (assoc 41 ent)
(cons (cons 40 (cdr (assoc 41 lst)))
(cons (list 10 (car pt) (cadr pt))
lst
) ;_ cons
) ;_ cons
) ;_ cons
lst (cons
(cons
42
(/
(sin
(setq
i (-
(angle pt
(vlax-curve-getpointatparam
lw
(1+ (fix par))
) ;_ vlax-curve-
) ;_ angle
(angle pt
(vlax-curve-getpointatparam
lw
(+ par
(/ (-
(1+ (fix par))
par
) ;_ -
2.
) ;_ /
) ;_ +
) ;_ vlax-curve-getpointatparam
) ;_ angle
) ;_ -
) ;_ setq
) ;_ sin
(cos i)
) ;_ /
) ;_ cons
lst
) ;_ cons
) ;_ setq
(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(entmod (append (reverse lst) (cddr ent)))
(entupd lw)
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
) ;_ progn
) ;_ if
(vl-cmdf
"_.stretch"
"_C"
pt
pt
""
pt
(getpoint pt " Specify a new point: ")
) ;_ vl-cmdf
)
((= (cdr (assoc 0 ent)) "LINE")
(setq lst '((0 . "LWPOLYLINE")))
(foreach x '(100 67 410 8 62 6 370)
(if (assoc x ent)
(setq lst (cons (assoc x ent) lst))
) ;_ if
) ;_ foreach
(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(entmakex
(append (reverse lst)
(list '(100 . "AcDbPolyline")
'(90 . 3)
'(70 . 0)
(cons 38 (cadddr (assoc 10 ent)))
(assoc 10 ent)
'(40 . 0)
'(41 . 0)
'(42 . 0)
(cons 10 (list (car pt) (cadr pt)))
'(40 . 0)
'(41 . 0)
'(42 . 0)
(cons 10
(list (cadr (assoc 11 ent))
(caddr (assoc 11
ent
) ;_ assoc
) ;_ caddr
) ;_ list
) ;_ cons
'(40 . 0)
'(41 . 0)
'(42 . 0)
(assoc 210 ent)
) ;_ list
) ;_ append
) ;_ entmakex
(entdel lw)
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
(vl-cmdf "_.stretch"
"_C"
pt
pt
""
pt
(getpoint pt " Specify a new point: ")
) ;_ vl-cmdf
)
((= (cdr (assoc 0 ent)) "ARC")
(setq lst '((0 . "LWPOLYLINE"))
par (vlax-curve-getparamatpoint
lw
(vlax-curve-getclosestpointto
lw
pt
) ;_ vlax-curve-
) ;_ vlax-curve-getparamatpoint
) ;_ setq
(foreach x '(100 67 410 8 62 6 370)
(if (assoc x
ent
) ;_ assoc
(setq lst (cons (assoc x ent) lst))
) ;_ if
) ;_ foreach
(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(entmakex
(append
(reverse lst)
(list
'(100 . "AcDbPolyline")
'(90 . 3)
'(70 . 0)
(cons 38 (cadddr (assoc 10 ent)))
(cons
10
(reverse
(cdr
(reverse
(polar
(cdr
(assoc 10 ent)
) ;_ cdr
(cdr (assoc 50 ent))
(cdr (assoc 40 ent))
) ;_ polar
) ;_ reverse
) ;_ cdr
) ;_ reverse
) ;_ cons
'(40 . 0)
'(41 . 0)
(cons
42
(/
(sin
(setq i (-
(angle
(vlax-curve-getstartpoint lw)
pt
) ;_ angle
(angle
(vlax-curve-getstartpoint lw)
(vlax-curve-getpointatparam
lw
(+ (vlax-curve-getstartparam lw)
(/
(- par
(vlax-curve-getstartparam
lw
) ;_ vlax-curve-
) ;_ -
2.
) ;_ /
) ;_ +
) ;_ vlax-curve-getpointatparam
) ;_ angle
) ;_ -
) ;_ setq
) ;_ sin
(cos i)
) ;_ /
) ;_ cons
(cons 10 (list (car pt) (cadr pt)))
'(40 . 0)
'(41 . 0)
(cons 42
(/ (sin
(setq i (-
(angle pt (vlax-curve-getendpoint lw))
(angle pt
(vlax-curve-getpointatparam
lw
(+ par
(/ (-
(vlax-curve-getendparam lw)
par
) ;_ -
2.
) ;_ /
) ;_ +
) ;_ vlax-curve-getpointatparam
) ;_ angle
) ;_ -
) ;_ setq
) ;_ sin
(cos i)
) ;_ /
) ;_ cons
(cons
10
(reverse
(cdr
(reverse
(polar
(cdr
(assoc
10
ent
) ;_ assoc
) ;_ cdr
(cdr (assoc 51 ent))
(cdr (assoc 40 ent))
) ;_ polar
) ;_ reverse
) ;_ cdr
) ;_ reverse
) ;_ cons
'(40 . 0)
'(41 . 0)
'(42 . 0)
(assoc 210 ent)
) ;_ list
) ;_ append
) ;_ entmakex
(entdel lw)
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
(vl-cmdf "_.stretch"
"_C"
pt
pt
""
pt
(getpoint pt " Specify a new point: ")
) ;_ vl-cmdf
)
((= (cdr (assoc 0 ent)) "CIRCLE")
(setq lst '((0 . "LWPOLYLINE")))
(foreach x '(100 67 410 8 62 6 370)
(if (assoc x ent)
(setq lst (cons (assoc x ent) lst))
) ;_ if
) ;_ foreach
(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(entmakex
(append (reverse lst)
(list '(100 . "AcDbPolyline")
'(90 . 2)
'(70 . 1)
(cons 38 (cadddr (assoc 10 ent)))
(cons 10 (list (car pt) (cadr pt)))
'(40 . 0)
'(41 . 0)
(cons 42 (/ (sin (/ pi 4.)) (cos (/ pi 4.))))
(cons 10
(reverse
(cdr (reverse (polar (cdr (assoc 10 ent))
(angle
pt
(cdr (assoc 10 ent))
) ;_ angle
(cdr (assoc 40 ent))
) ;_ polar
) ;_ reverse
) ;_ cdr
) ;_ reverse
) ;_ cons
'(40 . 0)
'(41 . 0)
'(42 . 1.)
(assoc 210 ent)
) ;_ list
) ;_ append
) ;_ entmakex
(entdel lw)
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
(vl-cmdf "_.stretch"
"_C"
pt
pt
""
pt
(getpoint pt " Specify a new point: ")
) ;_ vl-cmdf
)
(t (princ " \n Specified point does not lay on a polyline or line, arc, circle... "))
) ;_ cond
(princ)
) ;_ defun
--- End code ---
Crank:
Do you mean GRREAD or GRDRAW? :D
Here is a function I call after the STRETCH command:
--- Code: ---(defun rc (/ p1 p2 p3 p4 a g om)
(setq om (getvar "OSMODE"))(setvar "OSMODE" 0)
(setq p1 (getpoint "\nSelect objects to stretch by (rotated) crossing..."))
(princ "\nOther corner...")
(while (not a)
(setq g (grread T) p3 (cadr g))
(cond ((= (car g) 3) ; PICK BUTTON?
(setq a T)
(redraw)
)
((= (car g) 5) ; POSITIE?
(setq p2 (list (car p1)(cadr p3)))
(setq p4 (list (car p3)(cadr p1)))
(redraw)(grvecs (list -256 p1 p2 p2 p3 p3 p4 p4 p1))
)
)
)
(setvar "OSMODE" om)
(ssget "CP" (list p1 p2 p3 p4))
)
--- End code ---
I never understood why the box of a crossing or window doesn't follow the angle of the UCS.
MickD:
--- Quote from: Crank on October 08, 2006, 02:38:53 PM ---....
I never understood why the box of a crossing or window doesn't follow the angle of the UCS.
--- End quote ---
A lot of it has to do with the graphics api (not AutoCAD but the OpenGL/DirectX api's). In order for the application to get feedback from the user, the application feeds the graphics api a 'pick box' which can vary in size from the std pick box used by autocad (say 4 pixels square) to a selection window of given size by the user.
Now, given this pick box the application has to tell the grfx api to go into selection mode which creates a selection buffer, the grfx api then clips out any geometry (pixels) outside the box and returns a 'hit list' containing id numbers of the primitives which are mapped to autocad primitives that make up more complex objects, this way Autocad can find out what was selected and let you modify them.
You can see now how complex it could get if you tried to capture pixels in any direction but 'square' to the screen.
A work around could be to grab the rectangle and the model/scene and transform it to be square, do the selection thing and invert it back but there may be some subtle inaccuracies with doing this not to mention a performance hit.
hth,
Mick.
daron:
Quite a bit for me, Mick. Thanks.
Navigation
[0] Message Index
[#] Next page
Go to full version