TheSwamp

Code Red => AutoLISP (Vanilla / Visual) => Topic started by: ElpanovEvgeniy on October 08, 2006, 12:29:39 PM

Title: Examples of usage GRREAD - let's share
Post by: ElpanovEvgeniy on October 08, 2006, 12:29:39 PM
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: [Select]
(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


Change of radius of an arc

Code: [Select]
(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

Sequential choice of points

Code: [Select]
(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

Clone Select CP

Code: [Select]
(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

Example of usage of various matrixes in LISP

Code: [Select]
(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
Title: Re: Examples of usage GRREAD - let's share
Post by: ElpanovEvgeniy on October 08, 2006, 01:07:06 PM
Has found two more programs which are not published at this forum...
 :-)

Addition of a point in a polyline

Code: [Select]
(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

Addition of a point in a lwpolyline, line, arc, circle

Code: [Select]
(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
Title: Re: Examples of usage GRREAD - let's share
Post by: Crank on October 08, 2006, 02:38:53 PM
Do you mean GRREAD or GRDRAW? :D

Here is a function I call after the STRETCH command:
Code: [Select]
(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))
)
I never understood why the box of a crossing or window doesn't follow the angle of the UCS.
Title: Re: Examples of usage GRREAD - let's share
Post by: MickD on October 08, 2006, 06:56:36 PM
....
I never understood why the box of a crossing or window doesn't follow the angle of the UCS.


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.
Title: Re: Examples of usage GRREAD - let's share
Post by: daron on October 09, 2006, 08:21:58 AM
Quite a bit for me, Mick. Thanks.
Title: Re: Examples of usage GRREAD - let's share
Post by: sinc on October 09, 2006, 09:52:08 AM

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.

Are you really sure about all this, or is it a lot of guesswork?

You can always type WP or CP at the "Select Objects" prompt, and select any irregular selection area you want.  The selection area can be pretty convoluted.  If it's possible to easily select any irregular area like that, why would it be any harder to create a rectangular box oriented with, say, the SNAPANG?
Title: Re: Examples of usage GRREAD - let's share
Post by: ElpanovEvgeniy on October 09, 2006, 04:34:54 PM

Do you mean GRREAD or GRDRAW? :D


I meant GRREAD!
Actually, it can be used in greater quantity cases, than it is done by me....
I would like to see various variants of application :-)
Title: Re: Examples of usage GRREAD - let's share
Post by: GDF on October 09, 2006, 05:08:05 PM
Not sure of this one, I think it uses grread...anyway it is a kool routine.

..google it..

Code: [Select]

                                K4KUBE.TXT
                                ==========

                      Freeware Version 1.01 of K4KUBE

                   Copyright (C) 2002,  K4 CAD Solutions


WELCOME TO K4KUBE
===============================================================================

K4KUBE is a free RUBIK'S CUBE game for AutoCAD (R12, R13, R14, 2000, 2002).

K4KUBE comes as a zipped file (A_RUBIX.ZIP) which unzips into two files:

K4KUBE.TXT  - This File.
K4KUBE.LSP  - An AutoLISP program to play
              R U B I K ' S   C U B E.


INSTALLING K4KUBE
===============================================================================

1) Create a new directory with the path C:\K4KUBE (or any other name).
2) Unzip A_RUBIX.ZIP which expands into the two files listed above.


RUNNING K4KUBE
===============================================================================

Using the AutoCAD Menus, select 'Tools', then 'Load Application...', then
select K4KUBE.LSP from the folder which you installed into. Click on
'Load' then verify that it loaded successfully.

OR,  at the AutoCAD command prompt type:

     (load "c:/k4kube/k4kube")     [Note: use forward slashes].

     If you have installed K4KUBE into a different directory or folder than
     the one above, eg. C:\Program Files\K4kube then type:

     (load "c:/program files/k4kube/k4kube")

OR,  for easier loading copy the file K4KUBE.LSP somewhere into the AutoCAD
     support path and then type:

     (load "k4kube")

Alternatively, the AutoLISP File K4KUBE.LSP may be loaded by double clicking
on it via Windows Explorer.


Once loaded, the command K4KUBE runs automatically.

Click on Large Arrows to turn the cube.
Click on Small Arrows to turn a layer.
Click on buttons to:  MIX  (10 random twists)
                      SORT (resets cube)
                      QUIT (quits K4KUBE, remembers last permutation)
The command K4KUBE be run at any time from the Command Bar.


NOTE: If running in IntelliCAD type:

     (setq k4icad 1)

      at the command prompt.

  OR,

      Create a new file called 'K4KUBE-P.LSP' containing:

      (setq k4icad 1)
      (load "c:/k4kube/k4kube")  ;;modify to your installation path

      Finally, to run K4KUBE type:

      (load "c:/k4kube/k4kube-p")


ABOUT K4 CAD SOLUTIONS
===============================================================================

K4 CAD Solutions develops bespoke software for AutoCAD (and Windows) to meet
very specific user-requirements that are often not fully addressed by 'off
the shelf packages'.  Examples of the types of projects undertaken include:

     Parametric Commands : Commands to automate the drawing of complicated
                           designs simply by specifying dimensions of the
                           features within the design.  Use of dialogue boxes
                           enables fast and accurate data entry.

 Manufacturers Databases : Suites of commands that interactively display then
                           insert your company's manufactured products into
                           drawings - for use in-house or for distribution to
                           engineers, architects and specifiers.

     CNC Code Generators : Commands to draw machined parts and automatically
                           generate CNC code to your exact specifications.
                           G CODE turning and milling projects undertaken.

For more information regarding the services on offer or to discuss your
specific requirements in detail email K4 CAD Solutions at:

                           admin@k4cadsolutions.co.uk

or visit the web site:     http://www.k4cadsolutions.co.uk


       Fixed price quotes offered for well defined and specified projects.
             K4 CAD Solutions is based in Yorkshire, United Kingdom.


WARRANTY STATEMENT
===============================================================================

Author is not responsible for any damages whatsoever, including loss of
information, interruption of business, personal injury and/or any damage or
consequential damage without limitation, incurred before, during or after the
use of this product. Author's entire liability, without exception, is limited to
the customers' reimbursement of the purchase price (if applicable) of the
software (maximum being the suggested retail price) in exchange for the
return of the product, all copies, registration papers and manuals, and all
materials that constitute a transfer of ownership from the customer back to
Author.


LICENSE
===============================================================================

Each registered copy of this software may be used in only one single
location by one user.  Use of the software means that you have loaded the
program and run it or have installed the program onto a computer.  If you
install the software onto a multi-user platform or network, each and every
individual user of the software must be registered separately.

You may make one copy of the registered software for backup purposes,
providing you only have one copy installed on one computer being used by
one person.  If any person other than yourself uses software registered in
your name, regardless of whether it is at the same time or different times,
then this agreement is being violated!

The sale of and or distribution of registered copies of this software are
strictly forbidden.  It is a violation of this agreement to loan, rent,
lease, borrow, or transfer the use of registered copies of this software
product.


            AutoCAD is a registered trademark of Autodesk Inc.
        Windows is a registered tradmark of Microsoft Corporation

===============================================================================
Copyright (C) K4 CAD Solutions, April 2002
===============================================================================
Title: Re: Examples of usage GRREAD - let's share
Post by: MickD on October 09, 2006, 06:52:09 PM
...
Are you really sure about all this, or is it a lot of guesswork?
...

The part about how selection is accomplished yes, the accuracy of using irregular selection shapes no. Although it is possible to use irregular shapes it would take multiple passes or some mathematical gymnastics to get the correct primitives for the selection, especially if you had a curved edge in your selection shape.

I'll expand a bit on the selection process as performed by the grfx api for those interested. From here we'll call the host application using the grfx api the 'app' and the graphics api the 'grfx'.
Prior to selection, the app using the selection buffer must change the state of the grfx to 'selection' mode which draws all of the primitives to a special buffer (not to the screen) and gathers all of the objects drawn there.
Here's the process just using the std acad pickbox (cursor) which is about 4x4 pixels say -

1. The user picks a line say which sends a WM_MOUSEDOWN message, the app's window procedure catches and handles it appropriately. Depending on the state of the application it can handle this how it pleases, for now we'll say it is idle and will handle selection to highlight entities picked with the cursor in the editor (the client area of the main window where the grfx will draw its primitives).

2. Having caught the message the app has to tell the grfx it wants to do a sellection of the picked object. To do this the app must set the 'state' of the graphics to selection to draw to the selection buffer. To draw to this buffer (just like any other window) the app has to pass in of its viewing transformation, which also contains the view/model and clipping volume and finally maps this to a rectangle on the screen, generally the x and y size of our client rectangle/editor. In the case of the selection buffer we only want what's under the cursor so we pass in the x and y size of the 'pick box', the app assigns an id to each primitive (using named lists in the grfx) before it's drawn which the grfx uses to identify the drawn primitives. The grfx then draws the objects to the selection buffer, grabs a list of the ids it has drawn after 'clipping' and passes this list/array back to the app.
How does it get the id's? As the grfx has to calculate the colour of each pixel it draws to the buffer, in the selection mode it also assigns an id of each drawn primitive to each pixel within the selection rectangle/buffer, when you do a 'pick' or even a windowed selection you are just picking a rectangle/box of pixels and use the info store in the buffer mapped to that pixel.

3. On receiving the 'hit list' of objects drawn to the selection buffer (remembering the selection rect clips out all unwanted geometry outside of the rect passed in) the app iterates the list and handles it how it pleases, in Autocad's case it calls the ent->highlight() member function of the/each selected entity to tell it to draw itself highlighted. The app then redraws the scene in the normal rendering mode passing in all of the entities and now the ent's to be highlighted with the appropriate primitive line type to appear highlighted.

For autocad to use irregular selection with a polyline say, it would almost have to be only in 2d to keep the math simple and it would not need to use the selection buffer of the grfx, if it can do it with a 3d model (items that don't cross the polyline in the same plane) it would have to be doing its own projections to the polyline plane and then the clipping. Basically though the selction buffer is the most efficient way to collect selected entities IMO as this is what it is used and optimised for.

Cheers,
Mick.



Title: Re: Examples of usage GRREAD - let's share
Post by: sinc on October 09, 2006, 08:31:56 PM

For autocad to use irregular selection with a polyline say, it would almost have to be only in 2d to keep the math simple and it would not need to use the selection buffer of the grfx, if it can do it with a 3d model (items that don't cross the polyline in the same plane) it would have to be doing its own projections to the polyline plane and then the clipping. Basically though the selction buffer is the most efficient way to collect selected entities IMO as this is what it is used and optimised for.


Autocad can in fact select anything, in full 3D, with irregular windows.  But I notice that irregular windows can also select things that are not visible on the screen, while the normal rectangular windows cannot.  So this seems to imply that Autocad uses the grfx for normal windows, but does its own model parsing for irregular windows.  I don't notice any performance difference between the two, but I'm guessing I might with a much bigger drawing or with slower hardware.

In either case, the objects appear to be projected in into the plane of the current view to determine what gets selected.
Title: Re: Examples of usage GRREAD - let's share
Post by: MickD on October 09, 2006, 09:08:15 PM
...  I don't notice any performance difference between the two, but I'm guessing I might with a much bigger drawing or with slower hardware.

Not these days with the processing power we have, it may have been different back in 14/2000 though :)

Quote
In either case, the objects appear to be projected in into the plane of the current view to determine what gets selected.

I have been playing with my own 3d modeller in ogl for a while and an irregular selection will be a 'feature' that is not very high on the list because of the obvious complications but as you state above that is probably how I'd approach it - project the primitive linework to the viewing plane and clip.

sorry to polute the thread but this is one of my favorite subjects/api's...thanks for listening, carry on :)
Title: Re: Examples of usage GRREAD - let's share
Post by: SomeCallMeDave on October 10, 2006, 09:38:58 AM
Here is one that I use to change the current elevation up or down by 2' just by gesturing up or down with the mouse.  I use it when I have to drawn contours manually.

Code: [Select]
(defun c:ew(/ NewEL el1 DeltaEl)
  (setq CurrElev (getvar "ELEVATION")
        newDir (dkb_readMouse)
  )
  (if (minusp newDir) (setq NewEl -2) (setq NewEl 2))       
 
  (setvar "ELEVATION" (+ CurrElev NewEL))
); end function ew


(defun dkb_readMouse()

    (setq firstY nil)     
   
    (while (= (setq grCode (car (setq grData (grread T 7 0)))) 5)
         (setq grReturn (cadr grData))
          (if (= grCode 5)
              (progn
                  (if (not firstY)
                       (setq firstY (cadr grReturn)
                             currDelta 0
                        )
                        (setq currDelta (- (cadr grReturn) firstY))
                   )     
               );progn then
          );if     
     );end while
)




And one to adjust the elevation by a small increment by continually moving the mouse up or down

Code: [Select]

(defun c:eew()
  (dkb_mouseelev)

)

(defun dkb_MouseElev()

    (setq firstY nil
          TotalY (getvar "VIEWSIZE")
          NumSteps 50
          YStep (fix (/ TotalY NumSteps))
          DeltaElPerStep 0.05
          CurrEL (getvar "ELEVATION")
    )     
    (while (= (setq grCode (car (setq grData (grread T 7 0)))) 5)
         (setq grReturn (cadr grData))
          (if (= grCode 5)
              (progn
                  (if (not firstY)
                       (setq firstY (cadr grReturn)
                             currDelta 0
                        )
                        (setvar "ELEVATION"
                          (+ CurrEl
                             (* DeltaElPerStep
                                 (fix (/(setq currDelta (- (cadr grReturn) firstY)) YStep))
                             )
                          )
                        );setvar and end else
                   ); end inner if     
               );progn then
          );if     
     );end while
)

And one to change the text value of a spot elevation by, you guessed it,  moving the mouse up or down.  The 'new text value' is shown in the modemacro box.  When the left mouse button is hit, the text string is changed to the modemacro value.

Code: [Select]
(defun c:et()
   (setq Ent1Name (car (entsel "\nPick Text to Edit "))
    Ent1List (entget Ent1Name)
    Ent1Elev (atof (cdr (assoc 1 Ent1List)))
    OldMode (getvar "MODEMACRO")
         OldElev (getvar "ELEVATION")
   );setq
   (setvar "MODEMACRO" (rtos Ent1Elev 2 2 ))
    (setq firstY nil
          TotalY (getvar "VIEWSIZE")
          NumSteps 50
          YStep (max (fix (/ TotalY NumSteps)) 1)
          DeltaElPerStep 0.05
          CurrEL (atof (getvar "MODEMACRO"))
    )     
    (while (= (setq grCode (car (setq grData (grread T 7 0)))) 5)
         (setq grReturn (cadr grData))
          (if (= grCode 5)
              (progn
                  (if (not firstY)
                       (setq firstY (cadr grReturn)
                             currDelta 0
                        )
                        (setvar "MODEMACRO"
                          (rtos (+ CurrEl
                             (* DeltaElPerStep
                                 (fix (/(setq currDelta (- (cadr grReturn) firstY)) YStep))
                             )
                          ) 2 2 )
                        );setvar and end else
                   ); end inner if     
               );progn then
          );if     
     );end while
     (setq newEl (atof (getvar "MODEMACRO"))
           newElStr (rtos newEl 2 2)
           newEntList (subst (cons 1 newElStr) (assoc 1 ent1List) ent1List)
     )
     (setvar "ELEVATION" oldElev)
     (setvar "MODEMACRO" oldMode)
     (entmod newEntList)
     (prin1)     
 
);defun et
Title: Re: Examples of usage GRREAD - let's share
Post by: ElpanovEvgeniy on October 13, 2006, 11:18:01 AM
It is a working example of usage of OSNAP and the shortcut menu together with GRREAD function.


Code: [Select]
(defun menu-pop500 (d / lst p s)
  ; Choice function of OSNAP through the shortcut menu.
  ; Only, as an example.
  ; Is checked up in AutoCad 2004-2007 (En)
  ; by ElpanovEvgeniy
  ; (2006-10-11)
  ; (menu-pop500 (grread t 5))
  (setq
    lst (reverse
          (menu-index
            ((lambda (x) (list (1- (vla-get-count x)) x))
              (vla-item
                (vla-get-menus
                  (vla-item
                    (vla-get-menugroups
                      (vlax-get-acad-object)
                    ) ;_  vla-get-MenuGroups
                    "ACAD"
                  ) ;_  vla-item
                ) ;_  vla-get-Menus
                "&Object Snap Cursor Menu"
                ;|
 " *Object Snap Cursor Menu "
For localization into other languages, it is possible to use function bu kpblc
(cond
  ((vl-string-search "419" (setq p(vlax-product-key)))
    ;; The Russian version
   "&Контекстное меню привязки")
  ((vl-string-search "409" p)
   ;; The English version
    "&Object Snap Cursor Menu"
    ))

|;
              ) ;_  vla-item
            )
          ) ;_  menu-index
        ) ;_  reverse
  ) ;_  setq
  (while (and
           (listp d)
           (or (= (car d) 5)
               (= (car d) 11)
               (= (car d) 12)
               (= (car d) 25) ; For old version AutoCad
           ) ;_  or
         ) ;_  and
    (cond
      ((= (car d) 25) (menucmd "POP500=*")) ; For old version AutoCad
      ((equal d '(11 0)) (menucmd "POP500=*"))
      ((= (car d) 11) (setq s (nth (- (cadr d) 500) lst)))
    ) ;_  cond
    (if s
      (setq d s)
      (setq d (grread t 5))
    ) ;_  if
  ) ;_  while
  (substr s 1 4)
) ;_  defun
(defun menu-index (l)
  ; Creation of the list of choices of choice of OSNAP
  ; Is checked up in AutoCad 2004-2007 (En)
  ; by ElpanovEvgeniy
  ; (2006-10-11)
                  ;|
(menu-index
 ((lambda (x) (list (1-(vla-get-count x)) x))
  (vla-item
   (vla-get-menus
    (vla-item
     (vla-get-menugroups
      (vlax-get-acad-object)
      ) ;_  vla-get-MenuGroups
     "ACAD"
     ) ;_  vla-item
    ) ;_  vla-get-Menus
   "&Object Snap Cursor Menu"
   ) ;_  vla-item
  )
 ) ;_  menu-index
 |;
  (if (not (minusp (car l)))
    (cond
      ((= (vla-get-type (vla-item (cadr l) (car l))) 0)
       (cons
         (vla-get-macro (vla-item (cadr l) (car l)))
         (menu-index (cons (1- (car l)) (cdr l)))
       ) ;_  cons
      )
      ((= (vla-get-type (vla-item (cadr l) (car l))) 1)
       (menu-index (cons (1- (car l)) (cdr l)))
      )
      ((= (vla-get-type (vla-item (cadr l) (car l))) 2)
       (append
         (menu-index
           ((lambda (x) (list (1- (vla-get-count x)) x))
             (vla-get-submenu (vla-item (cadr l) (car l)))
           ) ;_  menu-index
         ) ;_  menu-index
         (menu-index (cons (1- (car l)) (cdr l)))
       ) ;_  append
      )
    ) ;_  cond
  ) ;_  if
) ;_  defun
(defun get_osmode nil
  ; Function create list osmode macro
  ; for result (getvar "OSMODE")
  ; by Evgeniy Elpanov
  ; (get_osmode)
  (mapcar
    (function cdr)
    (vl-remove-if
      (function
        (lambda (x)
          (zerop (logand (getvar "OSMODE") (car x)))
        ) ;_  lambda
      ) ;_  function
      '((1 . "_end")
        (2 . "_mid")
        (4 . "_cen")
        (8 . "_nod")
        (16 . "_qua")
        (32 . "_int")
        (64 . "_ins")
        (128 . "_per")
        (256 . "_tan")
        (512 . "_nea")
  ;(1024 . "_qui") ; Is not realized
        (2048 . "_app")
  ;(4096 . "_ext") ; Is not realized
  ;(8192 . "_par") ; Is not realized
       )
    ) ;_  substr
  ) ;_  mapcar
) ;_  defun


(defun osmode-grvecs-lst (/ -ASS ASS COL)
  ; Function create list
  ; for drawing icons osmode with the function grvecs
  ; by Evgeniy Elpanov
  ; (osmode-grvecs-lst)
  (setq
    col  (atoi (getenv "AutoSnapColor"))
    ass  (atof (getenv "AutoSnapSize"))
    -ass (- ass)
  ) ;_  setq
  (list
    (list
      "tracking"
      col
      (list (* -ass 0.2) 0.)
      (list (* ass 0.2) 0.)
      col
      (list 0. (* -ass 0.2))
      (list 0. (* ass 0.2))
    ) ;_  list
    (list
      "_end"
      col
      (list -ass -ass)
      (list -ass ass)
      col
      (list (1- -ass) (1- -ass))
      (list (1- -ass) (1+ ass))
      col
      (list -ass ass)
      (list ass ass)
      col
      (list (1- -ass) (1+ ass))
      (list (1+ ass) (1+ ass))
      col
      (list ass ass)
      (list ass -ass)
      col
      (list (1+ ass) (1+ ass))
      (list (1+ ass) (1- -ass))
      col
      (list ass -ass)
      (list -ass -ass)
      col
      (list (1+ ass) (1- -ass))
      (list (1- -ass) (1- -ass))
    ) ;_  list
    (list
      "_mid"
      col
      (list -ass -ass)
      (list 0. ass)
      col
      (list (1- -ass) (1- -ass))
      (list 0. (1+ ass))
      col
      (list 0. ass)
      (list ass -ass)
      col
      (list 0. (1+ ass))
      (list (1+ ass) (1- -ass))
      col
      (list ass -ass)
      (list -ass -ass)
      col
      (list (1+ ass) (1- -ass))
      (list (1- -ass) (1- -ass))
    ) ;_  list
    (list
      "_cen"
      7
      (list (* -ass 0.2) 0.)
      (list (* ass 0.2) 0.)
      7
      (list 0. (* -ass 0.2))
      (list 0. (* ass 0.2))
      col
      (list -ass 0.)
      (list (* -ass 0.86) (* ass 0.5))
      col
      (list (* -ass 0.86) (* ass 0.5))
      (list (* -ass 0.5) (* ass 0.86))
      col
      (list (* -ass 0.5) (* ass 0.86))
      (list 0. ass)
      col
      (list 0. ass)
      (list (* ass 0.5) (* ass 0.86))
      col
      (list (* ass 0.5) (* ass 0.86))
      (list (* ass 0.86) (* ass 0.5))
      col
      (list (* ass 0.86) (* ass 0.5))
      (list ass 0.)
      col
      (list ass 0.)
      (list (* ass 0.86) (* -ass 0.5))
      col
      (list (* ass 0.86) (* -ass 0.5))
      (list (* ass 0.5) (* -ass 0.86))
      col
      (list (* ass 0.5) (* -ass 0.86))
      (list 0. -ass)
      col
      (list 0. -ass)
      (list (* -ass 0.5) (* -ass 0.86))
      col
      (list (* -ass 0.5) (* -ass 0.86))
      (list (* -ass 0.86) (* -ass 0.5))
      col
      (list (* -ass 0.86) (* -ass 0.5))
      (list -ass 0.)
    ) ;_  list
    (list
      "_nod"
      col
      (list -ass -ass)
      (list ass ass)
      col
      (list -ass ass)
      (list ass -ass)
      col
      (list -ass 0.)
      (list (* -ass 0.86) (* ass 0.5))
      col
      (list (* -ass 0.86) (* ass 0.5))
      (list (* -ass 0.5) (* ass 0.86))
      col
      (list (* -ass 0.5) (* ass 0.86))
      (list 0. ass)
      col
      (list 0. ass)
      (list (* ass 0.5) (* ass 0.86))
      col
      (list (* ass 0.5) (* ass 0.86))
      (list (* ass 0.86) (* ass 0.5))
      col
      (list (* ass 0.86) (* ass 0.5))
      (list ass 0.)
      col
      (list ass 0.)
      (list (* ass 0.86) (* -ass 0.5))
      col
      (list (* ass 0.86) (* -ass 0.5))
      (list (* ass 0.5) (* -ass 0.86))
      col
      (list (* ass 0.5) (* -ass 0.86))
      (list 0. -ass)
      col
      (list 0. -ass)
      (list (* -ass 0.5) (* -ass 0.86))
      col
      (list (* -ass 0.5) (* -ass 0.86))
      (list (* -ass 0.86) (* -ass 0.5))
      col
      (list (* -ass 0.86) (* -ass 0.5))
      (list -ass 0.)
    ) ;_  list
    (list
      "_qua"
      col
      (list 0. -ass)
      (list -ass 0.)
      col
      (list 0. (1- -ass))
      (list (1- -ass) 0.)
      col
      (list -ass 0.)
      (list 0. ass)
      col
      (list (1- -ass) 0.)
      (list 0. (1+ ass))
      col
      (list 0. ass)
      (list ass 0.)
      col
      (list 0. (1+ ass))
      (list (1+ ass) 0.)
      col
      (list ass 0.)
      (list 0. -ass)
      col
      (list (1+ ass) 0.)
      (list 0. (1- -ass))
    ) ;_  list
    (list
      "_int"
      col
      (list -ass -ass)
      (list ass ass)
      col
      (list -ass (1+ -ass))
      (list ass (1+ ass))
      col
      (list (1+ -ass) -ass)
      (list (1+ ass) ass)
      col
      (list -ass ass)
      (list ass -ass)
      col
      (list -ass (1+ ass))
      (list ass (1+ -ass))
      col
      (list (1+ -ass) ass)
      (list (1+ ass) -ass)
    ) ;_  list
    (list
      "_ins"
      col
      (list (* -ass 0.1) (* -ass 0.1))
      (list -ass (* -ass 0.1))
      col
      (list -ass (* -ass 0.1))
      (list -ass ass)
      col
      (list -ass ass)
      (list (* ass 0.1) ass)
      col
      (list (* ass 0.1) ass)
      (list (* ass 0.1) (* ass 0.1))
      col
      (list (* ass 0.1) (* ass 0.1))
      (list ass (* ass 0.1))
      col
      (list ass (* ass 0.1))
      (list ass -ass)
      col
      (list ass -ass)
      (list (* -ass 0.1) -ass)
      col
      (list (* -ass 0.1) -ass)
      (list (* -ass 0.1) (* -ass 0.1))
      col
      (list (1- (* -ass 0.1)) (1- (* -ass 0.1)))
      (list (1- -ass) (1- (* -ass 0.1)))
      col
      (list (1- -ass) (1- (* -ass 0.1)))
      (list (1- -ass) (1+ ass))
      col
      (list (1- -ass) (1+ ass))
      (list (1+ (* ass 0.1)) (1+ ass))
      col
      (list (1+ (* ass 0.1)) (1+ ass))
      (list (1+ (* ass 0.1)) (1+ (* ass 0.1)))
      col
      (list (1+ (* ass 0.1)) (1+ (* ass 0.1)))
      (list (1+ ass) (1+ (* ass 0.1)))
      col
      (list (1+ ass) (1+ (* ass 0.1)))
      (list (1+ ass) (1- -ass))
      col
      (list (1+ ass) (1- -ass))
      (list (1- (* -ass 0.1)) (1- -ass))
      col
      (list (1- (* -ass 0.1)) (1- -ass))
      (list (1- (* -ass 0.1)) (1- (* -ass 0.1)))
    ) ;_  list
    (list
      "_tan"
      col
      (list -ass ass)
      (list ass ass)
      col
      (list (1- -ass) (1+ ass))
      (list (1+ ass) (1+ ass))
      col
      (list -ass 0.)
      (list (* -ass 0.86) (* ass 0.5))
      col
      (list (* -ass 0.86) (* ass 0.5))
      (list (* -ass 0.5) (* ass 0.86))
      col
      (list (* -ass 0.5) (* ass 0.86))
      (list 0. ass)
      col
      (list 0. ass)
      (list (* ass 0.5) (* ass 0.86))
      col
      (list (* ass 0.5) (* ass 0.86))
      (list (* ass 0.86) (* ass 0.5))
      col
      (list (* ass 0.86) (* ass 0.5))
      (list ass 0.)
      col
      (list ass 0.)
      (list (* ass 0.86) (* -ass 0.5))
      col
      (list (* ass 0.86) (* -ass 0.5))
      (list (* ass 0.5) (* -ass 0.86))
      col
      (list (* ass 0.5) (* -ass 0.86))
      (list 0. -ass)
      col
      (list 0. -ass)
      (list (* -ass 0.5) (* -ass 0.86))
      col
      (list (* -ass 0.5) (* -ass 0.86))
      (list (* -ass 0.86) (* -ass 0.5))
      col
      (list (* -ass 0.86) (* -ass 0.5))
      (list -ass 0.)
    ) ;_  list
    (list
      "_per"
      col
      (list -ass -ass)
      (list -ass ass)
      col
      (list (1- -ass) (1- -ass))
      (list (1- -ass) (1+ ass))
      col
      (list ass -ass)
      (list -ass -ass)
      col
      (list (1+ ass) (1- -ass))
      (list (1- -ass) (1- -ass))
      col
      (list -ass 0.)
      (list 0. 0.)
      col
      (list -ass -1.)
      (list 0. -1.)
      col
      (list 0. 0.)
      (list 0. -ass)
      col
      (list -1. 0.)
      (list -1. -ass)
    ) ;_  list
    (list
      "_nea"
      col
      (list -ass -ass)
      (list ass ass)
      col
      (list -ass ass)
      (list ass ass)
      col
      (list (1- -ass) (1+ ass))
      (list (1+ ass) (1+ ass))
      col
      (list -ass ass)
      (list ass -ass)
      col
      (list ass -ass)
      (list -ass -ass)
      col
      (list (1+ ass) (1- -ass))
      (list (1- -ass) (1- -ass))
    ) ;_  list
    (list
      "_app"
      col
      (list -ass -ass)
      (list ass ass)
      col
      (list ass -ass)
      (list -ass ass)

      col
      (list -ass -ass)
      (list -ass ass)
      col
      (list (1- -ass) (1- -ass))
      (list (1- -ass) (1+ ass))
      col
      (list -ass ass)
      (list ass ass)
      col
      (list (1- -ass) (1+ ass))
      (list (1+ ass) (1+ ass))
      col
      (list ass ass)
      (list ass -ass)
      col
      (list (1+ ass) (1+ ass))
      (list (1+ ass) (1- -ass))
      col
      (list ass -ass)
      (list -ass -ass)
      col
      (list (1+ ass) (1- -ass))
      (list (1- -ass) (1- -ass))
    ) ;_  list
    ;; Is not realized
    ;;    (list
    ;;    "_par"
    ;;      col
    ;;      (list (* -ass 0.8) -ass)
    ;;      (list ass (* ass 0.8))
    ;;      col
    ;;      (list -ass (* -ass 0.8))
    ;;      (list (* ass 0.8) ass)
    ;;    )

  ) ;_  list
) ;_  defun
(defun c:test (/ GR O OSM-LST OSMODE S TP)
  ; Example drawing icons osmode with
  ; Return point, for osmode
  ; by Evgeniy Elpanov
  ; (c:test)
  (setq osm-lst (osmode-grvecs-lst)
        osmode  (get_osmode)
  ) ;_  setq
  (while (or (= (car (setq gr (grread nil 5 0))) 5)
             (= (car gr) 11)
             (= (car gr) 25) ; For old version AutoCad
         ) ;_  or
    (if (or (= (car gr) 11)
            (= (car gr) 25)
        ) ;_  or
      (setq osmode (list (menu-pop500 gr)))
      (progn

        (if (setq
              o (vl-remove-if
                  (function null)
                  (mapcar
                    (function
                      (lambda (x / o)
                        (if (setq o (osnap (cadr gr) x))
                          (list (distance (cadr gr) o) o x (cadr gr))
                        ) ;_  if
                      ) ;_  lambda
                    ) ;_  function
                    osmode
                  ) ;_  mapcar
                ) ;_  vl-remove-if
            ) ;_  setq
          (setq
            o (cdar
                (vl-sort
                  o
                  (function
                    (lambda (a b)
                      (< (car a) (car b))
                    ) ;_  lambda
                  ) ;_  function
                ) ;_  vl-sort
              ) ;_  cdar
          ) ;_  setq
        ) ;_  if

        (setq s (/ (getvar "viewsize") (cadr (getvar "SCREENSIZE"))))
        (cond
          ((not o))
          ((WCMATCH (cadr o) "_end,_mid,_cen,_nod,_int,_ins")
           (setq tp (car o))
           (setvar "lastpoint" tp)
           (setq o (cons (trans (car o) 1 3) (cdr o)))
           (redraw)
           (grvecs
             (cdr (assoc "tracking" osm-lst))
             (list (list s 0. 0. (caar o))
                   (list 0. s 0. (cadar o))
                   (list 0. 0. s 0.)
                   '(0. 0. 0. 1.)
             ) ;_  list
           ) ;_  grvecs
           (grvecs
             (cdr (assoc (cadr o) osm-lst))
             (list (list s 0. 0. (caar o))
                   (list 0. s 0. (cadar o))
                   (list 0. 0. s 0.)
                   '(0. 0. 0. 1.)
             ) ;_  list
           ) ;_  grvecs
          )
          ((WCMATCH (cadr o) "_nea,_qua,_app")
           (setq o (cons (trans (car o) 1 3) (cdr o)))
           (redraw)
           (grvecs
             (cdr (assoc (cadr o) osm-lst))
             (list (list s 0. 0. (caar o))
                   (list 0. s 0. (cadar o))
                   (list 0. 0. s 0.)
                   '(0. 0. 0. 1.)
             ) ;_  list
           ) ;_  grvecs
          )
          ((and tp (not (equal tp (car o) 1e-8)))
           (redraw)
           (grdraw (car o) tp 7 1)
           (setq o (cons (trans (car o) 1 3) (cdr o)))
           (grvecs
             (cdr (assoc (cadr o) osm-lst))
             (list (list s 0. 0. (caar o))
                   (list 0. s 0. (cadar o))
                   (list 0. 0. s 0.)
                   '(0. 0. 0. 1.)
             ) ;_  list
           ) ;_  grvecs
          )
        ) ;_  cond
        (if tp
          (grvecs
            (cdr (assoc "tracking" osm-lst))
            (list (list s 0. 0. (car (trans tp 1 3)))
                  (list 0. s 0. (cadr (trans tp 1 3)))
                  (list 0. 0. s 0.)
                  '(0. 0. 0. 1.)
            ) ;_  list
          ) ;_  grvecs
        ) ;_  if
      ) ;_  progn
    ) ;_  if
  ) ;_  while
  (redraw)
  (if o
    (osnap (caddr o) (cadr o))
    (cadr gr)
  ) ;_  if
) ;_  defun

This example not finished, I ask to give advices and remarks!  :-)

Title: Re: Examples of usage GRREAD - let's share
Post by: MP on October 13, 2006, 12:01:34 PM
Wow, what's with all the George Bush references in osmode-grvecs-lst?

:-D

Kidding aside, I'll try to have a look this weekend, looks to be good stuff from the 30000 ft flyover Evgeniy!

:)
Title: Re: Examples of usage GRREAD - let's share
Post by: CAB on October 13, 2006, 01:29:31 PM
Tested in ACAD2004, very nice. :-)
Keep up the good work.
Will try to look at the code this weekend.

Thanks
Title: Re: Examples of usage GRREAD - let's share
Post by: CAB on October 13, 2006, 01:45:20 PM
Testing further I did get an error when selecting NONE in the Right Click menu.
Also would be nice if the F3 key toggled osmode On / Off.

I like it. :-)
Title: Re: Examples of usage GRREAD - let's share
Post by: ElpanovEvgeniy on October 13, 2006, 02:51:26 PM
Testing further I did get an error when selecting NONE in the Right Click menu.
Also would be nice if the F3 key toggled osmode On / Off.

I like it. :-)

Thanks!
Tomorrow I shall correct...

Today was at war with a shortcut menu added through VLA-ADD and not saved in the menu...
To create the new shortcut menu - it has not worked  :-(
Title: Re: Examples of usage GRREAD - let's share
Post by: Tramber on October 13, 2006, 03:45:56 PM
Desvidania Eugêne !

Groovy !

What a collection of great codes.
Title: Re: Examples of usage GRREAD - let's share
Post by: qjchen on October 13, 2006, 08:27:02 PM
Evgeniy, Very nice rountine, Thank you for share it.
Title: Re: Examples of usage GRREAD - let's share
Post by: ElpanovEvgeniy on October 14, 2006, 09:27:32 AM
Testing further I did get an error when selecting NONE in the Right Click menu.
Also would be nice if the F3 key toggled osmode On / Off.

I like it. :-)

Is corrected

Code: [Select]
(defun menu-pop500 (d / lst s)
  ; Choice function of OSNAP through the shortcut menu.
  ; Only, as an example.
  ; Is checked up in AutoCad 2004-2007 (En)
  ; by ElpanovEvgeniy
  ; (2006-10-11)
  ; (menu-pop500 (grread t 5))
  (setq
    lst (reverse
          (menu-index
            ((lambda (x) (list (1- (vla-get-count x)) x))
              (vla-item
                (vla-get-menus
                  (vla-item
                    (vla-get-menugroups
                      (vlax-get-acad-object)
                    ) ;_  vla-get-MenuGroups
                    "ACAD"
                  ) ;_  vla-item
                ) ;_  vla-get-Menus
                "&Object Snap Cursor Menu"
              ) ;_  vla-item
            )
          ) ;_  menu-index
        ) ;_  reverse
  ) ;_  setq
  (while (and
           (listp d)
           (or (= (car d) 5)
               (= (car d) 11)
               (= (car d) 12)
               (= (car d) 25) ; For old version AutoCad
           ) ;_  or
         ) ;_  and
    (cond
      ((= (car d) 25) (menucmd "POP500=*")) ; For old version AutoCad
      ((equal d '(11 0)) (menucmd "POP500=*"))
      ((= (car d) 11) (setq s (nth (- (cadr d) 500) lst)))
    ) ;_  cond
    (if s
      (setq d s)
      (setq d (grread t 5))
    ) ;_  if
  ) ;_  while
  (substr s 1 4)
) ;_  defun
(defun menu-index (l)
  ; Creation of the list of choices of choice of OSNAP
  ; Is checked up in AutoCad 2004-2007 (En)
  ; by ElpanovEvgeniy
  ; (2006-10-11)
                  ;|
(menu-index
 ((lambda (x) (list (1-(vla-get-count x)) x))
  (vla-item
   (vla-get-menus
    (vla-item
     (vla-get-menugroups
      (vlax-get-acad-object)
      ) ;_  vla-get-MenuGroups
     "ACAD"
     ) ;_  vla-item
    ) ;_  vla-get-Menus
   "&Object Snap Cursor Menu"
   ) ;_  vla-item
  )
 ) ;_  menu-index
 |;
  (if (not (minusp (car l)))
    (cond
      ((= (vla-get-type (vla-item (cadr l) (car l))) 0)
       (cons
         (vla-get-macro (vla-item (cadr l) (car l)))
         (menu-index (cons (1- (car l)) (cdr l)))
       ) ;_  cons
      )
      ((= (vla-get-type (vla-item (cadr l) (car l))) 1)
       (menu-index (cons (1- (car l)) (cdr l)))
      )
      ((= (vla-get-type (vla-item (cadr l) (car l))) 2)
       (append
         (menu-index
           ((lambda (x) (list (1- (vla-get-count x)) x))
             (vla-get-submenu (vla-item (cadr l) (car l)))
           ) ;_  menu-index
         ) ;_  menu-index
         (menu-index (cons (1- (car l)) (cdr l)))
       ) ;_  append
      )
    ) ;_  cond
  ) ;_  if
) ;_  defun
(defun get_osmode nil
  ; Function create list osmode macro
  ; for result (getvar "OSMODE")
  ; by Evgeniy Elpanov
  ; (get_osmode)
  (mapcar
    (function cdr)
    (vl-remove-if
      (function
        (lambda (x)
          (zerop (logand (getvar "OSMODE") (car x)))
        ) ;_  lambda
      ) ;_  function
      (append
        (if (< 0 (setq cur_mode (getvar "osmode")) 16384)
          '((1 . "_end")
            (2 . "_mid")
            (4 . "_cen")
            (8 . "_nod")
            (16 . "_qua")
            (32 . "_int")
  ;(4096 . "_ext") ; Is not realized
           )
        ) ;_  if
        (if (not (zerop (logand (getvar "autosnap") 16)))
          '((64 . "_ins")
            (128 . "_per")
            (256 . "_tan")
            (512 . "_nea")
  ;(1024 . "_qui") ; Is not realized
            (2048 . "_app")
  ;(8192 . "_par") ; Is not realized
           )
        ) ;_  if
      ) ;_  append
    ) ;_  substr
  ) ;_  mapcar
) ;_  defun


(defun osmode-grvecs-lst (/ -ASS ASS COL)
  ; Function create list
  ; for drawing icons osmode with the function grvecs
  ; by Evgeniy Elpanov
  ; (osmode-grvecs-lst)
  (setq
    col  (atoi (getenv "AutoSnapColor"))
    ass  (atof (getenv "AutoSnapSize"))
    -ass (- ass)
  ) ;_  setq
  (list
    (list
      "tracking"
      col
      (list (* -ass 0.2) 0.)
      (list (* ass 0.2) 0.)
      col
      (list 0. (* -ass 0.2))
      (list 0. (* ass 0.2))
    ) ;_  list
    (list
      "_end"
      col
      (list -ass -ass)
      (list -ass ass)
      col
      (list (1- -ass) (1- -ass))
      (list (1- -ass) (1+ ass))
      col
      (list -ass ass)
      (list ass ass)
      col
      (list (1- -ass) (1+ ass))
      (list (1+ ass) (1+ ass))
      col
      (list ass ass)
      (list ass -ass)
      col
      (list (1+ ass) (1+ ass))
      (list (1+ ass) (1- -ass))
      col
      (list ass -ass)
      (list -ass -ass)
      col
      (list (1+ ass) (1- -ass))
      (list (1- -ass) (1- -ass))
    ) ;_  list
    (list
      "_mid"
      col
      (list -ass -ass)
      (list 0. ass)
      col
      (list (1- -ass) (1- -ass))
      (list 0. (1+ ass))
      col
      (list 0. ass)
      (list ass -ass)
      col
      (list 0. (1+ ass))
      (list (1+ ass) (1- -ass))
      col
      (list ass -ass)
      (list -ass -ass)
      col
      (list (1+ ass) (1- -ass))
      (list (1- -ass) (1- -ass))
    ) ;_  list
    (list
      "_cen"
      7
      (list (* -ass 0.2) 0.)
      (list (* ass 0.2) 0.)
      7
      (list 0. (* -ass 0.2))
      (list 0. (* ass 0.2))
      col
      (list -ass 0.)
      (list (* -ass 0.86) (* ass 0.5))
      col
      (list (* -ass 0.86) (* ass 0.5))
      (list (* -ass 0.5) (* ass 0.86))
      col
      (list (* -ass 0.5) (* ass 0.86))
      (list 0. ass)
      col
      (list 0. ass)
      (list (* ass 0.5) (* ass 0.86))
      col
      (list (* ass 0.5) (* ass 0.86))
      (list (* ass 0.86) (* ass 0.5))
      col
      (list (* ass 0.86) (* ass 0.5))
      (list ass 0.)
      col
      (list ass 0.)
      (list (* ass 0.86) (* -ass 0.5))
      col
      (list (* ass 0.86) (* -ass 0.5))
      (list (* ass 0.5) (* -ass 0.86))
      col
      (list (* ass 0.5) (* -ass 0.86))
      (list 0. -ass)
      col
      (list 0. -ass)
      (list (* -ass 0.5) (* -ass 0.86))
      col
      (list (* -ass 0.5) (* -ass 0.86))
      (list (* -ass 0.86) (* -ass 0.5))
      col
      (list (* -ass 0.86) (* -ass 0.5))
      (list -ass 0.)
    ) ;_  list
    (list
      "_nod"
      col
      (list -ass -ass)
      (list ass ass)
      col
      (list -ass ass)
      (list ass -ass)
      col
      (list -ass 0.)
      (list (* -ass 0.86) (* ass 0.5))
      col
      (list (* -ass 0.86) (* ass 0.5))
      (list (* -ass 0.5) (* ass 0.86))
      col
      (list (* -ass 0.5) (* ass 0.86))
      (list 0. ass)
      col
      (list 0. ass)
      (list (* ass 0.5) (* ass 0.86))
      col
      (list (* ass 0.5) (* ass 0.86))
      (list (* ass 0.86) (* ass 0.5))
      col
      (list (* ass 0.86) (* ass 0.5))
      (list ass 0.)
      col
      (list ass 0.)
      (list (* ass 0.86) (* -ass 0.5))
      col
      (list (* ass 0.86) (* -ass 0.5))
      (list (* ass 0.5) (* -ass 0.86))
      col
      (list (* ass 0.5) (* -ass 0.86))
      (list 0. -ass)
      col
      (list 0. -ass)
      (list (* -ass 0.5) (* -ass 0.86))
      col
      (list (* -ass 0.5) (* -ass 0.86))
      (list (* -ass 0.86) (* -ass 0.5))
      col
      (list (* -ass 0.86) (* -ass 0.5))
      (list -ass 0.)
    ) ;_  list
    (list
      "_qua"
      col
      (list 0. -ass)
      (list -ass 0.)
      col
      (list 0. (1- -ass))
      (list (1- -ass) 0.)
      col
      (list -ass 0.)
      (list 0. ass)
      col
      (list (1- -ass) 0.)
      (list 0. (1+ ass))
      col
      (list 0. ass)
      (list ass 0.)
      col
      (list 0. (1+ ass))
      (list (1+ ass) 0.)
      col
      (list ass 0.)
      (list 0. -ass)
      col
      (list (1+ ass) 0.)
      (list 0. (1- -ass))
    ) ;_  list
    (list
      "_int"
      col
      (list -ass -ass)
      (list ass ass)
      col
      (list -ass (1+ -ass))
      (list ass (1+ ass))
      col
      (list (1+ -ass) -ass)
      (list (1+ ass) ass)
      col
      (list -ass ass)
      (list ass -ass)
      col
      (list -ass (1+ ass))
      (list ass (1+ -ass))
      col
      (list (1+ -ass) ass)
      (list (1+ ass) -ass)
    ) ;_  list
    (list
      "_ins"
      col
      (list (* -ass 0.1) (* -ass 0.1))
      (list -ass (* -ass 0.1))
      col
      (list -ass (* -ass 0.1))
      (list -ass ass)
      col
      (list -ass ass)
      (list (* ass 0.1) ass)
      col
      (list (* ass 0.1) ass)
      (list (* ass 0.1) (* ass 0.1))
      col
      (list (* ass 0.1) (* ass 0.1))
      (list ass (* ass 0.1))
      col
      (list ass (* ass 0.1))
      (list ass -ass)
      col
      (list ass -ass)
      (list (* -ass 0.1) -ass)
      col
      (list (* -ass 0.1) -ass)
      (list (* -ass 0.1) (* -ass 0.1))
      col
      (list (1- (* -ass 0.1)) (1- (* -ass 0.1)))
      (list (1- -ass) (1- (* -ass 0.1)))
      col
      (list (1- -ass) (1- (* -ass 0.1)))
      (list (1- -ass) (1+ ass))
      col
      (list (1- -ass) (1+ ass))
      (list (1+ (* ass 0.1)) (1+ ass))
      col
      (list (1+ (* ass 0.1)) (1+ ass))
      (list (1+ (* ass 0.1)) (1+ (* ass 0.1)))
      col
      (list (1+ (* ass 0.1)) (1+ (* ass 0.1)))
      (list (1+ ass) (1+ (* ass 0.1)))
      col
      (list (1+ ass) (1+ (* ass 0.1)))
      (list (1+ ass) (1- -ass))
      col
      (list (1+ ass) (1- -ass))
      (list (1- (* -ass 0.1)) (1- -ass))
      col
      (list (1- (* -ass 0.1)) (1- -ass))
      (list (1- (* -ass 0.1)) (1- (* -ass 0.1)))
    ) ;_  list
    (list
      "_tan"
      col
      (list -ass ass)
      (list ass ass)
      col
      (list (1- -ass) (1+ ass))
      (list (1+ ass) (1+ ass))
      col
      (list -ass 0.)
      (list (* -ass 0.86) (* ass 0.5))
      col
      (list (* -ass 0.86) (* ass 0.5))
      (list (* -ass 0.5) (* ass 0.86))
      col
      (list (* -ass 0.5) (* ass 0.86))
      (list 0. ass)
      col
      (list 0. ass)
      (list (* ass 0.5) (* ass 0.86))
      col
      (list (* ass 0.5) (* ass 0.86))
      (list (* ass 0.86) (* ass 0.5))
      col
      (list (* ass 0.86) (* ass 0.5))
      (list ass 0.)
      col
      (list ass 0.)
      (list (* ass 0.86) (* -ass 0.5))
      col
      (list (* ass 0.86) (* -ass 0.5))
      (list (* ass 0.5) (* -ass 0.86))
      col
      (list (* ass 0.5) (* -ass 0.86))
      (list 0. -ass)
      col
      (list 0. -ass)
      (list (* -ass 0.5) (* -ass 0.86))
      col
      (list (* -ass 0.5) (* -ass 0.86))
      (list (* -ass 0.86) (* -ass 0.5))
      col
      (list (* -ass 0.86) (* -ass 0.5))
      (list -ass 0.)
    ) ;_  list
    (list
      "_per"
      col
      (list -ass -ass)
      (list -ass ass)
      col
      (list (1- -ass) (1- -ass))
      (list (1- -ass) (1+ ass))
      col
      (list ass -ass)
      (list -ass -ass)
      col
      (list (1+ ass) (1- -ass))
      (list (1- -ass) (1- -ass))
      col
      (list -ass 0.)
      (list 0. 0.)
      col
      (list -ass -1.)
      (list 0. -1.)
      col
      (list 0. 0.)
      (list 0. -ass)
      col
      (list -1. 0.)
      (list -1. -ass)
    ) ;_  list
    (list
      "_nea"
      col
      (list -ass -ass)
      (list ass ass)
      col
      (list -ass ass)
      (list ass ass)
      col
      (list (1- -ass) (1+ ass))
      (list (1+ ass) (1+ ass))
      col
      (list -ass ass)
      (list ass -ass)
      col
      (list ass -ass)
      (list -ass -ass)
      col
      (list (1+ ass) (1- -ass))
      (list (1- -ass) (1- -ass))
    ) ;_  list
    (list
      "_app"
      col
      (list -ass -ass)
      (list ass ass)
      col
      (list ass -ass)
      (list -ass ass)

      col
      (list -ass -ass)
      (list -ass ass)
      col
      (list (1- -ass) (1- -ass))
      (list (1- -ass) (1+ ass))
      col
      (list -ass ass)
      (list ass ass)
      col
      (list (1- -ass) (1+ ass))
      (list (1+ ass) (1+ ass))
      col
      (list ass ass)
      (list ass -ass)
      col
      (list (1+ ass) (1+ ass))
      (list (1+ ass) (1- -ass))
      col
      (list ass -ass)
      (list -ass -ass)
      col
      (list (1+ ass) (1- -ass))
      (list (1- -ass) (1- -ass))
    ) ;_  list
    ;; Is not realized
    ;;    (list
    ;;    "_par"
    ;;      col
    ;;      (list (* -ass 0.8) -ass)
    ;;      (list ass (* ass 0.8))
    ;;      col
    ;;      (list -ass (* -ass 0.8))
    ;;      (list (* ass 0.8) ass)
    ;;    )

  ) ;_  list
) ;_  defun
(defun c:test (/ GR O OSM-LST OSMODE S TP)
  ; Example drawing icons osmode with
  ; Return point, for osmode
  ; by Evgeniy Elpanov
  ; (c:test)
  (setq osm-lst (osmode-grvecs-lst)
        osmode (get_osmode))
  (while (or (= (car (setq gr (grread nil 5 0))) 5)
               (= (car gr) 11)
               (= (car gr) 25) ; For old version AutoCad
           )
    (if (or (= (car gr) 11)
            (= (car gr) 25)
        ) ;_  or
      (setq osmode(list(menu-pop500 gr)))
      (progn

        (if (setq
              o (vl-remove-if
                  (function null)
                  (mapcar
                    (function
                      (lambda (x / o)
                        (if (setq o (osnap (cadr gr) x))
                          (list (distance (cadr gr) o) o x (cadr gr))
                        ) ;_  if
                      ) ;_  lambda
                    ) ;_  function
                    osmode
                  ) ;_  mapcar
                ) ;_  vl-remove-if
            ) ;_  setq
          (setq
            o (cdar
                (vl-sort
                  o
                  (function
                    (lambda (a b)
                      (< (car a) (car b))
                    ) ;_  lambda
                  ) ;_  function
                ) ;_  vl-sort
              ) ;_  cdar
          ) ;_  setq
        ) ;_  if

        (setq s (/ (getvar "viewsize") (cadr (getvar "SCREENSIZE"))))
        (cond
          ((not o))
          ((= (cadr o) "_non")(setq tp(redraw)))
          ((WCMATCH (cadr o) "_end,_mid,_cen,_nod,_int,_ins")
           (setq tp (car o))
           (setvar "lastpoint" tp)
           (setq o (cons (trans (car o) 1 3) (cdr o)))
           (redraw)
           (grvecs
             (cdr (assoc "tracking" osm-lst))
             (list (list s 0. 0. (caar o))
                   (list 0. s 0. (cadar o))
                   (list 0. 0. s 0.)
                   '(0. 0. 0. 1.)
             ) ;_  list
           ) ;_  grvecs
           (grvecs
             (cdr (assoc (cadr o) osm-lst))
             (list (list s 0. 0. (caar o))
                   (list 0. s 0. (cadar o))
                   (list 0. 0. s 0.)
                   '(0. 0. 0. 1.)
             ) ;_  list
           ) ;_  grvecs
          )
          ((WCMATCH (cadr o) "_nea,_qua,_app")
           (setq o (cons (trans (car o) 1 3) (cdr o)))
           (redraw)
           (grvecs
             (cdr (assoc (cadr o) osm-lst))
             (list (list s 0. 0. (caar o))
                   (list 0. s 0. (cadar o))
                   (list 0. 0. s 0.)
                   '(0. 0. 0. 1.)
             ) ;_  list
           ) ;_  grvecs
          )
          ((and tp (not (equal tp (car o) 1e-8)))
           (redraw)
           (grdraw (car o) tp 7 1)
           (setq o (cons (trans (car o) 1 3) (cdr o)))
           (grvecs
             (cdr (assoc (cadr o) osm-lst))
             (list (list s 0. 0. (caar o))
                   (list 0. s 0. (cadar o))
                   (list 0. 0. s 0.)
                   '(0. 0. 0. 1.)
             ) ;_  list
           ) ;_  grvecs
          )
        ) ;_  cond
        (if tp
          (grvecs
            (cdr (assoc "tracking" osm-lst))
            (list (list s 0. 0. (car (trans tp 1 3)))
                  (list 0. s 0. (cadr (trans tp 1 3)))
                  (list 0. 0. s 0.)
                  '(0. 0. 0. 1.)
            ) ;_  list
          ) ;_  grvecs
        ) ;_  if
      ) ;_  progn
    ) ;_  if
  ) ;_  while
  (redraw)
  (if o
    (osnap (caddr o) (cadr o))
    (cadr gr)
  ) ;_  if
) ;_  defun
Title: Re: Examples of usage GRREAD - let's share
Post by: ElpanovEvgeniy on October 14, 2006, 10:00:49 AM
Processing of keyboard input, I shall make later.
Now I ask the help in creation of the the shortcut menu.

So I create the new menu:

Code: [Select]
(if (vl-catch-all-error-p
      (setq me (VL-CATCH-ALL-APPLY
                 (function vla-item)
                 (list (setq m (vla-get-menus
                                 (vla-item
                                   (vla-get-menugroups
                                     (vlax-get-acad-object)
                                   ) ;_  vla-get-MenuGroups
                                   "ACAD"
                                 ) ;_  vla-item
                               ) ;_  vla-get-menus
                       ) ;_  setq
                       "new_menu_snap"
                 ) ;_  list
               ) ;_  VL-CATCH-ALL-APPLY
      ) ;_  setq
    ) ;_  vl-catch-all-error-p
  (setq me (vla-add m "new_menu_snap"))
) ;_  if
(foreach x '((0 "Endpoint" "_end")
             (1 "Midpoint" "_mid")
             (2 "Intersection" "_int")
             (3 "Apparent Intersection" "_app")
             (5 "Center" "_cen")
             (6 "Quadrant" "_qua")
             (7 "Tangent" "_tan")
             (9 "PERpendicular" "_per")
             (10 "Node" "_nod")
             (11 "Insertion" "_ins")
             (12 "Nearest" "_nea")
             (13 "None" "_non")
            )
  (vla-AddMenuItem me (car x) (cadr x) (caddr x))
) ;_  foreach
(foreach x '(4 8)
  (vla-AddSeparator me x)
) ;_  foreach

So, I try it to show.
Does not work!  :-(

Code: [Select]
(menucmd "p0=+ACAD.new_menu_snap")
(menucmd "p0=*")

Help me.
Title: Re: Examples of usage GRREAD - let's share
Post by: CAB on October 14, 2006, 10:02:57 AM
Here is one of my examples.

Code: [Select]
;; get entsel, ss or text
;;  CAB 07/30/2006


;;  return text or ss
(defun c:test (/ p1 ent ents result)
  ;; first get entsel, point or text
  (while
    (if (progn
          (prompt "\nSelect objects or enter Layer: ")
          (setq p1 (getkeyboard '(0 13) 0 "alpha" nil))
        )
      (cond
        ((= (type p1) "TEXT")
        nil ; exit
        )
        ((listp p1) ; point
         (if (setq ent (nentselp p1))
           (setq ents (list (car ent)))
         )
         nil
        )
      ) ; cond
    )
  ) ; while

  (while
      (cond
      ((null p1) nil) ; exit if nothing
        ((= (type p1) "TEXT")
         (setq result p1)
         nil ; we are done
        )
        ((listp p1) ; point, so ssget
          (prompt "\nSelect objects or enter Layer: ")
          (setq p2 (getkeyboard '(0 13) 0 "alpha" p1))
         nil
        )
      ) ; cond
  ) ; while

  result
)


;;; FUNCTION
;;;  Get keyboard input and return the keys as a string
;;;
;;; ARGUMENTS
;;; ExitList  is the list of ascii codes that will cause an exit
;;; #chars    number of characters allowed, 0= no limit
;;; $type     String type "real" "integer" "alpha"
;;; winPt     Window Point - Display a window
;;;
;;; USAGE
;;; 
;;;
;;; PLATFORMS
;;; 2000+
;;;
;;; AUTHOR
;;; Charles Alan Butler
;;; ab2draft@TampaBay.rr.com
;;;
;;; VERSION  1.0    Mar 07, 2005
(defun GetKeyboard (ExitList #chars $type winpt / buffer whitespace input space pointok)
  ;; ExitList  is the list of ascii codes that will cause an exit, 0 = point
  ;; #chars    number of characters allowed, 0= no limit
  ;; $type     String type real -real integer -integer alpha
  ;;           -real = allow minus sign

;;  Rectangel Get - Stig
;;  Honers the right to left solid line & left to right dashed line
;;  used in the normal selection method.
(defun getrect (pt / col method pi270 pi90 pt1 track)
  (setq pi270 (* 1.5 pi) pi90 (* 0.5 pi))
  (while (= 5 (car (setq track (grread T 5 1))))
    (redraw)
    (setq pt1 (cadr track))
    (cond ((>= pi270 (angle pt pt1) pi90)(setq col -256 method "_C"))
          ((setq col 256 method "_W")))
    (grvecs (list col pt (list (car pt) (cadr pt1))
                  col (list (car pt) (cadr pt1)) pt1
                  col pt1 (list (car pt1)(cadr pt))
                  col (list (car pt1)(cadr pt)) pt))
  )
  (redraw)
  ;; return point AND selection method
  (cond (pt1 (list pt1 method)))
)


 
  (setq  space        " "
          whitespace  (strcat "\r" (repeat 80 (setq space (strcat " " space))) "\r" )
  )

  (if (or (null ExitList)  (not (listp ExitList)))
    (setq exitList (list 13))
  )
  (and (vl-position 0 exitlist)
       (setq pointok t)
       )
  (if (or (null #chars)  (< #chars 0))
    (setq #chars 0) ; unlimited
  )
  (if (or (null $type)
           (not (member (setq $type (strcase $type))
                         '("REAL" "INTEGER" "ALPHA" "ASCII")
                )
           )
      )
    (setq $type "ALPHA")
  )

  (setq  buffer (if (eq $type "ASCII") (list) "" ) )


  (while
    (progn
      (if (eq $type "ASCII")
         (princ buffer)
         (princ (strcat " " buffer whitespace));(strcat action " " buffer whitespace))
      )
      (if (or
            (if (and pointok WinPt)
              (setq input (list 3 (getrect WinPt)))
              (and (= (car (setq input (grread 11 2))) 2) ; keyboard entry
                  (< 31 (setq input (cadr input)) 255) ; a key was pressed
              )
            )
            (and (listp input)
                 (= (car input) 3) ; point picked
                 pointok)
          )
         (cond
           ((not (print input)) ; print code number to command line
            ()
           )
           ((member input ExitLst)
            (setq buffer (cons buffer input))
            nil       ; exit loop
           )

           ((and (listp input)
                 (equal 3 (car input))) ; point picked
            (setq buffer nil
                  input (cadr input))
            nil       ; exit loop
           )

           ((equal 13 input) ; always exit on ENTER key
            (setq buffer (cons buffer input))
            nil       ; exit loop
           )

           ((equal bspace input) ; BS backspace <--<<
            (or (and (eq $type "ASCII")
                      (> (length buffer) 0)
                      (setq buffer (reverse (cdr (reverse buffer))))
                )
                (and (/= buffer "")
                      (setq buffer (substr buffer 1 (- (strlen buffer) 1)))
                )
                (setq action nil) ; exit
            )
           )          ; end BackSpace

           ((and  (wcmatch $type "*REAL")
                  (member input '(45 46 48 49 50 51 52 53 54 55 56 57))
            )
            (if (= input 45)
              (if (and (= $type "-REAL") (= buffer ""))
                (setq buffer "-")
              )
              (setq buffer (strcat buffer (chr input)))
            )
            (if (and (> #chars 0)
                      (= #chars (strlen buffer))
                )
              (setq input nil) ; exit
            )
           )          ;end REAL

           ((and  (wcmatch $type "*INTEGER")
                  (member input '(45 48 49 50 51 52 53 54 55 56 57))
            )
            (if (= input 45)
              (if (and (= $type "-INTEGER") (= buffer ""))
                (setq buffer "-")
              )
              (setq buffer (strcat buffer (chr input)))
            )
            (if (and (> #chars 0)
                      (= #chars (strlen buffer))
                )
              (setq input nil) ; exit
            )
           )          ; end INTEGET

           ((and (eq $type "ALPHA") (< 31 input 126))
            (setq buffer (strcat buffer (chr input)))
           )          ; end ALPHA

           ((eq $type "ASCII")
            (if buffer
              (setq buffer (cons buffer input))
              (setq buffer (list input))
            )
            (if (and (> #chars 0)
                      (= #chars (length buffer))
                )
              (setq input nil) ; exit
            )
           )          ; end ASCII

         )            ; end cond stmt
        t ; stay in loop
      )               ; endif
    )                 ; progn
  )                   ; end while

  ;;  return value ( string [exit key]) or [exit key]
  (if buffer
    (cons buffer input)
    input
  )

)   
Title: Re: Examples of usage GRREAD - let's share
Post by: qjchen on October 16, 2006, 08:39:15 PM
Evgeniy. I test your program here--(reply 12 of you)

when I type test, I only find that "nea" and "end" symbol can be show,but all the other -- such like "int" "cen" can't display. and when I click the right button of the mouse, the program exit with the following error: "error : Automation error.  parameter &Object Snap Cursor Menu (locate in Item) is invalid"

another thing: the subrountine---menu-pop500, do you mean in when I run "test", I can also use the "shift+right button" to call the quick osnap menu? but when I use the "shift+right button", it also exit with error :"error : Automation error.  parameter &Object Snap Cursor Menu (locate in Item) is invalid"

could you help me, thank you~
Title: Re: Examples of usage GRREAD - let's share
Post by: John Kaul (Se7en) on November 30, 2006, 11:52:23 AM
ElpanovEvgeniy,

(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)

That is amazing! I wish I could understand it because i could really use this technique in a program I'm writing.
Title: Re: Examples of usage GRREAD - let's share
Post by: Didge on December 06, 2006, 12:25:16 PM
Here's a simple use of GRREAD, this code will display an entity's Type & Layer on the command line as the crosshairs are moved across the screen. Changing the "assoc" code however will allow just about any property to be displayed.

Ironically, this routine was originally called INSPECT, but having just typed that at the command line I've just noticed an existing acad command by the same name that does exactly the same thing (albeit better) as this one. Thats my new piece of knowledge gathered for today  :-)

I did have a small maze type game that utilised this same function, the user had to navigate around a maze using the mouse against the clock without crashing into the walls and certain objects etc.

I've renamed the variables to something a little more informative.

Code: [Select]
;*****************************************************************************
; INSPECTOR - Command to Inspect Objects by Moving the Crosshairs Over Them. *
; =========                                                                  *
;             Didge, 2006.                                                   *
;*****************************************************************************
(defun C:INSPECTOR (/ INPUT INPUT_COORD ENTITY_FOUND ENTITY_NAME ENTITY_LIST ENTITY_TYPE ENTITY_LAYER)
  (prompt "\nMove Crosshairs To Inspect Objects.")
  (while (and (setq INPUT (grread T)) (= (car INPUT) 5))
      (setq INPUT_COORD (cadr INPUT))
      (setq ENTITY_FOUND (ssget INPUT_COORD))
      (if ENTITY_FOUND
         (progn
            (setq ENTITY_LIST (entget (ssname ENTITY_FOUND 0)))
            (setq ENTITY_TYPE (cdr (assoc 0 ENTITY_LIST)))
            (setq ENTITY_LAYER (cdr (assoc 8 ENTITY_LIST)))
            (prompt (strcat "\rObject: " ENTITY_TYPE "    Layer: " ENTITY_LAYER "                     "))
         )
      )
  )
  (princ)
)
Title: Re: Examples of usage GRREAD - let's share
Post by: GDF on January 04, 2008, 02:28:13 PM
Didge, great routine.

I like this example. I was wondering how you would modify the routine to make it active at anytime by way of the command line. I can not get it to work unless I call the command within the lisp an drag it in the drawing.

Gary

Here's a simple use of GRREAD, this code will display an entity's Type & Layer on the command line as the crosshairs are moved across the screen. Changing the "assoc" code however will allow just about any property to be displayed.

Ironically, this routine was originally called INSPECT, but having just typed that at the command line I've just noticed an existing acad command by the same name that does exactly the same thing (albeit better) as this one. Thats my new piece of knowledge gathered for today  :-)

I did have a small maze type game that utilised this same function, the user had to navigate around a maze using the mouse against the clock without crashing into the walls and certain objects etc.

I've renamed the variables to something a little more informative.

Code: [Select]
;*****************************************************************************
; INSPECTOR - Command to Inspect Objects by Moving the Crosshairs Over Them. *
; =========                                                                  *
;             Didge, 2006.                                                   *
;*****************************************************************************
(defun C:INSPECTOR (/ INPUT INPUT_COORD ENTITY_FOUND ENTITY_NAME ENTITY_LIST ENTITY_TYPE ENTITY_LAYER)
  (prompt "\nMove Crosshairs To Inspect Objects.")
  (while (and (setq INPUT (grread T)) (= (car INPUT) 5))
      (setq INPUT_COORD (cadr INPUT))
      (setq ENTITY_FOUND (ssget INPUT_COORD))
      (if ENTITY_FOUND
         (progn
            (setq ENTITY_LIST (entget (ssname ENTITY_FOUND 0)))
            (setq ENTITY_TYPE (cdr (assoc 0 ENTITY_LIST)))
            (setq ENTITY_LAYER (cdr (assoc 8 ENTITY_LIST)))
            (prompt (strcat "\rObject: " ENTITY_TYPE "    Layer: " ENTITY_LAYER "                     "))
         )
      )
  )
  (princ)
)
Title: Re: Examples of usage GRREAD - let's share
Post by: gile on January 05, 2008, 03:12:07 PM
Hi,

Here're my two cents, nothing really new, but a way to get keyboard inputs.

In this example, the user is prompt to select an entity and the start point of the perpendicular to the entity.

The line length can be specified with the pointer or on the keyboard.

PS: I have similar routines for the bisector of two segments or the mediator of two points which use the same way.

Code: [Select]
(defun c:perp (/ ent dep deriv ang loop per gr pe str)
  (vl-load-com)
  (if (and
(setq ent (car (entsel)))
(setq dep (trans (getpoint "\nStart point of the perpendicular line:") 1 0))
(not (vl-catch-all-error-p
       (setq deriv (vl-catch-all-apply
     'vlax-curve-getFirstDeriv
     (list ent
   (vlax-curve-getParamAtPoint ent dep)
     )
   )
       )
     )
)
      )
    (progn
      (entmake (list '(0 . "LINE")
     (cons 10 dep)
     (cons 11 dep)
       )
      )
      (setq per (entlast)
    ang (angle '(0 0 0) deriv)
    loop T

      )
      (princ "\nSpecify line length: ")
      (while (and (setq gr (grread T 12 0)) (/= (car gr) 3) loop)
(cond
  ((= (car gr) 5)
   (setq
     pe (polar
  dep
  (if (minusp (sin (- (angle dep (cadr gr)) ang)))
    (- ang (/ pi 2))
    (+ ang (/ pi 2))
  )
  (distance dep (cadr gr))
)
   )
   (entmod
     (subst (cons 11 (trans pe 1 0))
    (assoc 11 (entget per))
    (entget per)
     )
   )
   (grtext -1 (rtos (distance dep (cadr gr))))
  )
  ((member (cadr gr) '(13 32))
   (if (and str (numberp (read str)))
     (progn
       (entmod
(subst
   (cons
     11
     (trans (polar dep (angle dep pe) (distof str)) 1 0)
   )
   (assoc 11 (entget per))
   (entget per)
)
       )
       (setq loop nil)
     )
     (progn
       (princ
"\nNeeds a valid number  or a screen pointing.
                 \nSpecify line length: "
       )
       (setq str "")
     )
   )
  )
  (T
   (if (= (cadr gr) 8)
     (or
       (and str
    (/= str "")
    (setq str (substr str 1 (1- (strlen str))))
    (princ (chr 8))
    (princ (chr 32))
       )
       (setq str nil)
     )
     (or
       (and str (setq str (strcat str (chr (cadr gr)))))
       (setq str (chr (cadr gr)))
     )
   )
   (and str (princ (chr (cadr gr))))
  )
)
      )
    )
  )
  (princ)
)
Title: Re: Examples of usage GRREAD - let's share
Post by: Pepe on January 08, 2008, 06:02:00 PM
Hi, everybody!

Evgeniy Elpanov linked me to this interesting thread from my post

http://www.theswamp.org/index.php?topic=20737.0

My post was about the problem of how identify which shortcutmenu is the active using autolisp,
as the number of its items are needed to define which GRREAD code 11 represents the 1st item
of POP1, and so, be able to extract information of any menu item in a GRREAD loop.

This comes because GRREAD code 11 is organized as follows:

1º Items that belong to the active shortcut menu
2º Items that belong to popmenus on menu bar
3º Items that belong to images menus (those slides we used a long time ago...)
4º Items that belong to toolbars
5º Rest of the stuff (p.e. workspaces, etc...)

Both in shortcutmenus and popmenus you must not count separators, head of submenus, items
without macro, and macros which include 'syswindows' commands; in toolbars you must count
separators as items; the way to get the Images menus is reading .mns files for v2005 an lower
versions, and via activex and XML for v.2006 and upper versions.

The only way I found to avoid the problem caused by the imposibility of identifying which is the active
shortcutmenu, is reload the menu(s) in order to fit POP 0 (known) as the active shortcutmenu again.
This solution is slow and noisy, as I can't avoid the echo of the menu load.

The target of this routine is only to show the contents of the menu item selected by clicking on it.
It only works on pop menu bar, toolbars and shift+mouserightclick shortcutmenu items.

I've tested it on v.2005 and works properly but, although it should work properly too on v.2006 and upper
versions, sometimes crashes on reloading menu after calling the routine from the shortcutmenu after using
it. Don't ask me why  :x , maybe activex' fault. So, in this case, be careful as pop menu bar will spoil.


I'm not as tidy as many people here, so the code is not quoted (remarked?), and I've translated messages
into my foreign English  (oh, my God! :|)

Enjoy it!

(Oops! I posted yesterday a wrong code, now it's the right one.)

Code: [Select]
(defun tsterr (s)
  (if (= s "Function cancelled")
    (princ "\n*Cancelled*")
    (princ s)
    )
  (mapcar '(lambda (x) (if (numberp x) (princ) (vlax-release-object x))) ty)
  (setq *error* oe)
  (princ)
  )

(defun okd_k (a / okd_lm)
  (mapcar
    '(lambda (x)
       (cond ((= x 3) (setq okd_lm (append okd_lm (list 94 67))))
     ((= x 16) (setq okd_lm (append okd_lm (list 94 80))))
     ((= x 10) (setq okd_lm (append okd_lm (list 59))))
     (T (setq okd_lm (append okd_lm (list x))))
     )
       )
    a)
  (vl-list->string okd_lm)
  )
     
(defun lod_m (a / loc_ac loc_cn loc_lb loc_lg loc_lm loc_lp loc_mb loc_mg loc_nm loc_tt)
  (setq loc_mg (vla-get-menugroups a)
loc_mb (vla-get-menubar a)
loc_cn 0
)
  (vlax-for it loc_mg
    (setq loc_lm (cons (vla-get-menus it) loc_lm)
  loc_nm (cons (vla-get-menufilename it) loc_nm)
  loc_tt (cons (abs (1- (vla-get-type it))) loc_tt))
    )
  (mapcar
    '(lambda (x)
       (vlax-for it x
(if (= :vlax-true (vla-get-onmenubar it))
   (setq loc_lg (cons (vla-get-name it) loc_lg)
loc_lp (append (list (vl-position x loc_lm)) loc_lp))
   )
)
       )
    loc_lm
    )
  (vlax-for it loc_mb
    (setq loc_lb (cons (cons loc_cn (vla-get-name it)) loc_lb)
  loc_cn (1+ loc_cn))
    )
  (vlax-release-object loc_mb)
  (gc)
  (setq loc_nm (reverse loc_nm) loc_tt (reverse loc_tt))
  (vlax-map-collection loc_mg 'vla-unload)
  (mapcar '(lambda (x y) (vla-load loc_mg x y)) loc_nm loc_tt)
  (vlax-release-object loc_mg)
  (gc)
  (setq loc_mg (vla-get-menugroups a)
loc_mb (vla-get-menubar a))
  (vlax-for it loc_mg (setq loc_lm (cons (vla-get-menus it) loc_lm)))
  (mapcar
    '(lambda (x / mx pm)
       (setq pm (vla-item (setq mx (nth (nth (vl-position (cdr x) loc_lg) loc_lp) loc_lm)) (cdr x)))
       (if (= :vlax-false (vla-get-onmenubar pm))
(vla-insertmenuinmenubar mx (cdr x) (car x))
)
       )
    loc_lb)
  (list loc_mb loc_mg)
  )

(defun prn_a (a b / nm pp pr ps)
  (setq pr (vla-get-parent a)
nm (vla-get-name pr)
)
  (if (= nm "")
    (progn
      (setq ps (vla-get-parent (vla-get-parent pr)))
      (if (= :vlax-true (vla-get-shortcutmenu ps))
(setq pp
       (strcat "SHORTCUT MENU:"
       "\n->NAME:\t"
       (vla-get-namenomnemonic ps)
       "\n[-------]"
       )
      )
(setq pp
       (strcat "POP MENU ON BAR:"
       "\n->NAME:\t"
       (vla-get-namenomnemonic ps)
       "\n[-------]"
       )
      )
)
      (setq pp
     (strcat pp
     "\nSUBMENU:"
     "\n->NAME:\t"
     (vl-list->string
(vl-remove 38
   (vl-string->list
     (vla-get-caption
       (vla-get-parent pr)
       )
     )
   )
)
     "\n[-------]\nPOP MENU ITEM:\nGRREAD Nº:\t"
     (itoa b)
     "\n->CAPTION:\t"
     (vl-list->string
(vl-remove 38
   (vl-string->list
     (vla-get-caption a)
     )
   )
)
     "\n->HELPSTRING:\t"
     (vla-get-helpstring a)
     "\n->MACRO:\t"
     (okd_k (vl-string->list (vla-get-macro a)))
     "\n->TAGSTRING:\t"
     (vla-get-tagstring a)
     )
    )
      )
    (progn
      (if (= :vlax-true (vla-get-shortcutmenu pr))
(setq pp
       (strcat "SHORTCUT MENU:"
       "\n->NAME:\t"
       (vla-get-namenomnemonic pr)
       "\n[-------]"
       )
      )
(setq pp
       (strcat "POP MENU ON BAR:"
       "\n->NAME:\t"
       (vla-get-namenomnemonic pr)
       "\n[-------]"
       )
      )
)
      (setq pp
     (strcat pp
        "\nPOP MENU ITEM:\nGRREAD Nº:\t"
   (itoa b)
     "\n->CAPTION:\t"
     (vl-list->string
(vl-remove 38
   (vl-string->list
     (vla-get-caption a)
     )
   )
)
     "\n->HELPSTRING:\t"
     (vla-get-helpstring a)
     "\n->MACRO:\t"
     (okd_k (vl-string->list (vla-get-macro a)))
     "\n->TAGSTRING:\t"
     (vla-get-tagstring a)
     )
    )
      )
    )
  (alert pp)
  )

(defun prn_b (a b / nm pp pr)
  (setq pr (vla-get-parent a)
nm (vla-get-name pr)
pp (strcat "TOOL BAR:"
   "\n->NAM:\t"
   nm    
   "\n[-------]"
   "\nTOOL BAR ITEM:\nGRREAD Nº:\t"
   (itoa b)
   "\n->NAME:\t\t"
   (vla-get-name a)
   "\n->HELPSTRING:\t"
   (vla-get-helpstring a)
   "\n->MACRO:\t"
   (okd_k (vl-string->list (vla-get-macro a)))
   "\n->TAGSTRING:\t"
   (vla-get-tagstring a)
   )
)
  (alert pp)
  )
     
(defun fna_j (a / ax cn ll)
  (setq ax (vlax-invoke-method a 'getelementsbytagname "ImageMenu"))
  (if (zerop (vlax-get-property ax 'length))
    (vlax-get-property ax 'item 0)
    (progn
      (setq cn 0)
      (while (> (vlax-get-property ax 'length) cn)
(setq ll (append ll (list (vlax-get-property ax 'item cn))) cn (1+ cn))
)
      ll
      )
    )
  )

(defun fnb_j (a / ax)
  (setq ax (vlax-get-property (vlax-invoke-method a 'getelementsbytagname "Alias") 'item 0))
  (if (null ax)
    (setq lb (append lb (list a)))
    (setq la (append la (list a)))
    )
  )

(defun fnc_j (a / ax cn ln lo oa)
  (if (= :vlax-true (vlax-invoke-method a 'haschildnodes))
    (progn
      (setq cn 0
    ax (vlax-get-property a 'childnodes)
    ln (vlax-get-property ax 'length))
      (while (> ln cn)
(setq oa (vlax-get-property ax 'item cn) cn (1+ cn))
(if (= (vlax-get-property oa 'nodename) "ImageMenuItem")
  (setq lo (append lo (list oa)))
   )

)
      )
    )
  lo
  )

(defun get_j (a / dc la lb lc)
  (vl-load-com)
  (vlax-invoke-method
    (setq dc (vlax-create-object "MSXML.DOMDocument"))
    'load
    a
    )
  (mapcar 'fnb_j (fna_j dc))
  (setq lc (mapcar 'length (mapcar 'fnc_j la)))
  (mapcar 'vlax-release-object la)
  (mapcar 'vlax-release-object lb)
  (vlax-release-object dc)
  (gc)
  lc
  )

(defun get_aa (a / cn ct it lx ty)
  (setq ct (vla-get-count a) cn 0)
  (repeat ct
    (setq it (vlax-invoke-method a 'item cn)
  ty (vla-get-type it)
  cn (1+ cn))
    (if (zerop ty)
      (setq lx (append lx (list it)))
      (if (= ty 2)
(setq lx (append lx (get_aa (vla-get-submenu it))))
)
      )
    )
  (vl-remove-if
    (function
      (lambda (x)
(or (= (vla-get-macro x) "")
    (wcmatch (vla-get-macro x) "*quit*")
    (wcmatch (vla-get-macro x) "*closeall*")
    (wcmatch (vla-get-macro x) "*syswindows*")
    )
)
      )
    lx)
  )

(defun get_ab (a / cn ct it lx ty)
  (setq ct (vla-get-count a) cn 0)
  (repeat ct
    (setq it (vlax-invoke-method a 'item cn)
  ty (vla-get-type it)
  cn (1+ cn))
    (if (zerop ty)
      (setq lx (append lx (list it)))
      (if (= ty 2)
(setq lx (append lx (get_ab (vla-get-submenu it))))
)
      )
    )
  (vl-remove-if
    (function
      (lambda (x)
(or (= (vla-get-macro x) "")
    (wcmatch (vla-get-macro x) "*_closeall*")
    (wcmatch (vla-get-macro x) "*syswindows*")
    )
)
      )
    lx)
  )

(defun get_b (a / it ll)
  (vlax-for it a (setq ll (append ll (list it))))
  ll
  )

(defun get_i (a / ax fi fs li lx)
  (if (findfile (setq fs (vl-string-subst ".mns" ".mnc" a)))
    (progn
      (setq ax 0
    fi (open fs "r"))
      (while (/= (read-line fi) "***IMAGE") (princ))
      (while (/= (substr (setq li (read-line fi)) 1 3) "***")
(cond ((wcmatch li "`*`**")
       (if (zerop ax)
(princ)
(setq lx (append lx (list ax)) ax 0))
       )
      ((wcmatch li "*(*,*)*") (setq ax (1+ ax)))
      (T (princ))
      )
)
      (close fi)
      (setq lx (append lx (list ax)))
      )
    (progn
      (setq fi (reverse (vl-string->list fs)))
      (while (/= (car fi) 92)
(setq lx (cons (car fi) lx) fi (cdr fi))
)
      (alert (strcat "Couldn't find source menu for \"" (vl-list->string lx) "\"\nSorry, I can't follow"))
      (exit)
      )
    )
  )

(defun get_s (a / it ll)
  (vlax-for it a (setq ll (append ll (list it))))
  (vl-remove-if '(lambda (x) (= :vlax-false (vla-get-shortcutmenu x))) ll)
  )

(defun get_t (a / it ll)
  (vlax-for it a (setq ll (append ll (list it))))
  )

(defun get_u (a / it ll)
  (vlax-for it a (setq ll (append ll (list it))))
  (vl-remove-if '(lambda (x)
   (or
     (= :vlax-true (vla-get-shortcutmenu x))
     (= :vlax-true (vla-get-onmenubar x)))
   )
    ll)
  )

(defun rng_a (a b / ax ll lm)
  (setq lm a
ll (list (list (1+ b) (+ b (car lm))))
lm (cdr lm))
  (while lm
    (setq ax (cadr (last ll))
  ll (append ll (list (list (1+ ax) (+ (car lm) ax))))
  lm (cdr lm))
    )
  ll
  )

(defun scm_a (a b c / ax cp gt nt)
  (if (member a '(1000 2000 3000))
    (progn
      (grread T 2)
      (menucmd "P0=POP0")
      (menucmd "P0=*")
      )
    (setq ax (if (zerop a) nil a))
    )
  (if ax
    (progn
      (setq nt
     (vl-position
       'T
       (mapcar
'(lambda (x)
    (if
      (and
(>= ax (car x))
(<= ax (cadr x))
)
      (numberp (setq gt (- ax (car x))))
      nil)
    )
b)
       )
    )
      (if
(vl-catch-all-error-p
  (vl-catch-all-apply 'vla-get-onmenubar (list (nth nt c))))
(prn_b (nth gt (get_b (nth nt c))) a)
(prn_a
  (nth gt
       (if (< (atof (substr (getvar "ACADVER") 1 4)) 16.2)
(get_aa (nth nt c))
(get_ab (nth nt c))
)
       )
  a)
)
      )
    )
  )

(defun tst_g (/ aa ab ac ad ae ao it lg li lp ls lt lu lx ly mb mg)
  (setq mg (vla-get-menugroups (vlax-get-acad-object))
lg (reverse (vlax-for it mg (setq lg (cons it lg)))))
  (mapcar '(lambda (x) (setq ls (append (get_s x) ls))) (mapcar 'vla-get-menus lg))
  (if (> (length ls) 1)
    (progn
      (mapcar 'vlax-release-object ls)
      (mapcar 'vlax-release-object lg)
      (vlax-release-object mg)
      (gc)
      (setq ao (lod_m (vlax-get-acad-object))
    mb (car ao)
    mg (cadr ao)
    lg nil
    ls nil)
      (vlax-for it mg (setq lg (append lg (list it))))
      (vlax-for it mb (setq lp (append lp (list it))))
      (mapcar '(lambda (x) (setq ls (append ls (get_s x)))) (mapcar 'vla-get-menus lg))
      (terpri)
      (terpri)
      )
    (progn
      (setq mb (vla-get-menubar (vlax-get-acad-object)))
      (vlax-for it mb (setq lp (append lp (list it))))
      )
    )
  (if (< (atof (substr (getvar "ACADVER") 1 4)) 16.2)
    (progn
      (setq li (apply 'append (mapcar '(lambda (x) (get_i (vla-get-menufilename x))) lg)))
      (mapcar '(lambda (x) (setq lt (append lt (get_t x)))) (mapcar 'vla-get-toolbars lg))
      (mapcar '(lambda (x) (setq lu (append lu (get_u x)))) (mapcar 'vla-get-menus lg))
      (setq aa (rng_a (mapcar (function (lambda (x) (length (get_aa x)))) ls) 499)
    ab (rng_a (mapcar (function (lambda (x) (length (get_aa x)))) lp) (cadr (last aa)))
    ac (rng_a li (cadr (last ab)))
    ad (rng_a (mapcar (function (lambda (x) (length (get_b x)))) lt) (cadr (last ac)))
    ae (rng_a (mapcar (function (lambda (x) (length (get_aa x)))) lu) (cadr (last ad)))
    lx (append aa ab ac ad ae)
    ly (append ls lp li lt lu)
    )
      )
    (progn
      (setq li (apply 'append (mapcar '(lambda (x) (get_j (vla-get-menufilename x))) lg)))
      (mapcar '(lambda (x) (setq lt (append lt (get_t x)))) (mapcar 'vla-get-toolbars lg))
      (mapcar '(lambda (x) (setq lu (append lu (get_u x)))) (mapcar 'vla-get-menus lg))
      (setq aa (rng_a (mapcar (function (lambda (x) (length (get_ab x)))) ls) 499)
    ab (rng_a (mapcar (function (lambda (x) (length (get_ab x)))) lp) (cadr (last aa)))
    ac (rng_a li (cadr (last ab)))
    ad (rng_a (mapcar (function (lambda (x) (length (get_b x)))) lt) (cadr (last ac)))
    ae (rng_a (mapcar (function (lambda (x) (length (get_ab x)))) lu) (cadr (last ad)))
    lx (append aa ab ac ad ae)
    ly (append ls lp li lt lu)
    )
      )
    ) 
  (vlax-release-object mb)
  (vlax-release-object mg)
  (gc)
  (list lx ly)
  )

(defun C:TESTG (/ gr oe ts tx ty op sc)
  (vl-load-com)
  (if
    (zerop (getvar "SHORTCUTMENU"))
    (progn
      (grread t 2)
      (setq sc 12)
      )
    (setq sc 25)
    )
  (setq ts (tst_g)
tx (car ts)
ty (cadr ts)
oe *error*
*error* tsterr
)
  (while (null op)
    (setq gr (grread T 13))
    (if (/= (car gr) 5) (setq pl (cons gr pl)))
    (princ "\rCommand: Menu items evaluation: ")
    (if (= (car gr) 11)
      (progn
(scm_a (cadr gr) tx ty)
(princ "...Done!")
(terpri)
)
      (if (or (= (car gr) sc) (and (= (car gr) 2) (= (cadr gr) 13)))
(progn
  (princ "...I'm quitting")
  (setq op T)
  )
)
      )   
    )
  (mapcar '(lambda (x) (if (numberp x) (princ) (vlax-release-object x))) ty)
  (gc)
  (princ)
  )

(princ "\nType TESTG to begin...")
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on December 18, 2009, 07:53:30 PM
As posted  (http://www.cadtutor.net/forum/showthread.php?t=43191)over at CADTutor, thought I'd share it here too:

Code: [Select]
(defun c:cam4 (/ *ERROR* STRBRK FOO1 FOO2

                 ANG BLG C1 CEN CEN2 CODE DATA DELTA DIS
                 EN GR IANG LEN LST POLY RAD RAD1 RAD2 TAN)
  ;; by Lee McDonnell (Lee Mac)  ~  19.12.2009
 
  (vl-load-com)
 

  (defun *error* (msg)
    (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
        (princ (strcat "\n** Error: " msg " **")))
    (princ))
 

  (defun StrBrk (str chrc / pos lst)
   
    (while (setq pos (vl-string-position chrc str))
      (setq lst (cons (substr str 1 pos) lst)
            str (substr str (+ pos 2))))
   
    (reverse (cons str lst)))
 

  (if (setq cen (getpoint "\nPick Center of First Radius: "))
    (progn
      (setq poly (entmakex
                   (list
                     (cons 0 "LWPOLYLINE")
                     (cons 100 "AcDbEntity")
                     (cons 100 "AcDbPolyline")
                     (cons 90 2)
                     (cons 70 1)
                     (cons 10 cen)
                     (cons 10 (polar cen 0 1.))))

            en   (reverse
                   (vl-member-if
                     (function
                       (lambda (x)
                         (= 39 (car x))))
                     
                     (reverse (entget poly)))))
     

      (defun foo1 nil (setq str "")
        (while
          (progn
            (setq gr (grread 't 15 0) code (car gr) data (cadr gr))
           
            (cond (  (and (= 5 code) (listp data))
                   
                     (setq rad2 (distance cen2 data) delta (- rad rad2))
                   
                     (if (< (abs delta) len)
                       (progn
                       
                         (setq tan  (sqrt (- (* len len) (* delta delta))) iAng (atan tan delta)
                             
                               blg1 (/ (sin (* 0.5 (- pi iAng))) (cos (* 0.5 (- pi iAng))))
                             
                               blg2 (/ (sin (* 0.5 iAng))        (cos (* 0.5 iAng))))
                       
                         (entmod
                           (append en
                             (list
                               (cons 10 (polar cen  (+ ang iAng) rad))
                               (cons 42 blg1)
                               (cons 10 (polar cen  (- ang iAng) rad))
                                   
                               (cons 10 (polar cen2 (- ang iAng) rad2))
                               (cons 42 blg2)
                               (cons 10 (polar cen2 (+ ang iAng) rad2)))))) t))
                 
                  (  (and (= 3 code) (listp data))

                     (setq rad2 (distance cen2 data) delta (- rad rad2))
                   
                     (if (< (abs delta) len)
                       (progn
                       
                         (setq tan  (sqrt (- (* len len) (* delta delta))) iAng (atan tan delta)
                             
                               blg1 (/ (sin (* 0.5 (- pi iAng))) (cos (* 0.5 (- pi iAng))))
                             
                               blg2 (/ (sin (* 0.5 iAng))        (cos (* 0.5 iAng))))
                       
                         (entmod
                           (append en
                             (list
                               (cons 10 (polar cen  (+ ang iAng) rad))
                               (cons 42 blg1)
                               (cons 10 (polar cen  (- ang iAng) rad))
                                   
                               (cons 10 (polar cen2 (- ang iAng) rad2))
                               (cons 42 blg2)
                               (cons 10 (polar cen2 (+ ang iAng) rad2))))) nil)))

                  (  (= 2 code)

                     (cond (  (or (= data 46) (< 47 data 58))
                         
                              (setq str (strcat str (princ (chr data)))))

                           (  (and (< 0 (strlen str)) (= 8 data))

                              (setq str (substr str 1 (1- (strlen str))))
                              (princ (vl-list->string '(8 32 8))))

                           (  (vl-position data '(32 13))

                              (cond (  (zerop (strlen str)) t)

                                    (  (and (setq tmp (distof str)) (not (zerop tmp)))
                                   
                                       (setq data (polar cen2 0 tmp) rad2 (distance cen2 data)

                                             delta (- rad rad2))

                                       (if (< (abs delta) len)
                                         (progn

                                           (setq tan  (sqrt (- (* len len) (* delta delta))) iAng (atan tan delta)

                                                 blg1 (/ (sin (* 0.5 (- pi iAng))) (cos (* 0.5 (- pi iAng))))

                                                 blg2 (/ (sin (* 0.5 iAng))        (cos (* 0.5 iAng))))
                       
                                           (entmod
                                             (append en
                                               (list
                                                 (cons 10 (polar cen  (+ ang iAng) rad))
                                                 (cons 42 blg1)
                                                 (cons 10 (polar cen  (- ang iAng) rad))
                                                 
                                                 (cons 10 (polar cen2 (- ang iAng) rad2))
                                                 (cons 42 blg2)
                                                 (cons 10 (polar cen2 (+ ang iAng) rad2))))) nil)))

                                    (t (setq str "")

                                       (princ (strcat "\n** Invalid Input **" msg)))))
                           (t )))
                 
                  (t )))))
     

      (defun foo2 nil  (setq str "")
        (while
          (progn
            (setq gr (grread 't 15 0) code (car gr) data (cadr gr))
           
            (cond (  (and (= 5 code) (listp data))
                   
                     (setq dis (distance cen data) ang (angle cen data))
                   
                     (if (< rad dis)
                       (progn
                       
                         (setq tan  (sqrt (- (* dis dis) (* rad rad)))
                             
                               iAng (atan tan rad)
                             
                               blg  (/ (sin (* 0.5 (- pi iAng)))
                                       (cos (* 0.5 (- pi iAng)))))
                       
                         (entmod
                           (append en
                             (setq lst
                                (list
                                  (cons 10 data)
                                  (cons 10 (polar cen (+ ang iAng) rad))
                                  (cons 42 blg)
                                  (cons 10 (polar cen (- ang iAng) rad))))))) t))
                 
                  (  (and (= 3 code) (listp data))
                   
                     (setq dis (distance cen data) ang (angle cen data))
                   
                     (if (< rad dis)
                       (progn
                       
                         (setq tan  (sqrt (- (* dis dis) (* rad rad)))
                             
                               iAng (atan tan rad)
                             
                               blg  (/ (sin (* 0.5 (- pi iAng)))
                                       (cos (* 0.5 (- pi iAng)))))
                       
                         (setq en
                           (append en
                             (list
                               (cons 10 data)
                               (cons 10 data)
                               (cons 10 (polar cen (+ ang iAng) rad))
                               (cons 42 blg)
                               (cons 10 (polar cen (- ang iAng) rad)))))
                       
                         (setq en (reverse
                                    (vl-member-if
                                      (function
                                        (lambda (x)
                                          (= 39 (car x))))
                                   
                                      (reverse
                                        (entmod
                                          (subst (cons 90 4) (assoc 90 en) en)))))
                             
                               cen2 data len (distance cen cen2) ang (angle cen cen2))
                       
                         (setq msg (princ "\nPick Second Radius: "))
                         (foo1))))

                  (  (= 2 code)

                     (cond (  (or (vl-position data '(44 46)) (< 47 data 58))
                         
                              (setq str (strcat str (princ (chr data)))))

                           (  (and (< 0 (strlen str)) (= 8 data))

                              (setq str (substr str 1 (1- (strlen str))))
                              (princ (vl-list->string '(8 32 8))))

                           (  (vl-position data '(32 13))                           

                              (cond (  (zerop (strlen str)) t)

                                    (  (apply (function and)
                                         (setq tmp
                                           (mapcar (function distof) (StrBrk str 44))))

                                       (setq data tmp dis (distance cen data) ang (angle cen data))

                                       (if (< rad dis)
                                         (progn

                                           (setq tan  (sqrt (- (* dis dis) (* rad rad)))
                             
                                                 iAng (atan tan rad)
                                                 
                                                 blg  (/ (sin (* 0.5 (- pi iAng)))
                                                         (cos (* 0.5 (- pi iAng)))))
                                           
                                           (setq en
                                             (append en
                                               (list
                                                 (cons 10 data)
                                                 (cons 10 data)
                                                 (cons 10 (polar cen (+ ang iAng) rad))
                                                 (cons 42 blg)
                                                 (cons 10 (polar cen (- ang iAng) rad)))))
                                           
                                           (setq en (reverse
                                                      (vl-member-if
                                                        (function
                                                          (lambda (x)
                                                            (= 39 (car x))))
                                                       
                                                        (reverse
                                                          (entmod
                                                            (subst (cons 90 4) (assoc 90 en) en)))))
                                                 
                                                 cen2 data len (distance cen cen2) ang (angle cen cen2))
                                           
                                           (setq msg (princ "\nPick Second Radius: "))
                                           (foo1))))

                                    (t (setq str "")
                                     
                                       (princ (strcat "\n** Invalid Input **" msg)))))
                           (t )))
                                   
                  (t )))))
     
     
      (setq msg (princ "\nPick First Radius: ")) (setq str "")     
     
      (while
        (progn
          (setq gr (grread 't 15 0) code (car gr) data (cadr gr))

          (cond (  (and (= 5 code) (listp data))
                 
                   (setq data (trans data 1 0) ang (angle cen data)

                         dis (distance cen data))

                   (entmod
                     (append en
                       (setq lst
                         (list
                           (cons 10 data)
                           (cons 42 1.)
                           (cons 10 (polar data (+ ang pi) (* 2. dis)))
                           (cons 42 1.))))))

                (  (and (= 3 code) (listp data))
                 
                   (setq data (trans data 1 0))

                   (setq en
                     (append en
                       (setq lst
                         (list
                           (cons 10 data)
                           (cons 42 1.)
                           (cons 10 (polar data (+ ang pi) (* 2. dis)))
                           (cons 42 1.)
                           (cons 10 data))))

                         en (reverse
                              (vl-member-if
                                (function
                                  (lambda (x)
                                    (= 39 (car x))))

                                (reverse
                                  (entmod
                                    (subst (cons 90 3) (assoc 90 en) en)))))
                         
                         rad (distance cen data))

                   (princ (setq msg "\nPick Center of Second Radius: "))
                   (foo2))

                (  (= code 2)

                   (cond (  (or (= data 46) (< 47 data 58))
                         
                            (setq str (strcat str (princ (chr data)))))

                         (  (and (< 0 (strlen str)) (= 8 data))

                            (setq str (substr str 1 (1- (strlen str))))
                            (princ (vl-list->string '(8 32 8))))

                         (  (vl-position data '(32 13))                           

                            (cond (  (zerop (strlen str)) t)

                                  (  (and (setq tmp (distof str))
                                          (not (zerop tmp)))
                                   
                                     (setq data (polar cen 0 tmp))

                                     (setq en
                                       (append en
                                         (setq lst
                                           (list
                                             (cons 10 data)
                                             (cons 42 1.)
                                             (cons 10 (polar data (+ ang pi) (* 2. dis)))
                                             (cons 42 1.)
                                             (cons 10 data))))

                                           en (reverse
                                                (vl-member-if
                                                  (function
                                                    (lambda (x)
                                                      (= 39 (car x))))
                                                 
                                                  (reverse
                                                    (entmod
                                                      (subst (cons 90 3) (assoc 90 en) en)))))
                                           
                                           rad (distance cen data))

                                     (setq msg (princ "\nPick Center of Second Radius: "))
                                     (foo2))

                                  (t (setq str "")

                                     (princ (strcat "\n** Invalid Input **" msg)))))
                         (t )))
                 
                (t ))))))
  (princ))

The above can be used to construct a cam, the original discussion was to construct a line tangent to two circles.

(http://www.theswamp.org/screens/leemac/cam.gif)


Extension of this idea here (http://www.theswamp.org/index.php?topic=31371.0)
Title: Re: Examples of usage GRREAD - let's share
Post by: Kerry on December 18, 2009, 08:21:29 PM

a description of what it's 'sposed to do would be handy.
... and that first prompt confuses me "\nPick Center of First Radius: "

Regards
Kerry
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on December 18, 2009, 08:24:55 PM

a description of what it's 'sposed to do would be handy.
... and that first prompt confuses me "\nPick Center of First Radius: "

Regards
Kerry

Apologies Kerry, post updated.  :oops:
Title: Re: Examples of usage GRREAD - let's share
Post by: Kerry on December 18, 2009, 08:27:22 PM

a description of what it's 'sposed to do would be handy.
... and that first prompt confuses me "\nPick Center of First Radius: "

Regards
Kerry

Apologies Kerry, post updated.  :oops:

No apologies needed :)
... just thinking of those following who may not be able to grasp intent from the code.
Title: Re: Examples of usage GRREAD - let's share
Post by: xianaihua on December 18, 2009, 08:56:17 PM
Hi Lee Mac

nice work! :-D

I have a suggestion: You can enter a numeric value of the radius increased!
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on December 18, 2009, 09:28:48 PM
Hi Lee Mac

nice work! :-D

I have a suggestion: You can enter a numeric value of the radius increased!

Thanks Xianaihua :-)

Yes, that seems to be the next logical improvement  8-)
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on December 19, 2009, 01:17:38 PM
Code updated to accept keyboard input.  :wink:
Title: Re: Examples of usage GRREAD - let's share
Post by: Kerry on December 19, 2009, 07:08:17 PM

a description of what it's 'sposed to do would be handy.
... and that first prompt confuses me "\nPick Center of First Radius: "

Regards
Kerry

Apologies Kerry, post updated.  :oops:

No apologies needed :)
... just thinking of those following who may not be able to grasp intent from the code.

ahh yes ! a picture is worth a thousand words. !
Title: Re: Examples of usage GRREAD - let's share
Post by: xianaihua on December 22, 2009, 05:49:35 AM
Code: [Select]
;;;by:lihuili 2009-12-20
;;;Dynamic drawing a line to another line perpendicular bisector
(defun Perp_bisector_line (/   ent en      pt     enname
   p1   p2 ang ptemp1 p0     pt1
   sp   source ptemp ptemp1 ptemp2 ptemp3
   pt1   pt2 pt3 loop
  )
  (setvar "cmdecho" 0)
  (if (and (setq ent (car (entsel "\n select a line.")))
   (= (cdr (assoc 0 (setq en (entget ent)))) "LINE")
      )
    (progn
      (redraw ent 3)

      (setq p1 (trans (cdr (assoc 10 en)) 0 1)
    p2 (trans (cdr (assoc 11 en)) 0 1)
    ang (angle p1 p2)
      )
      (setq p0     (polar p1 ang (* 0.5 (distance p1 p2)))
    lineobj (vla-addLine
      (vla-get-ModelSpace
(vla-get-ActiveDocument (vlax-get-acad-object))
      )
      (vlax-3d-point p0)
      (vlax-3d-point p0)
    )
      )


      (setq ptemp1 (polar p0 (+ ang (* 0.5 pi)) 10))
      (prompt "\n to:")
      (setq loop t
    ptemp p0
    pt1 p0
      )
      (while loop
(setq sp (grread t))
(setq source (car sp)
      sp     (cadr sp)
)
(cond ((= source 5)
       (setq ptemp sp)
       (setq ptemp2 (polar sp 0 10)
     ptemp3 (polar sp (* 0.5 pi) 10)
       )
       (setq pt2 (inters p0 ptemp1 sp ptemp2 nil))
       (setq pt3 (inters p0 ptemp1 sp ptemp3 nil))
       (cond ((null pt2) (setq pt1 pt3))
     ((null pt3) (setq pt1 pt2))
     (t
      (if (< (distance sp pt2) (distance sp pt3))
(setq pt1 pt2)
(setq pt1 pt3)
      )
     )
       )
       (vla-put-EndPoint lineobj (vlax-3d-point pt1))
      )
      (t (setq loop nil))
)
      )
     
      (redraw ent 4)
    )

    (prompt "\n No select a line!")
  )
  (princ)
)


(defun c:test ()
  (Perp_bisector_line)
)
Title: Re: Examples of usage GRREAD - let's share
Post by: Fred Tomke on December 22, 2009, 06:18:49 AM
Hi, I neither want to disturb nor to annoy but I'd prefer to rotate the crosshair while dragging perpendicular (see attached gif).

Fred
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on December 22, 2009, 10:05:57 AM
Hey xianaihua, I did something similar to that...

Code: [Select]
;;; Draw perpendicular line
;;; Alan J. Thompson, 10.15.09
(defun c:LPer (/ #Ent #Read)
  (and
    (setq #Ent (car (entsel "\nSelect curve: ")))
    (vl-position (cdr (assoc 0 (entget #Ent))) '("LWPOLYLINE" "ARC" "LINE" "CIRCLE" "ELLIPSE"))
    (while (not (eq 25 (car (setq #Read (grread T 15 0)))))
      (princ "\rSpecify point for line: ")
      (redraw)
      (if (vl-consp (cadr #Read))
        (grdraw (vlax-curve-getclosestpointto #Ent (trans (cadr #Read) 1 0) T)
                (trans (cadr #Read) 1 0)
                1
        ) ;_ grdraw
      ) ;_ if
      (if (eq 3 (car #Read))
        (entmake (list '(0 . "LINE")
                       (cons 10 (vlax-curve-getclosestpointto #Ent (trans (cadr #Read) 1 0) T))
                       (cons 11 (trans (cadr #Read) 1 0))
                 ) ;_ list
        ) ;_ entmake
      ) ;_ if
    ) ;_ while
  ) ;_ and
  (redraw)
  (princ)
) ;_ defun
Title: Re: Examples of usage GRREAD - let's share
Post by: xianaihua on December 22, 2009, 11:14:48 AM
Hi,alanjt
nice work!
Your program can add to the block processing,In other words, be able to select block.
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on December 22, 2009, 12:30:45 PM
Hi,alanjt
nice work!
Your program can add to the block processing,In other words, be able to select block.
:) Thanks
No, the vlax-curve... functions don't work on blocks.
Title: Re: Examples of usage GRREAD - let's share
Post by: rkmcswain on December 22, 2009, 01:24:23 PM
Don't flame me too bad... I know, no code, but here is a animation of what it does....
Title: Re: Examples of usage GRREAD - let's share
Post by: dgorsman on December 22, 2009, 01:33:08 PM
Ooooh....   :kewl:
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on December 22, 2009, 01:42:58 PM
I posted this one in another thread....
http://www.theswamp.org/index.php?topic=30660.0
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on December 22, 2009, 01:43:59 PM
Don't flame me too bad... I know, no code, but here is a animation of what it does....

Very cool!
Title: Re: Examples of usage GRREAD - let's share
Post by: CAB on December 22, 2009, 02:40:18 PM
Here is another grread...
http://www.theswamp.org/index.php?topic=27747.0

and another:
http://www.theswamp.org/index.php?topic=18537.0
Title: Re: Examples of usage GRREAD - let's share
Post by: VovKa on December 22, 2009, 03:03:54 PM
No, the vlax-curve... functions don't work on blocks.
so, we will cheat a little :)
Code: [Select]
(defun c:LPer (/ #Ent #Read *error*)
  (defun *error* (msg) (and #Ent (entdel #Ent)) (princ msg))
  (and
    (setq #Ent (nentselp "\nSelect curve: "))
    (vl-position (cdr (assoc 0 (entget (car #Ent))))
'("LWPOLYLINE" "ARC" "LINE" "CIRCLE" "ELLIPSE")
    )
    (setq #Read (caddr #Ent)
  #Ent (entmakex (append (entget (car #Ent)) (list (cons 60 1))))
    )
    (or (not #Read)
(not (vla-transformby (vlax-ename->vla-object #Ent) (vlax-tmatrix #Read)))
    )
    (not
      (while (not (eq 25 (car (setq #Read (grread T 15 0)))))
(princ "\rSpecify point for line: ")
(redraw)
(if (vl-consp (cadr #Read))
  (grdraw (vlax-curve-getclosestpointto #Ent (trans (cadr #Read) 1 0) T)
  (trans (cadr #Read) 1 0)
  1
  )
)
(if (eq 3 (car #Read))
  (entmake
    (list '(0 . "LINE")
  (cons 10 (vlax-curve-getclosestpointto #Ent (trans (cadr #Read) 1 0) T))
  (cons 11 (trans (cadr #Read) 1 0))
    )
  )
)
      )
    )
    (entdel #Ent)
  )
  (redraw)
  (princ)
)
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on December 22, 2009, 03:07:46 PM
Damn it! I've even used vla-transformby before. Hell, I have a rotation extraction sub that uses this exact method. I can't believe I didn't think of it.  :|
Very nice Vovka. :)

No, the vlax-curve... functions don't work on blocks.
so, we will cheat a little :)
Code: [Select]
(defun c:LPer (/ #Ent #Read *error*)
  (defun *error* (msg) (and #Ent (entdel #Ent)) (princ msg))
  (and
    (setq #Ent (nentselp "\nSelect curve: "))
    (vl-position (cdr (assoc 0 (entget (car #Ent))))
'("LWPOLYLINE" "ARC" "LINE" "CIRCLE" "ELLIPSE")
    )
    (setq #Read (caddr #Ent)
  #Ent (entmakex (append (entget (car #Ent)) (list (cons 60 1))))
    )
    (or (not #Read)
(not (vla-transformby (vlax-ename->vla-object #Ent) (vlax-tmatrix #Read)))
    )
    (not
      (while (not (eq 25 (car (setq #Read (grread T 15 0)))))
(princ "\rSpecify point for line: ")
(redraw)
(if (vl-consp (cadr #Read))
  (grdraw (vlax-curve-getclosestpointto #Ent (trans (cadr #Read) 1 0) T)
  (trans (cadr #Read) 1 0)
  1
  )
)
(if (eq 3 (car #Read))
  (entmake
    (list '(0 . "LINE")
  (cons 10 (vlax-curve-getclosestpointto #Ent (trans (cadr #Read) 1 0) T))
  (cons 11 (trans (cadr #Read) 1 0))
    )
  )
)
      )
    )
    (entdel #Ent)
  )
  (redraw)
  (princ)
)
Title: Re: Examples of usage GRREAD - let's share
Post by: David Bethel on December 23, 2009, 07:15:49 AM
Just a simple grread call:

Code: [Select]
;;;GET SINGLE LETTER RESPONSE WITH OUT ENTER
;;;USEAGE  (getsltr '("Y" "N"))
(defun getsltr (al / in cl)
   (foreach a al
      (setq cl (cons (ascii (strcase a t)) cl)
            cl (cons (ascii (strcase a)) cl)))
   (while (not (member in cl))
          (princ "\n")
          (prin1 al)
          (princ ":   ")
          (setq in (cadr (grread))))
   (strcase (chr in)))

-David
Title: Re: Examples of usage GRREAD - let's share
Post by: ronjonp on December 23, 2009, 02:51:54 PM
Just adding to Vovkas Alan's routine  :-P...this one stores the segments added and sorts to the closest one  :-)

Code: [Select]
(defun c:lpers (/ *error* #ent #read clpt clr el ent lname pt x)
  (defun *error* (msg) (and #ent (mapcar 'entdel #ent)) (princ msg))
  (and
    (setq #ent (nentselp "\nSelect curve: "))
    (vl-position
      (cdr (assoc 0 (setq el (entget (car #ent)))))
      '("LWPOLYLINE" "ARC" "LINE" "CIRCLE" "ELLIPSE")
    )
    (setq clr (cdr (assoc 62 (entget (tblobjname "layer" (cdr (assoc 8 el)))))))
    (setq lname (cdr (assoc 8 el)))
    (setq #read (caddr #ent)
 #ent (entmakex (append (entget (car #ent)) (list (cons 60 1))))
    )
    (or (not #read)
(not (vla-transformby (vlax-ename->vla-object #ent) (vlax-tmatrix #read)))
    )
    (setq #ent (list #ent))
    (not
      (while (not (eq 2 (car (setq #read (grread t 15 0)))))
(princ "\rSpecify point for line: ")
(redraw)
(if (vl-consp (setq pt (cadr #read)))
 (progn
   (setq ent
  (car
    (mapcar
      'cdr
      (vl-sort
(mapcar '(lambda (x)
   (cons (distance (setq pt (trans (cadr #read) 1 0))
   (setq clpt (vlax-curve-getclosestpointto
x
(trans (cadr #read) 1 0)
      )
   )
 )
 x
   )
 )
#ent
)
(function (lambda (d1 d2) (< (car d1) (car d2))))
      )
    )
  )
   )
   (grdraw (setq clpt (setq clpt (vlax-curve-getclosestpointto ent pt))) pt clr)
 )
)
(if (eq 3 (car #read))
 (setq
   #ent (cons (entmakex
(list '(0 . "LINE") (cons 8 lname) (cons 10 clpt) (cons 11 pt))
      )
      #ent
)
 )
)
      )
    )
  )
  (redraw)
  (princ)
)
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on December 23, 2009, 03:02:19 PM
Mine and Ron's collaborative effort to combat boredom  :evil:

Code: [Select]
(defun c:bored (/ cir cnt gr lst n d)
  (setq lst (list (getvar 'viewctr) (getvar 'viewctr)) cnt 0)
 
  (while (eq 5 (car (setq gr (grread nil 5 1))))
    (redraw)
    (setq cir nil n 0 lst (append lst (list (last lst) (cadr gr))) cnt (1+ cnt))
   
    (if (< 100 cnt) (setq lst (cddr lst)))
   
    (repeat 50 (setq d (/ (distance (car lst) (last lst)) 4.))
      (repeat 4
        (setq cir (cons (polar (car lst)
                               (* (setq n (1+ n)) (/ (* pi 2) 50)) d) cir))
        (setq d (/ d 2.))))
   
    (grvecs (append (list (rem (/ cnt 100) 255)) lst cir)))
 
  (princ))

(http://www.theswamp.org/screens/leemac/Bored.gif)
Title: Re: Examples of usage GRREAD - let's share
Post by: wizman on December 23, 2009, 03:32:44 PM
Good Codes Guys, here's my simple addition:


Code: [Select]
(defun c:test (/ grr ent entlist inp pt1 pt2)
    ;;
    ;;
    (defun MkLine (p1 p2)
        (entmakex (list (cons 0 "LINE")
                        (cons 10 p1)
                        (cons 11 p2)
                  ) ;_ list
        ) ;_ entmakex
    ) ;_ defun
    ;;
    ;;
    (if
        (and
            (setq pt1 (getpoint "\n>>>...Pick Points...>>>: "))
            (setq pt2 (getpoint pt1))
            (setq ent (mkline pt1 pt2))
            (setq entlist (list ent))
        ) ;_ and
           ;;
           ;;
           (progn
               (while
                   (progn
                       (setq grr (grread t 7 0)
                             inp (car grr)
                       ) ;_ setq
                       (if (= (length entlist) 1)
                           (setq entlist (cons (mkline pt2 (cadr grr)) entlist))
                       ) ;_ if
                       (cond
                           ((= inp 3)
                            (setq entlist (cons (mkline (cadr grr) pt1) entlist))
                            (setq pt1 (cadr grr))
                           )
                           ((or (= inp 25) (= inp 11))
                            nil
                           )
                           ((= inp 5)
                            (foreach x entlist
                                (entmod
                                    (subst
                                        (cons 11 (cadr grr))
                                        (assoc 11 (entget x))
                                        (entget x)
                                    ) ;_ subst
                                ) ;_ entmod
                                (not (redraw x 3))
                            ) ;_ foreach
                           )
                       ) ;_ cond
                   ) ;_ progn
               ) ;_ while
               (foreach x entlist
                   (redraw x 4)
               ) ;_ foreach
           ) ;_ progn
           ;;
           ;;
    ) ;_ if
    (princ)
) ;_ defun
;;
;;
;;WIZ_24DEC09

Title: Re: Examples of usage GRREAD - let's share
Post by: wizman on December 23, 2009, 03:42:52 PM
Quote
so, we will cheat a little

another cheat is to just explode the block.
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on December 23, 2009, 03:45:25 PM
Very nice Ron!
I didn't expect so much to come out of what little my initial contribution was.

Just adding to Vovkas routine...this one stores the segments added and sorts to the closest one  :-)

Code: [Select]
(defun c:lpers (/ *error* #ent #read clpt clr el ent lname pt x)
  (defun *error* (msg) (and #ent (mapcar 'entdel #ent)) (princ msg))
  (and
    (setq #ent (nentselp "\nSelect curve: "))
    (vl-position
      (cdr (assoc 0 (setq el (entget (car #ent)))))
      '("LWPOLYLINE" "ARC" "LINE" "CIRCLE" "ELLIPSE")
    )
    (setq clr (cdr (assoc 62 (entget (tblobjname "layer" (cdr (assoc 8 el)))))))
    (setq lname (cdr (assoc 8 el)))
    (setq #read (caddr #ent)
  #ent (entmakex (append (entget (car #ent)) (list (cons 60 1))))
    )
    (or (not #read)
(not (vla-transformby (vlax-ename->vla-object #ent) (vlax-tmatrix #read)))
    )
    (setq #ent (list #ent))
    (not
      (while (not (eq 2 (car (setq #read (grread t 15 0)))))
(princ "\rSpecify point for line: ")
(redraw)
(if (vl-consp (setq pt (cadr #read)))
  (progn
    (setq ent
   (car
     (mapcar
       'cdr
       (vl-sort
(mapcar '(lambda (x)
    (cons (distance (setq pt (trans (cadr #read) 1 0))
    (setq clpt (vlax-curve-getclosestpointto
x
(trans (cadr #read) 1 0)
       )
    )
  )
  x
    )
  )
#ent
)
(function (lambda (d1 d2) (< (car d1) (car d2))))
       )
     )
   )
    )
    (grdraw (setq clpt (setq clpt (vlax-curve-getclosestpointto ent pt))) pt clr)
  )
)
(if (eq 3 (car #read))
  (setq
    #ent (cons (entmakex
(list '(0 . "LINE") (cons 8 lname) (cons 10 clpt) (cons 11 pt))
       )
       #ent
)
  )
)
      )
    )
  )
  (redraw)
  (princ)
)

Title: Re: Examples of usage GRREAD - let's share
Post by: VovKa on December 23, 2009, 03:56:01 PM
Just adding to Vovkas routine...this one stores the segments added and sorts to the closest one  :-)
Ron, stop discrediting me, 95% of the code is Alan's :)

Mine and Ron's collaborative effort to combat boredom  :evil:
guys, i'm having fun with it, coooool :)
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on December 23, 2009, 04:11:54 PM
Just adding to Vovkas routine...this one stores the segments added and sorts to the closest one  :-)
Ron, stop discrediting me, 95% of the code is Alan's :)
:-(
Title: Re: Examples of usage GRREAD - let's share
Post by: VovKa on December 23, 2009, 04:39:42 PM
hey don't be sad, Alan
i didn't mean to say that you code is bad or something, i meant that i personally never use grread.
writing lisps for years i still haven't found any way i could use grread. it's because of the lack of fantasy i suppose :)
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on December 23, 2009, 06:53:32 PM
IMO GrRead would be a TON more useful if it support OSnap...
Title: Re: Examples of usage GRREAD - let's share
Post by: CAB on December 23, 2009, 07:38:10 PM
I second that :-)
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on December 23, 2009, 09:46:08 PM
hey don't be sad, Alan
i didn't mean to say that you code is bad or something, i meant that i personally never use grread.
writing lisps for years i still haven't found any way i could use grread. it's because of the lack of fantasy i suppose :)
No offense taken. :)

I don't really use grread, with the lack of functionality (input, which can be emulated, but it's still pretty shaky and osnaps) it's just not worth the aggravation.
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on December 24, 2009, 10:32:20 AM
Another bit of fun  8-)

http://www.theswamp.org/index.php?topic=29961.msg355348#msg355348 (http://www.theswamp.org/index.php?topic=29961.msg355348#msg355348)
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on December 24, 2009, 11:31:54 AM
Here's a real simple one I did, modeled after a thread here. It's nice because it allows me to have the last typed in input available for the next time I create a text object. It's real simple.

Code: [Select]
;;; Quick Text
;;; Required Subroutines: AT:Mtext AT:Getstring
;;; Alan J. Thompson, 09.23.09
(defun c:QT (/ #Point1 #Point2 #String #Text #Final)
  (or QT:Default (setq QT:Default ""))
  (and (setq #String (AT:Getstring "Specify text string: " QT:Default))
       (not (eq #String ""))
       (setq QT:Default (strcase #String))
       (setq #Point1 (getpoint "\nSpecify placement point: "))
       (or (setq
             #Point2 (getpoint #Point1 "\nSpecify next point for angle <Zero>: ")
           ) ;_ setq
           (setq #Point2 #Point1)
       ) ;_ or
       (setq #Text (AT:Mtext #Point1 QT:Default 0 nil 5))
       (not (vla-put-rotation #Text (angle #Point1 #Point2)))
       (while (eq 5 (car (setq #Final (grread T 4 4))))
         (vla-put-insertionpoint #Text (vlax-3d-point (trans (cadr #Final) 1 0)))
       ) ;_ while
  ) ;_ and
  (princ)
) ;_ defun

You would need these two subroutines:
Code: [Select]
;;; Add MText to drawing
;;; #InsertionPoint - MText insertion point
;;; #String - String to place in created MText object
;;; #Width - Width of MText object (if nil, will be 0 width)
;;; #Layer - Layer to place Mtext object on (nil for current)
;;; #Justification - Justification # for Mtext object
;;;      1 or nil= TopLeft
;;;      2= TopCenter
;;;      3= TopRight
;;;      4= MiddleLeft
;;;      5= MiddleCenter
;;;      6= MiddleRight
;;;      7= BottomLeft
;;;      8= BottomCenter
;;;      9= BottomRight
;;; Alan J. Thompson, 05.23.09
(defun AT:MText (#InsertionPoint #String #Width #Layer #Justification / #Width
                 #Space #Insertion #Object
                )
  (or #Width (setq #Width 0))
  (or *AcadDoc*
      (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object)))
  ) ;_ or
  (setq #Space     (if (or (eq acmodelspace
                               (vla-get-activespace *AcadDoc*)
                           ) ;_ eq
                           (eq :vlax-true (vla-get-mspace *AcadDoc*))
                       ) ;_ or
                     (vla-get-modelspace *AcadDoc*)
                     (vla-get-paperspace *AcadDoc*)
                   ) ;_ if
        #Insertion (cond
                     ((vl-consp #InsertionPoint) (vlax-3d-point #InsertionPoint))
                     ((eq (type #InsertionPoint) 'variant) #InsertionPoint)
                     (T nil)
                   ) ;_ cond
  ) ;_ setq
  ;; create MText object
  (setq #Object (vla-addmtext #Space #Insertion #Width #String))
  ;; change layer, if applicable
  (and #Layer
       (tblsearch "layer" #Layer)
       (vla-put-layer #Object #Layer)
  ) ;_ and
  ;; change justification & match insertion point with new justification
  (cond ((member #Justification (list 1 2 3 4 5 6 7 8 9))
         (vla-put-attachmentpoint #Object #Justification)
         (vla-move #Object
                   (vla-get-InsertionPoint #Object)
                   #Insertion
         ) ;_ vla-move
        )
  ) ;_ cond
  #Object
) ;_ defun

Code: [Select]
;;; Getstring Dialog Box
;;; #Title - Title of dialog box
;;; #Default - Default string within edit box
;;; Alan J. Thompson, 08.25.09
(defun AT:GetString
       (#Title #Default / #FileName #FileOpen #DclID #NewString)
  (setq #FileName (vl-filename-mktemp "" "" ".dcl")
        #FileOpen (open #FileName "W")
  ) ;_ setq
  (foreach x '("TempEditBox : dialog {" "key = \"Title\";"
               "label = \"\";" "initial_focus = \"Edit\";" "spacer;"
               ": row {" ": column {" "alignment = centered;"
               "fixed_width = true;" ": text {" "label = \"\";" "}" "}"
               ": edit_box {" "key = \"Edit\";" "allow_accept = true;"
               "edit_width = 40;" "fixed_width = true;" "}" "}"
               "spacer;" ": row {" "fixed_width = true;"
               "alignment = centered;" ": ok_button {" "width = 11;" "}"
               ": cancel_button {" "width = 11;" "}" "}" "}//"
              )
    (write-line x #FileOpen)
  ) ;_ foreach
  (close #FileOpen)
  (setq #DclID (load_dialog #FileName))
  (new_dialog "TempEditBox" #DclID)
  (set_tile "Title" #Title)
  (set_tile "Edit" #Default)
  (action_tile
    "accept"
    "(setq #NewString (get_tile \"Edit\"))(done_dialog)"
  ) ;_ action_tile
  (action_tile "cancel" "(done_dialog)")
  (start_dialog)
  (unload_dialog #DclID)
  (vl-file-delete #FileName)
  #NewString
) ;_ defun
Title: Re: Examples of usage GRREAD - let's share
Post by: xianaihua on December 24, 2009, 11:39:06 AM
hi!alanjt
nice work!
Learn from you!
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on December 24, 2009, 11:56:53 AM
hi!alanjt
nice work!
Learn from you!
Thanks :) but there are much much more qualified people here than me.
Title: Re: Examples of usage GRREAD - let's share
Post by: GDF on December 24, 2009, 12:20:42 PM
hi!alanjt
nice work!
Learn from you!
Thanks :) but there are much much more qualified people here than me.

Very nice routine. I added this gem to my library. Thanks for sharing it.
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on December 24, 2009, 12:23:15 PM
Thanks and you're welcome. :)

hi!alanjt
nice work!
Learn from you!
Thanks :) but there are much much more qualified people here than me.

Very nice routine. I added this gem to my library. Thanks for sharing it.
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on December 24, 2009, 12:26:57 PM
Copy the main routine again. I updated how the text is moved around with grread per something Lee had pointed out a while back (wrote it before that).

hi!alanjt
nice work!
Learn from you!
Thanks :) but there are much much more qualified people here than me.

Very nice routine. I added this gem to my library. Thanks for sharing it.
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on December 24, 2009, 12:30:58 PM
Just playing around, learning how to use grread.

Code: [Select]
;;; Magic Eraser (erase anything cursor crosses)
;;; Alan J. Thompson, 10.15.09
(defun c:EE (/ #Read #Ent)
  (while (eq 5 (car (setq #Read (grread t 15 2))))
    (princ "\rMove cursor over object to erase: ")
    (if (setq #Ent (ssget (cadr #Read)))
      (vl-catch-all-apply 'entdel (list (ssname #Ent 0)))
    ) ;_ if
  ) ;_ while
  (princ)
) ;_ defun
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on December 24, 2009, 12:32:18 PM
This has NO practical application, it was just more of my playing around with grread (learning).

Code: [Select]
;;; Dynamic Distance (distance displayed from picked base point)
;;; Alan J. Thompson, 11.09.09
(defun c:DyD (/ *error* #Pnt #Obj #Read #Dist)
  (setq *error* (lambda (x)
                  (and #Obj (vl-catch-all-apply 'vla-delete (list #Obj)))
                  (grtext)
                  (redraw)
                ) ;_ lambda
  ) ;_ setq
  (and (setq #Pnt (getpoint "\nSpecify base point: "))
       (setq #Obj (vlax-ename->vla-object
                    (entmakex (list '(0 . "CIRCLE")
                                    '(100 . "AcDbEntity")
                                    '(100 . "AcDbCircle")
                                    '(62 . 1)
                                    '(6 . "Continuous")
                                    '(40 . 1.0)
                                    (cons 10 (trans #Pnt 1 0))
                              ) ;_ list
                    ) ;_ entmakex
                  ) ;_ vlax-ename->vla-object
       ) ;_ setq
       (while (eq 5 (car (setq #Read (grread T 15 0))))
         (redraw)
         (grdraw #Pnt (cadr #Read) 1 1)
         (vl-catch-all-apply 'vla-put-radius (list #Obj (distance #Pnt (cadr #Read))))
         (setq #Dist (strcat "Distance: " (rtos (distance #Pnt (cadr #Read)))))
         (princ (strcat "\r" #Dist "          "))
         (grtext -1 #Dist)
       ) ;_ while
  ) ;_ and
  (*error* nil)
  (princ)
) ;_ defun
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on December 24, 2009, 12:34:43 PM
Last one.

I did this one as a request (ended up not being what they wanted) and just got a little carried away.

Code: [Select]
;;; Place current drawing's directory contents (matching *.dwg) in MText
;;; Required Subroutines: AT:MText
;;; Alan J. Thompson, 10.28.09
(defun c:Dir2Text (/ AT:NumFix #Pnt1 #List #Pos #String #Text #Read)
  (defun AT:NumFix (#Num #Length / #Str)
    (setq #Str (vl-princ-to-string #Num))
    (while (and (<= (1+ (strlen #Str)) #Length) (< (strlen #Str) 16))
      (setq #Str (strcat "0" #Str))
    ) ;_ while
    #Str
  ) ;_ defun
  (cond
    ((setq #Pnt1 (getpoint "\nSpecify first corner: "))
     (setq #List   (vl-sort (vl-remove-if-not
                              '(lambda (x) (wcmatch x "*.dwg"))
                              (vl-directory-files (getvar 'dwgprefix))
                            ) ;_ vl-remove-if-not
                            '<
                   ) ;_ vl-sort
           #String ""
     ) ;_ setq
     (foreach x #List
       (setq #Pos (AT:NumFix (1+ (vl-position x #List)) (length #List)))
       (setq #String (strcat #String #Pos " - " (vl-filename-base x) "\\P"))
     ) ;_ foreach
     (setq #Text (AT:MText #Pnt1 #String 0 nil 1))
     (while (eq 5 (car (setq #Read (grread T 15 2))))
       (redraw)
       (grvecs (list 7
                     #Pnt1
                     (list (car (cadr #Read)) (cadr #Pnt1))
                     (list (car (cadr #Read)) (cadr #Pnt1))
                     (cadr #Read)
                     (cadr #Read)
                     (list (car #Pnt1) (cadr (cadr #Read)))
                     (list (car #Pnt1) (cadr (cadr #Read)))
                     #Pnt1
               ) ;_ list
       ) ;_ grvecs
       (vla-put-width #Text (abs (- (car #Pnt1) (car (cadr #Read)))))
     ) ;_ while
    )
  ) ;_ cond
  (redraw)
  (princ)
) ;_ defun

You'll need the AT:MText subroutine (posted above).
http://www.theswamp.org/index.php?topic=12813.msg369811#msg369811
Title: Re: Examples of usage GRREAD - let's share
Post by: xianaihua on December 25, 2009, 12:02:03 AM
Dear friends of the good works one after another eye-opener
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on December 26, 2009, 07:45:55 AM
Alan, you could always cheat with your GetString  :evil:

Code: [Select]
(defun LM:GetString (#Default / dcTag result)
  (cond (  (<= (setq dcTag (load_dialog "ACAD")) 0))
        (  (not (new_dialog "acad_txtedit" dcTag)))
        (t
           (set_tile "text_edit" #Default)
           (action_tile "accept" "(setq result (get_tile \"text_edit\")) (done_dialog)")
           (action_tile "cancel" "(done_dialog)")

           (start_dialog)
           (unload_dialog dcTag)))
  result)
Title: Re: Examples of usage GRREAD - let's share
Post by: VovKa on December 26, 2009, 09:37:16 AM
Lee, i'm a cheater too :)
Code: [Select]
(lisped "edit me")
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on December 26, 2009, 11:54:31 AM
True, maybe one of these days I'll actually learn DCL properly.

Alan, you could always cheat with your GetString  :evil:

Code: [Select]
(defun LM:GetString (#Default / dcTag result)
  (cond (  (<= (setq dcTag (load_dialog "ACAD")) 0))
        (  (not (new_dialog "acad_txtedit" dcTag)))
        (t
           (set_tile "text_edit" #Default)
           (action_tile "accept" "(setq result (get_tile \"text_edit\")) (done_dialog)")
           (action_tile "cancel" "(done_dialog)")

           (start_dialog)
           (unload_dialog dcTag)))
  result)
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on December 26, 2009, 12:34:14 PM
Nah, its just using whats already there  :evil:
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on December 26, 2009, 05:16:45 PM
Nah, its just using whats already there  :evil:
Oh I know, I just meant that, if I knew enough about DCL, I would recognize what I needed.
Title: Re: Examples of usage GRREAD - let's share
Post by: CAB on December 26, 2009, 05:50:37 PM
Alan, Just using ACAD dcl which is already built.
Code: [Select]
;;  Text Edit Only
;;  CAB  03.06.07
(defun c:teo (/ ss txt elst newtxt dcledit)
  (defun dcledit (txt / attlist NewTxt ddatt_dcl)
    (and
      (setq oldtxt txt
            dcl    (load_dialog "ACAD")
      )
      (new_dialog "acad_txtedit" dcl)
      (set_tile "text_edit" txt)
      (action_tile "text_edit" "(setq txt $value)")
      (action_tile "cancel" "(setq txt oldtxt)")
      (start_dialog)
      (unload_dialog dcl)
    )
    txt
  )
  (while (setq ss (ssget "_+.:E:S" '((0 . "TEXT"))))
    (setq elst (entget (ssname ss 0))
          txt  (cdr (assoc 1 elst))
    )
    (if (/= txt (setq NewTxt (dcledit txt)))
      (entupd
        (cdr (assoc -1 (entmod (subst (cons 1 NewTxt) (assoc 1 elst) elst))))
      )
    )
  )
  (princ)
)
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on December 26, 2009, 08:38:29 PM
They are quite handy  :evil:

Code: [Select]
(defun c:qe (/ i ss tx ent)
  (and (setq i -1 ss (ssget "_:L" '((0 . "MTEXT,TEXT"))))
       (not (numberp (setq tx (lisped "New Text"))))
       (while (setq ent (ssname ss (setq i (1+ i))))
         (entmod (subst (cons 1 tx) (assoc 1 (entget ent)) (entget ent)))))
  (princ))
Title: Re: Examples of usage GRREAD - let's share
Post by: cmwade77 on January 04, 2010, 07:17:59 PM
Ok, anyone have a way to make polar snap work with GRRead? I have been trying, so far haven't even come close.
Title: Re: Examples of usage GRREAD - let's share
Post by: cmwade77 on January 06, 2010, 03:11:15 PM
Ok, I have another one here, this is a modification of Alan's code with VovKa's modification in it:
Code: [Select]
;*************************************************************************************************************************
;| VERSION HISTORY **
**
IB - VERSION 1.0 **
01/06/10 **
BY: CHRIS WADE **
**
- Insert Blocks on lines, arcs, polylines, other blocks, circles, etc. **
- Type: **
- W - Cycles from 3-5 wires **
- A - Changes to Arrowheads **
- C - Continuation Block **
- E - Use endpoint of object **
- T - Type block name. **
**
;*************************************************************************************************************************|;

; Code Adapted from VovKa's modification of Alanjt's code at http://www.theswamp.org/index.php?topic=12813.msg369625#msg369625
; Alanjt's Original code is located at: http://www.theswamp.org/index.php?topic=12813.msg369597#msg369597

(defun c:IB (/ #Ent #Read *error* blobj Ang lastpt cpt bname w ws bscale sObj oLay Snap Spt *thisdrawing* *modelspace* *paperspace*)
  ;;Error routine adapted from:
;;                     --=={  Dynamic Text Curve Align  }==--                    ;;
;;  AUTHOR:                                                                      ;;
;;                                                                               ;;
;;  Copyright © Lee McDonnell, November 2009. All Rights Reserved.               ;;
;;                                                                               ;;
;;      { Contact: Lee Mac @ TheSwamp.org, CADTutor.net }                        ;;
(defun *error* (msg)
(and blobj(or (and pLst (mapcar (function (lambda (x) (vlax-put blobj (car x) (cdr x)))) pLst)) (and (not (vlax-erased-p blobj)) (vla-delete blobj))))
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **")))
        (redraw)
(princ)
)
  (setq TMP nil)
  (vl-load-com)
  (setq bname "3W")
  (setq W 3)
  (setq bscale (/ (getvar "dimscale") 96)) 
  (vl-cmdf "._insert" bname)(command)
  (setq *thisdrawing* (vla-get-activedocument
(vlax-get-acad-object)
      ) ;_ end of vla-get-activedocument
      *modelspace*  (vla-get-ModelSpace *thisdrawing*)
  *paperspace*  (vla-get-PaperSpace *thisdrawing*))
  (and
    (setq #Ent (nentselp "\nSelect Item to Insert Block On: "))
    (vl-position (cdr (assoc 0 (entget (car #Ent))))
'("LWPOLYLINE" "ARC" "LINE" "CIRCLE" "ELLIPSE")
    )
    (setq #Read (caddr #Ent)
  #Ent (entmakex (append (entget (car #Ent)) (list (cons 60 1))))
    )
(setq Sobj (vlax-ename->vla-object #Ent)
  oLay (vla-get-Layer Sobj))
    (or (not #Read)
(not (vla-transformby Sobj (vlax-tmatrix #Read)))
    )
    (not
      (while (not (eq 25 (car (setq #Read (grread T 15 0)))))
  (princ "\rSpecify point for block ([W]ires/[A]rrow/[C]ontinuation block/[T]ype block name/[E]ndpoint): ")
  (redraw)
(cond
((eq 3 (car #Read))
(if (or (/= (getvar "cvport") 1) (/= (getvar "tilemode") 0))
(setq blobj (vla-InsertBlock *modelspace* (vlax-3d-point Spt) bname bscale bscale bscale Ang))
(setq blobj (vla-InsertBlock *paperspace* (vlax-3d-point Spt) bname bscale bscale bscale Ang))
)
(vla-put-Layer blobj oLay)
)
((and (= (car #Read) 2) (or (= (cadr #Read) 101) (= (cadr #Read) 69)))
(if (/= Snap "_End")
(setq Snap "_End")
(setq Snap nil)
)
)
((and (= (car #Read) 2) (or (= (cadr #Read) 119) (= (cadr #Read) 87)))
(if (< W 5)
(setq W (+ W 1))
(setq W 3)
)
(setq WS (rtos W 2 0))
(setq bname (strcat WS "W"))
(vl-cmdf "._insert" bname)(command)
(setq Snap nil)
)
((and (= (car #Read) 2) (or (= (cadr #Read) 65) (= (cadr #Read) 97)))
(cond
((= bname "hr")
(setq bname "hr2-11")
(setq Snap "_End")
)
(T
(setq bname "hr")
(setq Snap nil)
)
)
(vl-cmdf "._insert" bname)(command)
)
((and (= (car #Read) 2) (or (= (cadr #Read) 99) (= (cadr #Read) 67)))
(setq bname "cb")
(vl-cmdf "._insert" bname)(command)
(setq Snap "_End")
)
((and (= (car #Read) 2) (or (= (cadr #Read) 116) (= (cadr #Read) 84)))
(setq bname nil)
(while (or (= bname nil) (= bname ""))
(setq bname (getstring T "\nEnter Block Name: "))
)
(vl-cmdf "._insert" bname)(command)
(setq Snap nil)
)
(T
(if (vl-consp (cadr #Read))
(progn
(if (= lastpt nil)
(setq lastpt (vlax-curve-getclosestpointto #Ent (trans (cadr #Read) 1 0) T))
(progn
(setq cpt (vlax-curve-getclosestpointto #Ent (trans (cadr #Read) 1 0) T))
(setq data (trans (cadr #Read) 1 0))               
(setq Ang (+ (angle data cpt) (D2R 90)))
(if (/= snap nil)
(setq Spt (osnap cpt Snap))
(setq Spt cpt)
)
(if (/= Spt nil)
(progn
(if (/= blobj nil)
(if (not (vlax-erased-p blobj)) (vla-delete blobj))
)
(if (or (/= (getvar "cvport") 1) (/= (getvar "tilemode") 0))
(setq blobj (vla-InsertBlock *modelspace* (vlax-3d-point Spt) bname bscale bscale bscale Ang))
(setq blobj (vla-InsertBlock *paperspace* (vlax-3d-point Spt) bname bscale bscale bscale Ang))
)
)
)
(vla-put-Layer blobj oLay)

)
)

)  
)
)
)
      )
    )
    (entdel #Ent)
  )
  (redraw)
  (princ)
)

; Convert value in radians to degrees
(defun R2D (nbrOfRadians)
 (* 180.0 (/ nbrOfRadians pi))
)
; Convert value in degrees to radians
(defun D2R (numberOfDegrees)
 (* pi (/ numberOfDegrees 180.0))
) ;_ end of defun
(defun c:ktst ()
(while
(setq input (grread t 4 4))
(princ "\n")
(princ (cadr input))
)
)
The only problem that I am having is that if the object that you are inserting on is not closed, and you move the cursor off of the object, the block can get inserted in space (this seems to happen with the perpendicular line in the original code as well), any ideas on how to fix this?
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on January 06, 2010, 04:54:28 PM
Off the top of my head, I think you just remove the last T call from these lines:

Code: [Select]
(vlax-curve-getclosestpointto #Ent (trans (cadr #Read) 1 0) [color=red]T[/color])Just take it out or set it to nil.
Title: Re: Examples of usage GRREAD - let's share
Post by: cmwade77 on January 06, 2010, 05:41:46 PM
Thank you very much Alan, that did the trick.
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on January 06, 2010, 05:58:11 PM
Thank you very much Alan, that did the trick.
:)
Title: Re: Examples of usage GRREAD - let's share
Post by: chlh_jd on February 03, 2011, 12:47:15 AM
Here's my rough code for use grread fun
Code: [Select]
;;;ss-grread
;;;
;;;get grread point , if type the keys then run Correlation function
;;;funkeys - Keywords from the keyboard
;;;fun_names - Function name or function name list
;;;funarg_list - The parameters list or parameters list tables used for the function
;;;
;;;Return the point list , Function during the implementation of fun1 arg1
;;;
;;;GSLS(ss) , 2010-07-21
(defun ss-grread (fun_keys fun_names funarg_list fun1 arg1 / is_go_on PT midkey pos funname funarglst)
  (setq is_go_on T)
  (while (and (setq PT (grread t 4 2))
     (/= 3 (car PT))
     (/= 25 (car pt))
     is_go_on
)
    (cond      
      ((and (= 2 (car pt)) (or (eq (strcase (chr (cadr pt))) fun_keys)  (eq (strcase (chr (cadr pt)) T) fun_keys)))
       (wjm-fun fun_names funarg_list)      
       (setq is_go_on nil)      
       )
      ((and (= 2 (car pt)) (or (setq midkey (member (strcase (chr (cadr pt))) fun_keys)) (setq midkey (member (strcase (chr (cadr pt)) T) fun_keys))))
       (setq pos (vl-position (car midkey) fun_keys)
    funname (nth pos fun_names)
    funarglst(nth pos funarg_list))
       (wjm-fun funname funarglst)      
       (setq is_go_on nil)      
       )
      (t      
(if (and (= 5 (car PT)) (null fun_keys))
  (progn
    (wjm-fun fun1 arg1)    
    )
)
       )
      )
    )
  (cadr PT)
  )
Used fun
Code: [Select]
;;;the follow function coded by WJM
(defun wjm-fun (funname funarglist)
  (if (progn (setq catchit (vl-catch-all-apply
     funname
     funarglist
   )
     )
     (vl-catch-all-error-p catchit)
      )
    (progn
      (princ "函数:")
      (princ funname)
      (princ "参数表:")
      (princ funarglist)
      (princ "\n捕捉到错误:")
      (princ (vl-catch-all-error-message catchit))
    )
  )
  catchit
)
Title: Re: Examples of usage GRREAD - let's share
Post by: efernal on March 06, 2011, 11:48:16 AM
Code: [Select]
;; wrote by eduardo fernal
;; 02/2011
(DEFUN c:teste (/ p1 e1 hf osmode attreq attdia cn)
  (SETQ osmode (GETVAR "OSMODE")
        cn     0
  )
  (SETVAR "OSMODE" 0)
  (IF (NULL (TBLSEARCH "BLOCK" "EfPac0173"))
    (PROGN (IF (NULL (TBLSEARCH "STYLE" "Tempsitc"))
             (ENTMAKE '((0 . "STYLE")
                        (100 . "AcDbSymbolTableRecord")
                        (100 . "AcDbTextStyleTableRecord")
                        (2 . "Tempsitc")
                        (70 . 0)
                        (40 . 0.0)
                        (41 . 1.0)
                        (50 . 0.0)
                        (71 . 0)
                        (42 . 1.0)
                        (3 . "TEMPSITC.TTF")
                        (4 . "")
                       )
             )
           )
           (ENTMAKE '((0 . "BLOCK") (2 . "EfPac0173") (70 . 2) (10 0.0 0.0 0.0)))
           (ENTMAKE '((0 . "ATTDEF")
                      (100 . "AcDbEntity")
                      (8 . "0")
                      (100 . "AcDbText")
                      (10 3.93553 7.30553 0.0)
                      (40 . 1.0)
                      (1 . "")
                      (50 . 0.0)
                      (41 . 1.0)
                      (51 . 0.0)
                      (7 . "Tempsitc")
                      (71 . 0)
                      (72 . 0)
                      (11 0.0 0.0 0.0)
                      (100 . "AcDbAttributeDefinition")
                      (280 . 0)
                      (3 . "Norte")
                      (2 . "1")
                      (70 . 0)
                      (73 . 0)
                      (74 . 0)
                      (280 . 1)
                     )
           )
           (ENTMAKE '((0 . "ATTDEF")
                      (100 . "AcDbEntity")
                      (8 . "0")
                      (100 . "AcDbText")
                      (10 3.93553 5.64553 0.0)
                      (40 . 1.0)
                      (1 . "")
                      (50 . 0.0)
                      (41 . 1.0)
                      (51 . 0.0)
                      (7 . "Tempsitc")
                      (71 . 0)
                      (72 . 0)
                      (11 0.0 0.0 0.0)
                      (100 . "AcDbAttributeDefinition")
                      (280 . 0)
                      (3 . "Leste")
                      (2 . "2")
                      (70 . 0)
                      (73 . 0)
                      (74 . 0)
                      (280 . 1)
                     )
           )
           (ENTMAKE '((0 . "ATTDEF")
                      (100 . "AcDbEntity")
                      (8 . "0")
                      (100 . "AcDbText")
                      (10 3.93553 3.98553 0.0)
                      (40 . 1.0)
                      (1 . "")
                      (50 . 0.0)
                      (41 . 1.0)
                      (51 . 0.0)
                      (7 . "Tempsitc")
                      (71 . 0)
                      (72 . 0)
                      (11 0.0 0.0 0.0)
                      (100 . "AcDbAttributeDefinition")
                      (280 . 0)
                      (3 . "Cota")
                      (2 . "3")
                      (70 . 0)
                      (73 . 0)
                      (74 . 0)
                      (280 . 1)
                     )
           )
           (ENTMAKE '((0 . "ATTDEF")
                      (100 . "AcDbEntity")
                      (8 . "0")
                      (100 . "AcDbText")
                      (10 3.93553 1.98553 0.0)
                      (40 . 1.0)
                      (1 . "")
                      (50 . 0.0)
                      (41 . 1.0)
                      (51 . 0.0)
                      (7 . "Tempsitc")
                      (71 . 0)
                      (72 . 0)
                      (11 0.0 0.0 0.0)
                      (100 . "AcDbAttributeDefinition")
                      (280 . 0)
                      (3 . "Descrição")
                      (2 . "4")
                      (70 . 0)
                      (73 . 0)
                      (74 . 0)
                      (280 . 1)
                     )
           )
           (ENTMAKE '((0 . "LWPOLYLINE")
                      (100 . "AcDbEntity")
                      (8 . "0")
                      (100 . "AcDbPolyline")
                      (90 . 7)
                      (70 . 0)
                      (43 . 0.0)
                      (38 . 0.0)
                      (39 . 0.0)
                      (10 2.05061 2.05061)
                      (40 . 0.0)
                      (41 . 0.0)
                      (42 . 0.437869)
                      (91 . 0)
                      (10 1.4632 2.02708)
                      (40 . 0.0)
                      (41 . 0.0)
                      (42 . 0.0)
                      (91 . 0)
                      (10 0.0 0.0)
                      (40 . 0.0)
                      (41 . 0.0)
                      (42 . 0.0)
                      (91 . 0)
                      (10 2.02708 1.4632)
                      (40 . 0.0)
                      (41 . 0.0)
                      (42 . 0.437869)
                      (91 . 0)
                      (10 2.05061 2.05061)
                      (40 . 0.0)
                      (41 . 0.0)
                      (42 . 0.0)
                      (91 . 0)
                      (10 3.53553 3.53553)
                      (40 . 0.0)
                      (41 . 0.0)
                      (42 . 0.0)
                      (91 . 0)
                      (10 13.5355 3.53553)
                      (40 . 0.0)
                      (41 . 0.0)
                      (42 . 0.0)
                      (91 . 0)
                     )
           )
           (ENTMAKE '((0 . "ENDBLK")))
    )
    nil
  )
  (SETVAR "OSMODE" 8)
  (IF (OR (NOT g::efpac0173::hf)
          (NOT (NUMBERP g::efpac0173::hf))
          (<= g::efpac0173::hf 0.0)
      )
    (SETQ g::efpac0173::hf 1.0)
  )
  (SETQ
    hf (GETREAL (STRCAT "\n-> Altura da fonte (font height) < " (RTOS g::efpac0173::hf 2 1) " > : "))
  )
  (IF (OR (NOT hf) (NOT (NUMBERP hf)) (<= hf 0))
    (SETQ hf g::efpac0173::hf)
  )
  (SETQ g::efpac0173::hf hf
        attreq (GETVAR "ATTREQ")
        attdia (GETVAR "ATTDIA")
  )
  (SETVAR "ATTREQ" 1)
  (SETVAR "ATTDIA" 0)
  ;;(PRINC "\n-> Tecle algo para encerrar ou posicione o cursor sobre pontos...")
  (princ "\n-> Type a letter for finish or put cursor over points...")
  (WHILE (LISTP (SETQ p1 (CADR (GRREAD 1 5 0))))
    (IF (SETQ e1 (SSGET "C"
                        (LIST (- (CAR p1) 0.001) (- (CADR p1) 0.001) (CADDR p1))
                        (LIST (+ (CAR p1) 0.001) (+ (CADR p1) 0.001) (CADDR p1))
                        (LIST (CONS 0 "POINT"))
                 )
        )
      (PROGN
        (SETQ e1 (ENTGET (SSNAME e1 0))
              p1 (CDR (ASSOC 10 e1))
              p3 (MAPCAR '+ '(5 5 0) p1)
        )
        (IF (NOT (SSGET "x" (LIST (CONS 0 "INSERT") (CONS 2 "EfPac0173") (CONS 10 p1))))
          (COMMAND "_.-INSERT"
                   "EfPac0173"
                   "_NON"
                   p1
                   g::efpac0173::hf
                   g::efpac0173::hf
                   0.0
                   (STRCAT "N=" (RTOS (CADR p1) 2 3))
                   (STRCAT "L=" (RTOS (CAR p1) 2 3))
                   (STRCAT "E=" (RTOS (CADDR p1) 2 3))
                   (ITOA (SETQ cn (1+ cn)))
          )
        )
      )
    )
  )
  (SETVAR "OSMODE" osmode)
  (SETVAR "ATTREQ" attreq)
  (SETVAR "ATTDIA" attdia)
  (PRINC)
)
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on March 06, 2011, 01:18:51 PM
Efernal,

Please read this (http://www.theswamp.org/index.php?topic=4429.0).
Title: Re: Examples of usage GRREAD - let's share
Post by: stevesfr on March 06, 2011, 01:58:28 PM
;;   wrote by eduardo fernal
;;   02/2011
(DEFUN c:teste (/ p1 e1 hf osmode attreq attdia cn)
.........


Well, I sure can't get this to work! ! ! !
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on March 06, 2011, 02:35:23 PM
It does have a dependence on the TTF file being available.

I have modified it slightly, perhaps try the attached.
Title: Re: Examples of usage GRREAD - let's share
Post by: stevesfr on March 06, 2011, 03:04:12 PM
Lee,
perfect, thank you sir.....
Steve
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on March 06, 2011, 03:32:10 PM
Lee,
perfect, thank you sir.....
Steve

It could probably be streamlined should you have your own 'leader' block to insert, and I would probably opt to use VL to insert the block since entmaking the attribs is quite irritating. Or perhaps reverting back to the 'Insert' command is the easiest way to go.

Of course, the dynamicity could be replaced with just a selection prompt wherein the user could window over a set of points and label them all.
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on March 07, 2011, 10:38:47 AM
You could also use fields within a block to display the coordinates.
Title: Re: Examples of usage GRREAD - let's share
Post by: stevesfr on March 07, 2011, 11:56:19 AM
It does have a dependence on the TTF file being available.

I have modified it slightly, perhaps try the attached.

Lee, one thing puzzles me...  when the program inserts the leader block and you explode it, the attributes are listed as North, East, Elev, and Description.    However before exploding, the attributes are really East, North, Elev and Description.   How did the North and East get reversed ?  I know you math guys think of x and y, but we engineers/surveyors think N and E  (y and x).  How can we get the block to tell the "truth" ?
Steve
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on March 07, 2011, 03:01:08 PM
It does have a dependence on the TTF file being available.

I have modified it slightly, perhaps try the attached.

Lee, one thing puzzles me...  when the program inserts the leader block and you explode it, the attributes are listed as North, East, Elev, and Description.    However before exploding, the attributes are really East, North, Elev and Description.   How did the North and East get reversed ?  I know you math guys think of x and y, but we engineers/surveyors think N and E  (y and x).  How can we get the block to tell the "truth" ?
Steve

That's probably a mistake on my part - I changed the code quite hastily to get it to work for you...

Please try the updated code.
Title: Re: Examples of usage GRREAD - let's share
Post by: stevesfr on March 07, 2011, 04:33:48 PM
Lee,  thanks mate. 
Steve
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on March 07, 2011, 05:16:39 PM
Playing around...

http://www.theswamp.org/index.php?topic=37330.msg423824#msg423824

(http://www.theswamp.org/screens/alanjt/DynamicFillet.gif)

(http://www.theswamp.org/screens/alanjt/DynamicFilletLWPolyline.gif)
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on March 07, 2011, 05:33:42 PM
That looks crazy!  :lol:

Was looking at Evgeniy's example of 'line<45' at the start of the thread, perhaps this might be another way to code it:

Code: [Select]
(defun c:test ( / p l g )
  (if (setq p (getpoint "\nSpecify First Point: "))
    (progn
      (setq l
        (entget
          (entmakex
            (list
              (cons 0 "LINE") (cons 10 (trans p 1 0)) (cons 11 (trans p 1 0))
            )
          )
        )
      )
      (princ "\nSpecify Next Point: ")
      (while (= 5 (car (setq g (grread t 13 0))))
        (entupd
          (cdr
            (assoc -1
              (entmod
                (list (assoc -1 l)
                  (cons 11
                    (trans
                      (polar p (/ pi 4.)
                        (
                          (if
                            (minusp
                              (
                                (lambda ( n )
                                  (- (caddr (trans (cadr g) 1 n)) (caddr (trans p 1 n)))
                                )
                                (polar '(0. 0. 0.) (/ pi 4.) 1.)
                              )
                            )
                            - +
                          )
                          (distance p (cadr g))
                        )
                      )
                      1 0
                    )
                  )
                )
              )
            )
          )
        )
      )
    )
  )
  (princ)
)
Title: Re: Examples of usage GRREAD - let's share
Post by: chlh_jd on March 08, 2011, 05:59:47 AM
hi Goodfellas ,
Have you encountered grread cursor lag, particularly in the drawing which has a large number of TrueType fonts used .
e.g.
Code: [Select]
(defun cs_ENTSEL (STR FILTER / PT SS_NAME area_mid SS old_modemacro)
  (setq old_modemacro (getvar "MODEMACRO"))    
  (if (/= (type STR) 'STR)
    (progn
      (princ "\n变量类型不对,STR应为字符串。\n")
      (eval NIL)
    )
    (progn
      (if (/= (type FILTER) 'list)
(progn
 (princ "\n变量类型不对,FILTER应为表。\n")
 (eval NIL)
)
(progn
 (princ STR)
 (setq PT (grread t 4 2))
 (setq is_go_on t)
 (while (and (/= 3 (car PT))
     (/= 25 (car pt))
     is_go_on
)
   (cond
     ((and (= 2 (car pt))
   (or (= 13 (cadr pt)) (= 32 (cadr pt)))
      ) ;_Enter,Space.
      (setq is_go_on nil)
     )
     ((and (= 2 (car pt))
   (or (= 115 (cadr pt)) (= 83 (cadr pt)))
      ) ;_S set arg.
      (if (dcl_Form_IsActive CS_ODCLINIT)
nil
(c:asd)
      )
      (setq is_go_on t)
     )
     (t
      (progn
(if (= 5 (car PT))
  (progn
    (setq PT (cadr PT))
    (setq SS (ssget PT FILTER)) ;_perhaps this take a lag !
    (if SS_NAME
      (progn
(redraw SS_NAME 4) ;_release high-display .
      )
    )
  ) ;_progn
)
(setq SS_NAME NIL)
(if SS
  (progn
    (setq str (cdr (assoc 1 (entget (ssname SS 0)))))
    (setq SS_NAME (ssname SS 0))
    (redraw SS_NAME 3)
  )
  (setvar "MODEMACRO" old_modemacro)
)
      ) ;_progn
     )
   ) ;_cond
   (setq PT (grread t 4 2))
 ) ;_while
 (setvar "MODEMACRO" old_modemacro)  
 (if (/= 25 (car pt))
   (progn
     (setq PT (cadr PT))
     (setq SS (ssget PT FILTER))
     (if SS_NAME
(redraw SS_NAME 4)
     )
     (setq SS_NAME NIL)
     (if SS
(progn
 (setq SS_NAME (ssname SS 0))
 (list PT SS_NAME)
)
(list PT)
     )
   )
   nil
 )
)
      )
    )
  )
)
for test code
Code: [Select]
(defun c:test (/ en)
  (setq
      en
       (cs_ENTSEL
"\n请选取计算书或配筋文字[设置(S)]:"
'((1
   .
   "G*[-=]*,*[-=]*[-=]*,VT*[-=]*,*%%13[01234]*,N*%%13[01234],*L*,*[xX]*"
  )
 )
       )
    )
  (princ en)
  )

Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on March 08, 2011, 10:16:36 AM
That looks crazy!  :lol:

Was looking at Evgeniy's example of 'line<45' at the start of the thread, perhaps this might be another way to code it:
Nicely done Lee. I  actually coded this just yesterday and was wondering how you could code it to account for the opposite direction.

Code: [Select]
(defun _grAtAngle (pt ang / gr point)
  (while
    (progn (setq gr (grread T 15 0))
           (cond ((eq 5 (car gr)) (redraw) (grdraw pt (polar pt ang (distance pt (cadr gr))) 7 -1) T)
                 ((eq 3 (car gr)) (setq point (cadr gr)) (redraw))
           )
    )
  )
  point
)

Don't think I ever linked these:  http://www.theswamp.org/index.php?topic=33469.0

(http://www.theswamp.org/screens/alanjt/GrFun.gif)
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on March 08, 2011, 10:47:27 AM
Cheers Alan :-)

Perhaps two methods:

Code: [Select]
(defun line<ang ( p a / g )
  (while (= 5 (car (setq g (grread t 13 0)))) (redraw)
    (grdraw p
      (polar p a
        (
          (if
            (minusp
              (
                (lambda ( n )
                  (- (caddr (trans (cadr g) 1 n)) (caddr (trans p 1 n)))
                )
                (polar '(0. 0. 0.) a 1.)
              )
            )
            - +
          )
          (distance p (cadr g))
        )
      )
      -1
    )
  )
  (redraw) (if (listp (cadr g)) (cadr g))
)

Code: [Select]
(defun line<ang ( p a / g )
  (while (= 5 (car (setq g (grread t 13 0)))) (redraw)
    (grdraw p
      (polar p a
        (
          (if (minusp (cos (- (angle p (polar p a 1.)) (angle p (cadr g)))))
            - +
          )
          (distance p (cadr g))
        )
      )
      -1
    )
  )
  (redraw) (if (listp (cadr g)) (cadr g))
)

 :-)
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on March 08, 2011, 10:57:38 AM
Cheers Alan :-)

Perhaps two methods:

Code: [Select]
(defun line<ang ( p a / g )
  (while (= 5 (car (setq g (grread t 13 0)))) (redraw)
    (grdraw p
      (polar p a
        (
          (if
            (minusp
              (
                (lambda ( n )
                  (- (caddr (trans (cadr g) 1 n)) (caddr (trans p 1 n)))
                )
                (polar '(0. 0. 0.) a 1.)
              )
            )
            - +
          )
          (distance p (cadr g))
        )
      )
      -1
    )
  )
  (redraw) (if (listp (cadr g)) (cadr g))
)

Code: [Select]
(defun line<ang ( p a / g )
  (while (= 5 (car (setq g (grread t 13 0)))) (redraw)
    (grdraw p
      (polar p a
        (
          (if (minusp (cos (- (angle p (polar p a 1.)) (angle p (cadr g)))))
            - +
          )
          (distance p (cadr g))
        )
      )
      -1
    )
  )
  (redraw) (if (listp (cadr g)) (cadr g))
)

 :-)
Care to explain the method/math? I *think* I get the cosine one, but I'm not 100% and I don't understand the trans one at all.
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on March 08, 2011, 11:15:02 AM
Care to explain the method/math? I *think* I get the cosine one, but I'm not 100% and I don't understand the trans one at all.

For the Cosine one, I use the angle enclosed by a unit vector (call it 'u') from the basepoint at angle 'a', and the vector formed by the basepoint and cursor position (call it 'v'), with the angle measured anticlockwise from vector 'v' to vector 'u'. For quadrants where the cursor lies above the vector perpendicular to vector 'u', the angle enclosed is either < pi/2 or > 3pi/2, and for those quadrants where the cursor lies below, the angle is pi/2 < ang < 3pi/2. I then use the fact that the cosine function changes sign for these intervals.

For the 'trans' method, I define a coordinate system whose normal is in the direction of vector 'u', then I take the elevation of the cursor position relative to the base point as defined in this new coordinate system, should the difference be negative, the cursor lies in the quadrants below the vector perpendicular to vector 'u', else it lies above.

Quick Diagram (don't have too much time atm):

(http://www.theswamp.org/screens/leemac/CursorPosition.png)

Hope this is somewhat clear  :|

Lee
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on March 08, 2011, 12:39:30 PM
OK, I understand the cosine one. The trans one is a little beyond me - haven't spent much time messing with trans, other than the norm (no pun intended), but I'm going to study it some more. Thanks, Lee.
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on March 08, 2011, 01:44:21 PM
You're welcome Alan.
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on March 08, 2011, 02:48:36 PM
My above explanation regarding the 'trans' method was quite poor, so I have spent some time constructing a diagram that will hopefully explain the method with more clarity.

I shall link you to the image, since it is rather large for the post:

Trans Diagram (http://www.theswamp.org/screens/leemac/TransDiagram.png)

The part of the code we are concerned with is:

Code: [Select]
(
  (lambda ( n )
    (- (caddr (trans (cadr g) 1 n)) (caddr (trans p 1 n)))
  )
  (polar '(0. 0. 0.) a 1.)
)

On my diagram I have labelled the Base Point ['p' in the code], and a diagrammatic cursor represents the Cursor Position ['(cadr g)' in the code]. The WCS is shown in cyan in the diagram.

Now, I define a coordinate system with Normal vector at an angle 'a' to the WCS X-Axis, this coordinate system I have shown in green. The normal vector in the code is the unit vector:

Code: [Select]
(polar '(0. 0. 0.) a 1.)
For WCS this vector would be '(0.0 0.0 1.0).

In this coordinate system, just need to check the difference in elevation (Z-Value) between the Cursor position (transformed to be relative to the new Coordinate System) and the Base Point (also transformed to be expressed relative to the new Coordinate System). These elevations are shown in dashed red in the diagram.

Hence, as shown in the code:

Code: [Select]
(- (caddr (trans (cadr g) 1 n)) (caddr (trans p 1 n)))
I subtract the Z-Coordinate of the transformed Cusor Position from the Z-Coordinate of the transformed Base Point, if negative, the cursor is below the X-Axis of the defined coordinate system, and hence the direction needs to be reversed.

I hope this is clearer - if you have any questions, just ask.

Lee
Title: Re: Examples of usage GRREAD - let's share
Post by: chlh_jd on March 08, 2011, 07:35:06 PM
hi
another use just for fun .
Code: [Select]
(defun fe-follow-mouse (_sset / pos_mouse pt_mouse pt)
  ;;(command "_.copy" _sset "" (list 0 0 0) (list 0 0 0))
  (setvar "OSMODE" 0)
  (command)
  (setq pt (cadr (grread t 1 0)))
  (while (= (car (setq pos_mouse (grread t 1 0))) 5)
    (setq pt_mouse (cadr pos_mouse))
    (command "_.move" _sset "" pt pt_mouse)
    (setq pt pt_mouse)
  )
)
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on March 09, 2011, 08:38:37 AM
For OSnap etc, you might like to look at acet-ss-drag-move (http://www.theswamp.org/index.php?topic=36515.msg415112#msg415112), although this is outside the intention of this 'grread' oriented thread.
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on March 09, 2011, 08:53:20 AM
For OSnap etc, you might like to look at acet-ss-drag-move (http://www.theswamp.org/index.php?topic=36515.msg415112#msg415112), although this is outside the intention of this 'grread' oriented thread.
Still a useful sub.
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on March 09, 2011, 08:57:25 AM
BTW was my last explanation clearer for you?
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on March 09, 2011, 08:59:07 AM
BTW was my last explanation clearer for you?
I didn't even see that one, have to give it a read.
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on March 09, 2011, 09:57:21 AM
One more:

Code: [Select]
(defun ucsline ( p a / g )
  (while (= 5 (car (setq g (grread t 13 0)))) (redraw) (setq g (cadr g))
    (grdraw p
      (apply 'polar
        (cons p
          (
            (lambda ( n / x z )
              (setq x (- (car   (trans g 1 n)) (car   (trans p 1 n)))
                    z (- (caddr (trans g 1 n)) (caddr (trans p 1 n)))
              )
              (if (< (abs z) (abs x)) (list (+ a (/ pi 2.)) x) (list a z))
            )
            (polar '(0. 0. 0.) a 1.0)
          )
        )
      )
      -1
    )
  )
  (redraw) (if (listp (cadr g)) (cadr g))
)

Code: [Select]
(ucsline (getpoint "\nBase Point: ") (/ pi 6.))
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on March 09, 2011, 10:06:53 AM
You should change this line so the point is only return if the user left-clicks - matches actual functionality of AutoCAD.

Code: [Select]
(if (and (listp (cadr g)) (eq 3 (car g))) (cadr g))
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on March 09, 2011, 10:15:46 AM
You should change this line so the point is only return if the user left-clicks - matches actual functionality of AutoCAD.

Code: [Select]
(if (and (listp (cadr g)) (eq 3 (car g))) (cadr g))

Does it not already have that behaviour?
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on March 09, 2011, 10:16:53 AM
Another more realistic example:

Code: [Select]
(defun c:test ( / p g a ) (setq a (angle '(0. 0. 0.) (trans (getvar 'UCSXDIR) 0 1 t)))
 
  (if (setq p (getpoint "\nSpecify First Point: "))
    (while (or (= 5 (car (setq g (grread t 15 0)))) (= 2 (car g))) (redraw) (setq g (cadr g))
      (if (listp g)
        (grdraw p
          (if (zerop (getvar 'ORTHOMODE)) g
            (apply 'polar
              (cons p
                (
                  (lambda ( n / x z )
                    (setq x (- (car   (trans g 1 n)) (car   (trans p 1 n)))
                          z (- (caddr (trans g 1 n)) (caddr (trans p 1 n)))
                    )
                    (if (< (abs z) (abs x)) (list (+ a (/ pi 2.)) x) (list a z))
                  )
                  (polar '(0. 0. 0.) a 1.0)
                )
              )
            )
          )
          -1
        )
        (if (= 15 g) (setvar 'ORTHOMODE (- 1 (getvar 'ORTHOMODE))))
      )     
    )
  )
  (redraw) (if (listp (cadr g)) (cadr g))
)
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on March 09, 2011, 10:18:04 AM
You should change this line so the point is only return if the user left-clicks - matches actual functionality of AutoCAD.

Code: [Select]
(if (and (listp (cadr g)) (eq 3 (car g))) (cadr g))

Does it not already have that behaviour?
Nevermind, I'm retarded. :ugly:
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on March 10, 2011, 08:05:49 PM
A recent addition for the thread  :-)

(http://www.theswamp.org/screens/leemac/IsoText.gif)

http://www.theswamp.org/index.php?topic=37429.msg424402#msg424402 (http://www.theswamp.org/index.php?topic=37429.msg424402#msg424402)
Title: Re: Examples of usage GRREAD - let's share
Post by: chlh_jd on March 11, 2011, 11:48:43 AM
hi all
here's draw a leader , it's so simple
Code: [Select]
;;;to draw a leader and change the direction  with mouse move
;;;by GSLS(SS)
(defun c:ss_JT (/ pt1 pt2 pt3 pt is_back0 is_go_on en en1)
  (svos) 
  (setvar 'cmdecho 0)
  (setvar 'PICKSTYLE 0)
  (setq pt1 (getpoint))
  (setq pt2 (getpoint pt1))
  (entmake (list (cons 0 "LINE") (cons 10 pt1) (cons 11 pt2)))
  (setq en1 (entlast))
  (redraw en1 3)
  (setq pt3 (getpoint pt2))
  (draw-pline
    (list pt1 pt2 (polar pt3 (angle pt3 pt2) 450) pt3) ;_here you can change the Neck Point Distance '450'
    '((0.0 0.0) (0.0 0.0) (150.0 0.0) (0.0 0.0)); here you can change the Neck Width '150.0'
    nil
    nil
    -1
    0
  )
  (setq en (entlast))
  (redraw en 3)
  (entdel en1)
  (setq pt (grread t 4 2))
  (setq is_back0
(if (< (distance (cadr pt) pt3) (distance (cadr pt) pt1))
   1
   -1
)
is_go_on T
  )
  (while (and (/= 3 (car PT))
      (/= 25 (car pt))
      is_go_on
)
    (cond
      ((and (= 2 (car pt)) (or (= 13 (cadr pt)) (= 32 (cadr pt)))) ;_Space or Enter
       (setq is_go_on nil)
       (setq is_back
      (if
(< (distance (cadr pt) pt3) (distance (cadr pt) pt1))
1
-1
      )
       )
       (if (< (* is_back0 is_back) 0)
(progn (entdel en)
(if (= is_back 1)
  (draw-pline
    (list pt1 pt2 (polar pt3 (angle pt3 pt2) 450) pt3)
    '((0.0 0.0) (0.0 0.0) (150.0 0.0) (0.0 0.0))
    nil
    nil
    -1
    0
  )
  (draw-pline
    (list pt1 (polar pt1 (angle pt1 pt2) 450) pt2 pt3)
    '((0.0 150.0) (0.0 0.0) (0.0 0.0) (0.0 0.0))
    nil
    nil
    -1
    0
  )
)
   (setq en (entlast))
           (redraw en 4)
)
       )       
      )
      (t
       (setq is_back
      (if
(< (distance (cadr pt) pt3) (distance (cadr pt) pt1))
1
-1
      )
       )
       (if (< (* is_back0 is_back) 0)
(progn (entdel en)
(if (= is_back 1)
  (draw-pline
    (list pt1 pt2 (polar pt3 (angle pt3 pt2) 450) pt3)
    '((0.0 0.0) (0.0 0.0) (150.0 0.0) (0.0 0.0))
    nil
    nil
    -1
    0
  )
  (draw-pline
    (list pt1 (polar pt1 (angle pt1 pt2) 450) pt2 pt3)
    '((0.0 150.0) (0.0 0.0) (0.0 0.0) (0.0 0.0))
    nil
    nil
    -1
    0
  )
)
(setq en (entlast))
(redraw en 3)
)
       )
       (setq is_back0 is_back)
      )
    ) ;_cond
    (setq PT (grread t 4 2))
  )
  (redraw en 4) 
  (clos)
  (princ)
)
;;;Error-handing
  (defun ss-errexit (msg)
    (command)
    (command)
    (if (or (= msg "Function cancelled")
    (= msg "quit / exit abort")
)
      (princ msg)
      (princ (strcat "\n错误: " msg))
    )
    (clos)
  ) 
;;;save old sysvar
(defun svos ()
  (setq #system#    '("OSMODE"      "ORTHOMODE"    "CLAYER"
      "CECOLOR"      "PLINEWID"     "CELTYPE"
      "CMDECHO"      "ELEVATION"    "PICKSTYLE"
     )
#vlale#     (mapcar 'getvar #system#)
gsls_olderr *error*
*error*     ss-errexit
  )
  (vla-startundomark
    (vla-get-activedocument (vlax-get-acad-object))
  )
)
;;;---------------------------------------------------------------------;;;
;;;call old sysvar
(defun clos ()
  (vla-EndUndoMark
    (vla-get-ActiveDocument (vlax-get-acad-object))
  )
  (MapCar 'setvar #system# #vlale#)
  (setq *error* gsls_olderr)
)
;;;--------------------------------------------------------------------------------------;;;
;;;drwa-pline                                                                            ;;;
;;;--------------------------------------------------------------------------------------;;;
;;;
;;;function: to make a polyline by code and return ename
;;;
;;;Variants:
;;;pl_list: the points list offered by order
;;;width : 0.0 or num, or a list like ((0.0 0.0) (0.0 20) (20 0.0)...),if nil it will getvar "plinewid" ,
;;;        if it's length noteq d90 then wid41 and wid42 equal to 0.0 .   
;;;d42_lst: 0.0 or num, or nil, if nil or it's length noteq d90 then d42 equal to 0.0 .
;;;
;;;lay_pl: layername, if nil it will getvar "CLAYER"
;;;
;;;color : color number, if it's -1 then getvar "COLOR" ellse set it by the given color number
;;;
;;;Prompt:
;;;If width list or d42_lst list is Exist , it's order must be same to the pl_list,
;;;   otherwise it will take out a wrong polyline .
;;;
;;;Written By GSLS(SS),2010.06.30
;;;
(defun draw-pline
  (pl_list width   d42_lst lay_pl  color   d70
   /    d90    i    wid    d42    wid40
   wid41   en000   pb
  )
  (setq d90 (length pl_list)
pb  '()
i   0
  )
  (cond ((and (listp width)
      (listp d42_lst)
      (= (length width) (length d42_lst) d90)
)
(foreach pt pl_list
   (setq wid   (nth i width)
d42   (nth i d42_lst)
wid40 (car wid)
wid41 (cadr wid)
pb    (append pb
       (list (cons 10 pt)
     (cons 40 wid40)
     (cons 41 wid41)
     (cons 42 d42)
       )
       )
i     (1+ i)
   )
)
)
((and (or (numberp width) (null width))
      (listp d42_lst)
      (= (length d42_lst) d90)
)
(if (null width)
   (setq wid40 (getvar "plinewid")
wid41 (getvar "plinewid")
   )
   (setq wid40 width
wid41 width
   )
)
(foreach pt pl_list
   (setq d42 (nth i d42_lst)
pb  (append pb
     (list (cons 10 pt)
   (cons 40 wid40)
   (cons 41 wid41)
   (cons 42 d42)
     )
     )
i   (1+ i)
   )
)
)
((and (listp width)
      (= (length width) d90)
      (or (null d42_lst) (numberp d42_lst))
)
(if (null d42_lst)
   (setq d42 0.0)
   (setq d42 d42_lst)
)
(foreach pt pl_list
   (setq wid   (nth i width)
wid40 (car wid)
wid41 (cadr wid)
pb    (append pb
       (list (cons 10 pt)
     (cons 40 wid40)
     (cons 41 wid41)
     (cons 42 d42)
       )
       )
i     (1+ i)
   )
)
)
(t
(if (numberp width)
   (setq wid40 width
wid41 width
   )
   (setq wid40 0.0
wid41 0.0
   )
)
(foreach pt pl_list
   (setq pb (append pb
    (list (cons 10 pt)
  (cons 40 wid40)
  (cons 41 wid41)
  (cons 42 0.0)
    )
    )
   )
)
)
  )
  (setq en000 (append (list
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 8
      (if (and lay_pl (/= lay_pl ""))
lay_pl
(getvar "CLAYER")
      )
)
(cons 100 "AcDbPolyline")
(cons 90 d90)
(cons 70 d70)
      )
      pb
      )
  )
  (if (and color (/= -1 color))
    (setq en000 (append en000 (list (cons 62 color))))
  )
  (if (= nil (entmake en000))
    (princ "\nerror:entity-list error.")
  )
  (entlast)
)
Title: Re: Examples of usage GRREAD - let's share
Post by: xiaxiang on March 12, 2011, 05:08:27 AM
hi all
here's draw a leader , it's so simple
Nice work,chlh_jd !
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on March 13, 2011, 01:54:57 PM
I use this very simple routine to draw an arrow:
Code: [Select]
(defun c:Arrow (/ a b)
  ;; Draw quick arrow
  ;; Alan J. Thompson
  (if (and (setq a (getpoint "\nSpecify first point: "))
           (setq b (getpoint a "\nSpecity next point: "))
      )
    (command "_.leader" "_non" a "_non" b "" "" "_N")
  )
  (princ)
)
but chlh_jd and boredom inspired me to write these...

Code: [Select]
(defun c:Arrow (/ _group _dist lastentity p1 p2 ent obj gr coords pt)
  ;; Draw quick arrow
  ;; Alan J. Thompson, 03.13.11
  (defun _group (l)
    (if (caddr l)
      (cons (list (car l) (cadr l) (caddr l)) (_group (cdddr l)))
    )
  )

  (defun _dist (a b) (distance (list (car a) (cadr a)) (list (car b) (cadr b))))

  (setq lastentity (entlast))
  (if (and (setq p1 (getpoint "\nSpecify first point: "))
           (setq p2 (getpoint p1 "\nSpecity next point: "))
           (vl-cmdf "_.leader" "_non" p2 "_non" p1 "" "" "_N")
           (not (equal lastentity (setq ent (entlast))))
           (setq obj (vlax-ename->vla-object ent))
      )
    (while (eq 5 (car (setq gr (grread T 15 0))))
      (redraw)
      (grdraw (cadr gr)
              (trans (vlax-curve-getClosestPointTo ent (setq pt (trans (cadr gr) 1 0))) 0 1)
              3
              -1
      )
      (if
        (equal
          (last (setq coords (_group (vlax-get obj 'Coordinates))))
          (car (vl-sort coords (function (lambda (a b) (< (_dist a pt) (_dist b pt))))))
        )
         (vlax-put obj 'Coordinates (apply (function append) (reverse coords)))
      )
      (grdraw (cadr gr) (trans (car coords) 0 1) 1 -1)
    )
  )
  (redraw)
  (princ)
)

(http://www.theswamp.org/screens/alanjt/Arrow.gif)

and this one for multiple segments (got a little carried away)...
Code: [Select]
(defun c:ArrowM
       (/ _group _getPoints _arrow _closestpt AT:Arrow lastentity AT:Midpoint lst ent obj gr coords)
  ;; Draw Arrow
  ;; Alan J. Thompson, 03.13.11

  (defun _group (l)
    (if (caddr l)
      (cons (list (car l) (cadr l) (caddr l)) (_group (cdddr l)))
    )
  )

  (defun _getPoints (/ lst pt)
    (if (car (setq lst (list (getpoint "\nSpecify first point: "))))
      ((lambda (color)
         (while (setq pt (getpoint (car lst) "\nSpecify next point: "))
           (redraw)
           (mapcar (function (lambda (a b) (and a b (grdraw a b color -1))))
                   (setq lst (cons pt lst))
                   (cdr lst)
           )
           (AT:Arrow (car lst) (angle (cadr lst) (car lst)))
         )
         (redraw)
         lst
       )
        (cdr (assoc 62 (tblsearch "LAYER" (getvar 'CLAYER))))
      )
    )
  )

  (defun _arrow (lst)
    (mapcar
      (function
        (lambda (a b)
          (and a b (AT:Arrow (trans (AT:MidPoint a b) 0 1) (angle (trans b 0 1) (trans a 0 1))))
        )
      )
      lst
      (cdr lst)
    )
  )

  (defun _closestpt (lst p)
    (car (vl-sort lst (function (lambda (a b) (< (distance a p) (distance b p))))))
  )

  (defun AT:Arrow (#Location #Angle / #Size #Point1 #Point2 #Point3)
    ;; Display directional arrow
    ;; #Location - arrow placement point
    ;; #Angle - arrow directional angle
    ;; Alan J. Thompson, 04.28.09
    (setq #Size   (* (getvar "viewsize") 0.02)
          #Point1 (polar #Location #Angle #Size)
          #Point2 (polar #Location (+ #Angle (* pi 0.85)) #Size)
          #Point3 (polar #Location (+ #Angle (* pi 1.15)) #Size)
    )
    (grvecs (list 4 #Point1 #Point2 #Point2 #Point3 #Point3 #Point1))
    #Location
  )


  (defun AT:Midpoint (p1 p2)
    ;; Midpoint between two points
    ;; Alan J. Thompson, 04.23.09
    (mapcar (function (lambda (a b) (/ (+ a b) 2.))) p1 p2)
  )

  (setq lastentity (entlast))
  (if (and (setq lst (_getPoints))
           (progn (vl-cmdf "_.leader") (foreach p lst (vl-cmdf "_non" p)) (vl-cmdf "" "" "_N"))
           (not (equal lastentity (setq ent (entlast))))
           (setq obj (vlax-ename->vla-object ent))
      )
    (while (eq 5 (car (setq gr (grread T 15 0))))
      (redraw)
      (grdraw (cadr gr) (trans (vlax-curve-getClosestPointTo ent (trans (cadr gr) 1 0)) 0 1) 3 -1)
      (grdraw (cadr gr) (trans (car (setq coords (_group (vlax-get obj 'Coordinates)))) 0 1) 1 -1)
      (_arrow coords)
      (if (equal (last coords) (_closestpt coords (trans (cadr gr) 1 0)))
        (vlax-put obj 'Coordinates (apply (function append) (reverse coords)))
      )
    )
  )
  (redraw)
  (princ)
)

(http://www.theswamp.org/screens/alanjt/ArrowM.gif)
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on March 13, 2011, 01:56:36 PM
Oh yeah, and one for LWPolyline widths...

Code: [Select]
(defun c:PW (/ _width _colorUp _dist AT:SS->List sslst gr p&c wd)
  ;; set LWPolyline Width
  ;; Alan J. Thompson, 03.12.11

  (vl-load-com)

  (defun _width (d w) (entupd (cdr (assoc -1 (entmod (subst (cons 43 w) (assoc 43 d) d))))))

  (defun _colorUp (n)
    (if (> (setq n (+ n 100)) 249)
      1
      n
    )
  )

  (defun _dist (a b) (distance (list (car a) (cadr a)) (list (car b) (cadr b))))

  (defun AT:SS->List (ss vla / i l)
    ;; Convert selection set to list of ename or vla objects
    ;; ss - SSGET selection set
    ;; vla - T for vla objects, nil for ename
    ;; Alan J. Thompson, 04.01.10
    (if (eq (type ss) 'PICKSET)
      (if vla
        (repeat (setq i (sslength ss))
          (setq l (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) l))
        )
        (repeat (setq i (sslength ss)) (setq l (cons (ssname ss (setq i (1- i))) l)))
      )
    )
  )

  (if (setq sslst (AT:SS->List (ssget "_:L" '((0 . "LWPOLYLINE"))) nil))
    (progn (while (eq 5 (car (setq gr (grread T 15 0))))
             (redraw)
             (grdraw
               (cadr gr)
               (car (setq p&c
                           (car
                             (vl-sort
                               (mapcar
                                 (function
                                   (lambda (e / d)
                                     (cons (trans (vlax-curve-getClosestPointTo e (trans (cadr gr) 1 0)) 0 1)
                                           (_colorUp (cond ((cdr (assoc 62 (setq d (entget e)))))
                                                           ((cdr (assoc 62 (tblsearch "LAYER" (cdr (assoc 8 d))))))
                                                     )
                                           )
                                     )
                                   )
                                 )
                                 sslst
                               )
                               (function (lambda (a b) (< (_dist (car a) (cadr gr)) (_dist (car b) (cadr gr)))))
                             )
                           )
                    )
               )
               (cdr p&c)
               -1
             )
             (princ (strcat "\rLWPolyline width: "
                            (rtos (setq wd (* (_dist (cadr gr) (car p&c)) 2.)))
                            "          "
                    )
             )
             (foreach e sslst (_width (entget e) wd))
           )
    )
  )
  (redraw)
  (princ)
)

(http://www.theswamp.org/screens/alanjt/LWPolylineWidth.gif)
Title: Re: Examples of usage GRREAD - let's share
Post by: chlh_jd on March 14, 2011, 01:22:46 AM
Excellent , Alan ! :-)
You have used the better method grdraw to show middle routine . I can learn a lot from your code
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on March 14, 2011, 08:52:18 AM
Excellent , Alan ! :-)
You have used the better method grdraw to show middle routine . I can learn a lot from your code
Enjoy. I had a bit of fun writing it.
Title: Re: Examples of usage GRREAD - let's share
Post by: GDF on March 14, 2011, 03:16:32 PM
Excellent , Alan ! :-)
You have used the better method grdraw to show middle routine . I can learn a lot from your code
Enjoy. I had a bit of fun writing it.

Nice routine.

To activate the PW command grread function, I have to hit the space bar after selecting the polyline.
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on March 14, 2011, 03:19:46 PM
Excellent , Alan ! :-)
You have used the better method grdraw to show middle routine . I can learn a lot from your code
Enjoy. I had a bit of fun writing it.

Nice routine.

To activate the PW command grread function, I have to hit the space bar after selecting the polyline.
Thanks.
Yes, it allows for multiple LWPolyline selection, so you have to right-click/enter/spacebar after selecting all desired LWPolylines.
Title: Re: Examples of usage GRREAD - let's share
Post by: Pad on March 15, 2011, 04:54:59 AM
Thanks for the two leader arrow routines Alan.  Very useful.
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on March 15, 2011, 08:45:58 AM
Thanks for the two leader arrow routines Alan.  Very useful.
Enjoy.  :-)
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on March 30, 2011, 10:51:50 AM
Similar to the new option to 2011 or being able to TAB through a list of ENames like one can TAB through different usable OSnaps in an area.

Code: [Select]
(defun AT:CycleThroughENames (lst / l n i g e)
  ;; Cycle through a list of ENames to choose one
  ;; lst - list of ENames
  ;; Alan J. Thompson, 03.29.11
  (if (>= (setq l (length lst)) 2)
    (progn
      (princ "\n<Tab> to cycle through entities: ")
      (redraw (setq i (nth (setq n 0) lst)) 3)
      (while (progn (setq g (grread nil 10))
                    (cond ((equal g '(2 9))
                           (redraw i 4)
                           (redraw (setq i (nth (setq n (rem (1+ n) l)) lst)) 3)
                           T
                          )
                          ((or (member g '((2 32) (2 13))) (eq (car g) 25)) (redraw (setq e i) 4))
                          (T (redraw i 4))
                    )
             )
      )
      e
    )
    (car lst)
  )
)

EDIT: Minor change to follow a suggestion by Lee.

Test subroutines (and a quick sub to convert the selection set to a list):
Code: [Select]
(defun ss->lst (ss / i l)
  (if (eq (type ss) 'PICKSET)
    (repeat (setq i (sslength ss)) (setq l (cons (ssname ss (setq i (1- i))) l)))
  )
)

(defun c:Test (/ ent)
  (if (setq ent (AT:CycleThroughENames (ss->lst (ssget))))
    (sssetfirst nil (ssadd ent))
  )
  (princ)
)

(defun c:Test2 (/ pt ent)
  (if (and (setq pt (getpoint "\nSpecify point: "))
           (setq ent (AT:CycleThroughENames (ss->lst (ssget "_C" pt pt))))
      )
    (sssetfirst nil (ssadd ent))
  )
  (princ)
)

(http://www.theswamp.org/screens/alanjt/CycleThroughENames.gif)
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on March 30, 2011, 11:18:57 AM
Nice one Alan :-) It reminds me of a snippet I posted here (http://www.theswamp.org/index.php?topic=34065.msg399068#msg399068)  :-)

Looking back at it, it could probably be shortened to just:

Code: [Select]
(defun c:msel ( / ss i l )
  (and
    (setq ss (ssget))
    (setq i -1 l (sslength ss))
    (princ "\nPress Tab to Cycle Through Selection <Exit>: ")
    (while (= 9 (cadr (grread nil 10))) (sssetfirst nil (ssadd (ssname ss (setq i (rem (1+ i) l))))))
  )
  (princ)
)
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on March 30, 2011, 11:58:00 AM
Quote
(rem (1+ i) l)
Clever. :kewl: You've proved me useless.
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on March 30, 2011, 12:19:50 PM
Quote
(rem (1+ i) l)
Clever. :kewl: You've proved me useless.

Thanks Alan  8-)
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on March 30, 2011, 02:11:21 PM
These would probably make more sense. I was getting caught up in worrying with it only returning an EName if the user right-clicked, hit enter or the spacebar, but that's kind of silly. If they selected the objects, they're bound to want to, regardless...

Code: [Select]
(defun AT:CycleThroughENames (lst / l i n)
  (if (>= (setq l (length lst)) 2)
    (progn (princ "\n<Tab> to cycle through entities: ")
           (redraw (setq i (nth (setq n 0) lst)) 3)
           (while (eq (cadr (grread nil 10)) 9)
             (mapcar 'redraw (list i (setq i (nth (setq n (rem (1+ n) l)) lst))) '(4 3))
           )
           (redraw i 4)
           i
    )
    (car lst)
  )
)



(defun AT:CycleThroughSS (ss / l i e)
  (if (eq (type ss) 'PICKSET)
    (if (eq (setq l (sslength ss)) 1)
      (ssname ss 0)
      (progn (princ "\n<Tab> to cycle through entities: ")
             (redraw (setq e (ssname ss (setq i 0))) 3)
             (while (eq (cadr (grread nil 10)) 9)
               (mapcar 'redraw (list e (setq e (ssname ss (setq i (rem (1+ i) l))))) '(4 3))
             )
             (redraw e 4)
             e
      )
    )
  )
)

Thanks for the example to put my head on a little straighter, Lee.
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on March 31, 2011, 07:33:44 AM
Nice one Alan, you're welcome :-)
Title: Re: Examples of usage GRREAD - let's share
Post by: pBe on March 31, 2011, 08:13:22 AM
Question:

Can grread retrieve infos from a "gripped" object?


Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on March 31, 2011, 08:28:21 AM
Can grread retrieve infos from a "gripped" object?

What 'infos' would you be looking to retrieve?

grread is simply a function to monitor user input.
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on March 31, 2011, 08:33:23 AM
Question:

Can grread retrieve infos from a "gripped" object?



You can select the 'gripped' object with (ssget "_I") and extract info from there.
Title: Re: Examples of usage GRREAD - let's share
Post by: pBe on March 31, 2011, 08:40:44 AM
You can select the 'gripped' object with (ssget "_I") and extract info from there.

grread is simply a function to monitor user input.

I understand, just wondering that's all  :-)

Thank you gentlemen
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on March 31, 2011, 08:45:15 AM
Or

Code: [Select]
(cadr (ssgetfirst))
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on March 31, 2011, 08:49:13 AM
Or

Code: [Select]
(cadr (ssgetfirst))
even better.
Title: Re: Examples of usage GRREAD - let's share
Post by: pBe on March 31, 2011, 09:26:21 AM
Or

Code: [Select]
(cadr (ssgetfirst))

Thats how i usually do it. My question really is, telling the object to recognize a lisp routine (not just "query" rouitines) while grips is "hot" , notice the command prompt when you pressed return it changes from ***stretch*** to ***move*** and so forth, i'm just wondering if grread might have a take on that.  anyhoo

thanks and nice thread btw

Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on April 12, 2011, 11:58:16 AM
Wrote a more practical one and thought I'd do a crappy GRREAD example:

Code: [Select]
(defun c:Test (/ _grAngle _ss2lst lst gr pt)

  (vl-load-com)

  (defun _grAngle (a b) (grdraw (trans a 0 1) (cadr gr) 1 -1) (angle a b))

  (defun _ss2lst (ss / i l)
    (if (eq (type ss) 'PICKSET)
      (repeat (setq i (sslength ss))
        (setq l (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) l))
      )
    )
  )

  (if (setq lst (_ss2lst (ssget "_:L" '((0 . "INSERT")))))
    (while (eq 5 (car (setq gr (grread T 15 0))))
      (setq pt (trans (cadr gr) 1 0))
      (redraw)
      (foreach o lst (vla-put-rotation o (_grAngle (vlax-get o 'InsertionPoint) pt)))
    )
  )
  (redraw)
  (princ)
)

(http://www.theswamp.org/screens/alanjt/RotateBlocksToGrReadPoint.gif)
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on April 12, 2011, 12:02:57 PM
That looks fun!  :lol:
Title: Re: Examples of usage GRREAD - let's share
Post by: CAB on April 12, 2011, 12:46:35 PM
Interesting tool Alan. Not sure when I'd use it but you never know. 8-)
In the tool box it goes.
Thanks
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on April 12, 2011, 01:35:17 PM
That looks fun!  :lol:
:-D

Interesting tool Alan. Not sure when I'd use it but you never know. 8-)
In the tool box it goes.
Thanks
Thanks Alan. :) I won't ever use it - no OSnaps. I just thought I'd do a fun one.

Code: [Select]
(defun c:RBP (/ ss pt)
  ;; Rotate Blocks to Point
  ;; Alan J. Thompson
  (if (and (setq ss (ssget "_:L" '((0 . "INSERT"))))
           (setq pt
                  (if (eq 1 (sslength ss))
                    (getpoint (trans (cdr (assoc 10 (entget (ssname ss 0)))) 0 1) "\nSpecify base point: ")
                    (getpoint "\nSpecify base point: ")
                  )
           )
      )
    ((lambda (p)
       (vlax-for x (setq ss (vla-get-activeselectionset
                              (cond (*AcadDoc*)
                                    ((setq *AcadDoc* (vla-get-activedocument
                                                       (vlax-get-acad-object)
                                                     )
                                     )
                                    )
                              )
                            )
                   )
         (vla-put-rotation x (angle (vlax-get x 'InsertionPoint) p))
       )
       (vla-delete ss)
     )
      (trans pt 1 0)
    )
  )
  (princ)
)
Title: Re: Examples of usage GRREAD - let's share
Post by: kruuger on April 12, 2011, 04:00:13 PM
Wrote a more practical one and thought I'd do a crappy GRREAD example:

Code: [Select]
(defun c:Test (/ _grAngle _ss2lst lst gr pt)

  (vl-load-com)

  (defun _grAngle (a b) (grdraw (trans a 0 1) (cadr gr) 1 -1) (angle a b))

  (defun _ss2lst (ss / i l)
    (if (eq (type ss) 'PICKSET)
      (repeat (setq i (sslength ss))
        (setq l (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) l))
      )
    )
  )

  (if (setq lst (_ss2lst (ssget "_:L" '((0 . "INSERT")))))
    (while (eq 5 (car (setq gr (grread T 15 0))))
      (setq pt (trans (cadr gr) 1 0))
      (redraw)
      (foreach o lst (vla-put-rotation o (_grAngle (vlax-get o 'InsertionPoint) pt)))
    )
  )
  (redraw)
  (princ)
)

(http://www.theswamp.org/screens/alanjt/RotateBlocksToGrReadPoint.gif)
haha, good stuff to learn mr. alanjt  :-)
kruuger
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on April 12, 2011, 04:36:31 PM
haha, good stuff to learn mr. alanjt  :-)
kruuger
enjoy. :)
Title: Re: Examples of usage GRREAD - let's share
Post by: pBe on April 15, 2011, 09:23:43 AM
While trying out GRREAD, I notice cant snap to an object
is it possible to activate running osnap while in grread?


Code: [Select]
(defun c:test (/ CreateList _grAngle adoc Plines obj cnt ent ObjectPointList
           PtAngleList Xpoint gr NewLine
           )
;;; pBe April 2011 ;;;
  (vl-load-com)
  (defun CreateList (p) (setq ObjectPointList (cons (cdr p) ObjectPointList)))
;;; Alanjt ;;;
  (defun _grAngle (a b) (grdraw (trans a 0 1) (cadr gr) 1 -1) (angle a b))
;;;  ;;;
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (if (setq Plines (ssget ":L" '((0 . "LWPOLYLINE"))))
    (progn
      (repeat (setq cnt (sslength Plines))
        (setq obj (ssname Plines (setq cnt (1- cnt)))
          ent (entget obj))
        (mapcar
          'CreateList
          (vl-remove-if-not '(lambda (x) (= (car x) 10)) ent)
          )
        (ssdel obj Plines)
        )
      (if ObjectPointList
        (progn
;;; Alanjt ;;;
          (while (eq 5 (car (setq gr (grread T 15 0))))
            (setq Xpoint (trans (cadr gr) 1 0))
            (redraw)
            (foreach pts ObjectPointList (_grAngle pts Xpoint))
            )
;;;                  ;;;
          (redraw)
          (foreach
             itm ObjectPointList
            (setq
              NewLine
               (vla-addline
                 (vlax-get (vla-get-activelayout adoc) 'Block)
                 (vlax-3d-point Xpoint)
                 (vlax-3d-point itm)
                 )
              )
            )
          )
        )
      )
    )
  (princ)
  )

Thanks
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on April 15, 2011, 09:25:40 AM
OSnap, Ortho, Tracking, DynamicInput, etc aren't available when using grRead, instead one must attempt to 'imitate' them:

http://www.theswamp.org/index.php?topic=12813.msg157794#msg157794 (http://www.theswamp.org/index.php?topic=12813.msg157794#msg157794)
Title: Re: Examples of usage GRREAD - let's share
Post by: pBe on April 15, 2011, 09:30:25 AM
Thanks Lee
 :-)
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on April 18, 2011, 04:12:13 PM
Elevation label :)

Textstring field changes when elevation of text object is changed - the object field references itself.

(http://www.theswamp.org/screens/alanjt/ZLBL.gif)

Code: [Select]
(defun c:ZLBL (/ pt txt pt2 gr ang)
  ;; Alan J. Thompson, 04.18.11
  (vl-load-com)
  (if
    (and (setq pt (getpoint "\nSpecify point: "))
         (setq txt (vla-addMText
                     (vlax-get-property
                       (cond (*AcadDoc*)
                             ((setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
                       )
                       (if (eq 1 (getvar 'cvport))
                         'PaperSpace
                         'ModelSpace
                       )
                     )
                     (setq pt2 (vlax-3d-point (trans pt 1 0)))
                     0.
                     ""
                   )
         )
    )
     (progn
       (vla-put-textstring
         txt
         (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                 (itoa (vla-get-objectID txt))
                 ">%).InsertionPoint \\f \"%lu2%pt4%pr2\">%"
         )
       )
       (vla-regen *AcadDoc* acActiveViewport)
       (while (eq 5 (car (setq gr (grread T 15 0))))
         (mapcar
           (function (lambda (p v) (vlax-put-property txt p v)))
           '(Rotation AttachmentPoint InsertionPoint)
           (if (or (<= (setq ang (angle pt (cadr gr))) (/ pi 2.)) (>= ang (* pi 1.5)))
             (list ang 4 pt2)
             (list (+ pi ang) 6 pt2)
           )
         )
       )
     )
  )
  (princ)
)
Title: Re: Examples of usage GRREAD - let's share
Post by: chlh_jd on April 26, 2011, 09:23:22 AM
Hi all , here is a new to use Left (+1) and Right (-1)  mouse button .
how can we changed into mousewheel method forward or backward scroll ?
Code: [Select]
(defun c:test (/ en ent str pt)
  (if (and (setq en (car (entsel "Select Integer Number Text :")))
   (setq ent (entget en))
   (setq str (cdr (assoc 1 ent)))
   (numberp (eval (read str)))
   (equal (atoi str) (atof str))
      )
    (while (and (setq pt (grread t 4 2))
  (not (and (= 2 (car pt))
    (or (= 13 (cadr pt)) (= 32 (cadr pt)))
       )
  ) ;_Enter Space
     )
(cond ((= (car pt) 3);_Mouse Left button
       (setq str (rtos (1+ (atoi str)) 2 0))
       (setq ent (subst (cons 1 str) (assoc 1 ent) ent))
       (entmod ent)
       )
      ((or (= (car pt) 11) (= (car pt) 25));_Mouse Right button
       (setq str (rtos (1- (atoi str)) 2 0))
       (setq ent (subst (cons 1 str) (assoc 1 ent) ent))
       (entmod ent)
       )
      )
    )
    (princ)
  )
  (princ)
)
Title: Re: Examples of usage GRREAD - let's share
Post by: chlh_jd on April 26, 2011, 09:25:02 AM
 is
Code: [Select]
(grread 1 13 1) can be used ?
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on April 26, 2011, 09:47:42 AM
 :lol:

Code: [Select]
(defun c:Test (/ e g l c)
  (if (and (setq e (car (entsel "\nSelect text object: ")))
           (member (cdr (assoc 0 (entget e))) '("MTEXT" "TEXT"))
      )
    (while (eq 5 (car (setq g (grread T 15 0))))
      (cond ((not l) (setq l (cons (cadadr g) l)))
            ((apply 'equal (setq c (list (car (setq l (cons (cadadr g) l))) (cadr l)))))
            ((apply '> c)
             (entmod (list (cons 1 (rtos (1+ (distof (cdr (assoc 1 (entget e))))))) (cons -1 e)))
            )
            ((apply '< c)
             (entmod (list (cons 1 (rtos (1- (distof (cdr (assoc 1 (entget e))))))) (cons -1 e)))
            )
      )
    )
  )
  (princ)
)
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on April 26, 2011, 09:50:11 AM
Nice idea Alan :-)

This was my take:

Code: [Select]
(defun c:test ( / c e f i l s ss )
  (if
    (and (setq ss (ssget "_:L" '((0 . "TEXT"))))
      (progn
        (repeat (setq i (sslength ss))
          (setq e (ssname ss (setq i (1- i)))
                s (cdr (assoc 1 (entget e)))
          )                 
          (if (equal (atoi s) (read s)) (setq l (cons e l)) l)
        )
      )
      (princ "\nPress [+/-] to Increment/Decrement text...")
    )
    (while (member (setq c (cadr (grread nil 14 1))) '(43 45 61 95))
      (setq f (if (member c '(45 95)) 1- 1+))

      (foreach e l
        (setq e (entget e))
        (entmod (subst (cons 1 (itoa (f (atoi (cdr (assoc 1 e)))))) (assoc 1 e) e))
      )
    )
  )
  (princ)
)

(http://www.theswamp.org/screens/leemac/IncIntGrRead.gif)
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on April 26, 2011, 09:55:07 AM
Nice idea Alan :-)

This was my take:
Thanks and nice one to you too. :)
Mine isn't practical, but I suppose it shows using the mouse position to edit objects in an unconventional way.
Title: Re: Examples of usage GRREAD - let's share
Post by: chlh_jd on April 26, 2011, 10:00:33 AM
Nice Idea Alan , how to Against mousewheel zoom .
Lee Mac Nice too  .
Thank you a lot .
Code: [Select]
(entmod (list (cons 1 (rtos (1+ (distof (cdr (assoc 1 (entget e))))))) (cons -1 e)))Nice mothod !!!
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on April 26, 2011, 10:06:57 AM
Nice Idea Alan , how to Against mousewheel zoom .
Lee Mac Nice too  .
Thank you a lot .
Beats me dude. I did mine the way I did because of your inquiries into the mouse wheel.

BTW, if you do figure out how to access the state of the wheel, you'll need to disable the wheel acting as a zoom in/out ability.
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on April 26, 2011, 10:08:02 AM
You can't detect mouse-wheel scroll using GrRead and I don't think there is an acet-sys-* function for it  :-(
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on April 26, 2011, 10:09:00 AM
You can't detect mouse-wheel scroll using GrRead and I don't think there is an acet-sys-* function for it  :-(
Probably has to do with GRREAD being created before the mouse had a wheel. :-P
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on April 26, 2011, 10:10:24 AM
You can't detect mouse-wheel scroll using GrRead and I don't think there is an acet-sys-* function for it  :-(
Probably has to do with GRREAD being created before the mouse had a wheel. :-P

 :-D
Title: Re: Examples of usage GRREAD - let's share
Post by: chlh_jd on April 26, 2011, 10:15:07 AM
Thanks Alan , Thanks Lee   :angel:
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on April 26, 2011, 10:19:27 AM
Thank Alan , Thank Lee   :angel:
Thank you Lee.  :lol:


Title: Re: Examples of usage GRREAD - let's share
Post by: chlh_jd on April 26, 2011, 11:08:17 AM
use type "a s A S" or "d f D F"
Code: [Select]
(defun c:test (/ en ent str pt)
  (if (and (setq en (car (entsel "Select Integer Number Text :")))
   (setq ent (entget en))
   (setq str (cdr (assoc 1 ent)))
   (numberp (eval (read str)))
   (equal (atoi str) (atof str))    
      )
    (while (and (setq pt (grread  t 15 0))
  (not (and (= 2 (car pt))
    (or (= 13 (cadr pt)) (= 32 (cadr pt)))
       )
  ) ;_Enter Space
(not (or (= (car pt) 11) (= (car pt) 25)));_Right button
     )     
(cond ((and (= (car pt) 2) (member (cadr pt) (list 65 83 97 115)));_type "a s A S"
       (setq str (rtos (1+ (atoi str)) 2 0))
       (setq ent (subst (cons 1 str) (assoc 1 ent) ent))
       (entmod ent)
       )
      ((and (= (car pt) 2) (member (cadr pt) (list 68 70 100 102)))        
       (setq str (rtos (1- (atoi str)) 2 0))
       (setq ent (subst (cons 1 str) (assoc 1 ent) ent))
       (entmod ent)
       )      
      )     
    )
    (princ)
  )
  (princ)
)
Title: Re: Examples of usage GRREAD - let's share
Post by: chlh_jd on April 26, 2011, 11:36:43 AM
Add viesize control .
Code: [Select]
;;;use Alan method
;;;to easy to control add method devided by viewsize .
(defun c:test (/ en ent str ds pto pt)
  (if (and (setq en (car (entsel "Select Integer Number Text :")))
   (setq ent (entget en))
   (setq str (cdr (assoc 1 ent)))
   (numberp (eval (read str)))
   (equal (atoi str) (atof str))
   (setq ds (/ (getvar "viewsize") 100.));_here can be changed cond to your need
   (setq pto (grread t 15 0))
      )
    (while (and (setq pt (grread pto))
(not (and (= 2 (car pt))
  (or (= 13 (cadr pt)) (= 32 (cadr pt)))
     )
) ;_Enter Space
(not (or (= (car pt) 11) (= (car pt) 25))) ;_Right button
   )
      (if (and (= (car pt) 5)
       (> (abs (- (cadadr pt) (cadadr pto))) ds)        
  )
(cond
  ((> (- (cadadr pt) (cadadr pto)) 0);_Y+ move   
   (setq str (rtos (1+ (atoi str)) 2 0))
   (entmod (list (cons 1 str) (cons -1 en)))    
   (setq pto pt)
  )
  ((< (- (cadadr pt) (cadadr pto)) 0);_Y- move
   (setq str (rtos (1- (atoi str)) 2 0))
   (entmod (list (cons 1 str) (cons -1 en)))
   (setq pto pt)
  )
)
(princ)
      )
    )
    (princ)
  )
  (princ)
)
Title: Re: Examples of usage GRREAD - let's share
Post by: m4rdy on April 26, 2011, 11:43:20 AM
use type "a s A S" or "d f D F"
Code: [Select]
(defun c:test (/ en ent str pt)
  (if (and (setq en (car (entsel "Select Integer Number Text :")))
   (setq ent (entget en))
   (setq str (cdr (assoc 1 ent)))
   (numberp (eval (read str)))
   (equal (atoi str) (atof str))    
      )
    (while (and (setq pt (grread  t 15 0))
  (not (and (= 2 (car pt))
    (or (= 13 (cadr pt)) (= 32 (cadr pt)))
       )
  ) ;_Enter Space
(not (or (= (car pt) 11) (= (car pt) 25)));_Right button
     )     
(cond ((and (= (car pt) 2) (member (cadr pt) (list 65 83 97 115)));_type "a s A S"
       (setq str (rtos (1+ (atoi str)) 2 0))
       (setq ent (subst (cons 1 str) (assoc 1 ent) ent))
       (entmod ent)
       )
      ((and (= (car pt) 2) (member (cadr pt) (list 68 70 100 102)))        
       (setq str (rtos (1- (atoi str)) 2 0))
       (setq ent (subst (cons 1 str) (assoc 1 ent) ent))
       (entmod ent)
       )      
      )     
    )
    (princ)
  )
  (princ)
)

Nothing happened.

m4rdy
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on April 26, 2011, 12:59:40 PM
Keep in mind that I didn't do any checks (as Lee did) because it was a crappy example and I just didn't really care. (http://www.myemoticons.com/images/communicate/insults/lazy-good-for-nothin-.gif)
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on May 28, 2011, 11:01:58 AM
Updated some old code :-)

Program will now work in all UCS/Views  :-)

(http://www.lee-mac.com/files/Cam.gif)
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on July 14, 2011, 08:27:48 PM
Some fun with GrRead following a thread at CT:

Dynamic Horizontal Lines:

(http://www.theswamp.org/lilly_pond/leemac/hlines.gif)

Code: [Select]
(defun c:hlines ( / *error* g1 g2 gr h l ms p p1 p2 v )
  ;; Lee Mac 2011
  (defun *error* ( m ) (redraw) (princ))
  (or *n (setq *n 3))
 
  (if (setq p1 (getpoint "\nSpecify First Corner: "))
    (progn
      (setq ms (princ "\nSpecify Opposite Corner [+/-]: "))
      (while
        (progn (setq gr (grread t 15 0) g1 (car gr) g2 (cadr gr))
          (cond
            ( (= 5 g1)(redraw)
              (setq h (- (car g2) (car p1))
                    v (/ (- (cadr g2) (cadr p1)) (1+ *n))
                    p p1
              )
              (repeat *n
                (setq p (list (car p) (+ v (cadr p)) (caddr p)))
                (grdraw p (list (+ (car p) h) (cadr p) (caddr p)) -1)
              )
              (setq l
                (list
                  p1 (list (+ (car p1) h) (cadr p1) (caddr p1))
                  g2 (list (car p) (+ v (cadr p)) (caddr p))
                )
              )
              (mapcar '(lambda ( a b ) (grdraw a b 1 -1)) l (append (cdr l) (list (car l))))
            )
            ( (= 2 g1)
              (cond
                ( (member g2 '(45 95))
                  (if (= 1 *n)
                    (princ (strcat "\n--> Minimum Number of Lines Reached." ms))
                    (setq *n (1- *n))
                  )
                )
                ( (member g2 '(43 61))
                  (setq *n (1+ *n))
                )
              )
            )
            ( (= 3 g1)
              (setq h (- (car g2) (car p1))
                    v (/ (- (cadr g2) (cadr p1)) (1+ *n))
              )
              (repeat *n (setq p1 (list (car p1) (+ v (cadr p1)) (caddr p1)))
                (entmakex
                  (list
                    (cons 0 "LINE")
                    (cons 10 (trans p1 1 0))
                    (cons 11 (trans (list (+ (car p1) h) (cadr p1) (caddr p1)) 1 0))
                  )
                )
              )
              nil
            )
          )
        )
      )
    )
  )
  (redraw) (princ)
)

Dynamic Vertical Lines:

(http://www.theswamp.org/lilly_pond/leemac/vlines.gif)

Code: [Select]
(defun c:vlines ( / *error* g1 g2 gr h l ms p p1 p2 v )
  ;; Lee Mac 2011
  (defun *error* ( m ) (redraw) (princ))
  (or *n (setq *n 3))
 
  (if (setq p1 (getpoint "\nSpecify First Corner: "))
    (progn
      (setq ms (princ "\nSpecify Opposite Corner [+/-]: "))
      (while
        (progn (setq gr (grread t 15 0) g1 (car gr) g2 (cadr gr))
          (cond
            ( (= 5 g1)(redraw)
              (setq h (/ (- (car g2) (car p1)) (1+ *n))
                    v (- (cadr g2) (cadr p1))
                    p p1
              )
              (repeat *n
                (setq p (list (+ h (car p)) (cadr p) (caddr p)))
                (grdraw p (list (car p) (+ v (cadr p)) (caddr p)) -1)
              )
              (setq l
                (list
                  p1 (list (car p1) (+ v (cadr p1)) (caddr p1))
                  g2 (list (+ h (car p)) (cadr p) (caddr p))
                )
              )
              (mapcar '(lambda ( a b ) (grdraw a b 1 -1)) l (append (cdr l) (list (car l))))
            )
            ( (= 2 g1)
              (cond
                ( (member g2 '(45 95))
                  (if (= 1 *n)
                    (princ (strcat "\n--> Minimum Number of Lines Reached." ms))
                    (setq *n (1- *n))
                  )
                )
                ( (member g2 '(43 61))
                  (setq *n (1+ *n))
                )
              )
            )
            ( (= 3 g1)
              (setq h (/ (- (car g2) (car p1)) (1+ *n))
                    v (- (cadr g2) (cadr p1))
              )
              (repeat *n (setq p1 (list (+ h (car p1)) (cadr p1) (caddr p1)))
                (entmakex
                  (list
                    (cons 0 "LINE")
                    (cons 10 (trans p1 1 0))
                    (cons 11 (trans (list (car p1) (+ v (cadr p1)) (caddr p1)) 1 0))
                  )
                )
              )
              nil
            )
          )
        )
      )
    )
  )
  (redraw) (princ)
)

Combining the two...

(http://www.theswamp.org/lilly_pond/leemac/hvlines.gif)

Code: [Select]
(defun c:hvlines ( / *error* g1 g2 gr h l ms p p1 p2 v )
  ;; Lee Mac 2011
  (defun *error* ( m ) (redraw) (princ))
  (or *n (setq *n 3))
 
  (if (setq p1 (getpoint "\nSpecify First Corner: "))
    (progn
      (setq ms (princ "\nSpecify Opposite Corner [TAB/+/-]: "))
      (while
        (progn (setq gr (grread t 15 0) g1 (car gr) g2 (cadr gr))
          (cond
            ( (= 5 g1)(redraw)
              (if *v
                (progn
                  (setq h (/ (- (car g2) (car p1)) (1+ *n))
                        v (- (cadr g2) (cadr p1))
                        p p1
                  )
                  (repeat *n
                    (setq p (list (+ h (car p)) (cadr p) (caddr p)))
                    (grdraw p (list (car p) (+ v (cadr p)) (caddr p)) -1)
                  )
                  (setq l
                    (list
                      p1 (list (car p1) (+ v (cadr p1)) (caddr p1))
                      g2 (list (+ h (car p)) (cadr p) (caddr p))
                    )
                  )
                )
                (progn
                  (setq h (- (car g2) (car p1))
                        v (/ (- (cadr g2) (cadr p1)) (1+ *n))
                        p p1
                  )
                  (repeat *n
                    (setq p (list (car p) (+ v (cadr p)) (caddr p)))
                    (grdraw p (list (+ (car p) h) (cadr p) (caddr p)) -1)
                  )
                  (setq l
                    (list
                      p1 (list (+ (car p1) h) (cadr p1) (caddr p1))
                      g2 (list (car p) (+ v (cadr p)) (caddr p))
                    )
                  )
                )
              )                 
              (mapcar '(lambda ( a b ) (grdraw a b 1 -1)) l (append (cdr l) (list (car l))))
            )
            ( (= 2 g1)
              (cond
                ( (member g2 '(45 95))
                  (if (= 1 *n)
                    (princ (strcat "\n--> Minimum Number of Lines Reached." ms))
                    (setq *n (1- *n))
                  )
                )
                ( (member g2 '(43 61))
                  (setq *n (1+ *n))
                )
                ( (= 9 g2)
                  (setq *v (not *v)) t
                )
              )
            )
            ( (= 3 g1)
              (if *v
                (progn
                  (setq h (/ (- (car g2) (car p1)) (1+ *n))
                        v (- (cadr g2) (cadr p1))
                  )
                  (repeat *n (setq p1 (list (+ h (car p1)) (cadr p1) (caddr p1)))
                    (entmakex
                      (list
                        (cons 0 "LINE")
                        (cons 10 (trans p1 1 0))
                        (cons 11 (trans (list (car p1) (+ v (cadr p1)) (caddr p1)) 1 0))
                      )
                    )
                  )
                )
                (progn
                  (setq h (- (car g2) (car p1))
                        v (/ (- (cadr g2) (cadr p1)) (1+ *n))
                  )
                  (repeat *n (setq p1 (list (car p1) (+ v (cadr p1)) (caddr p1)))
                    (entmakex
                      (list
                        (cons 0 "LINE")
                        (cons 10 (trans p1 1 0))
                        (cons 11 (trans (list (+ (car p1) h) (cadr p1) (caddr p1)) 1 0))
                      )
                    )
                  )
                )
              )
              nil
            )
          )
        )
      )
    )
  )
  (redraw) (princ)
)

 :-)
Title: Re: Examples of usage GRREAD - let's share
Post by: myloveflyer on July 14, 2011, 11:55:23 PM
Cool,LEE :-D
Title: Re: Examples of usage GRREAD - let's share
Post by: kruuger on July 15, 2011, 03:33:56 AM
good example Lee.
more lines to reveiw :)
kruuger
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on July 15, 2011, 07:06:33 AM
Thanks guys  :-)
Title: Re: Examples of usage GRREAD - let's share
Post by: Ketxu on September 14, 2011, 12:57:58 PM
Wrote a more practical one and thought I'd do a crappy GRREAD example:

Code: [Select]
(defun c:Test (/ _grAngle _ss2lst lst gr pt)

  (vl-load-com)

  (defun _grAngle (a b) (grdraw (trans a 0 1) (cadr gr) 1 -1) (angle a b))

  (defun _ss2lst (ss / i l)
    (if (eq (type ss) 'PICKSET)
      (repeat (setq i (sslength ss))
        (setq l (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) l))
      )
    )
  )

  (if (setq lst (_ss2lst (ssget "_:L" '((0 . "INSERT")))))
    (while (eq 5 (car (setq gr (grread T 15 0))))
      (setq pt (trans (cadr gr) 1 0))
      (redraw)
      (foreach o lst (vla-put-rotation o (_grAngle (vlax-get o 'InsertionPoint) pt)))
    )
  )
  (redraw)
  (princ)
)

(http://www.theswamp.org/screens/alanjt/RotateBlocksToGrReadPoint.gif)
I like thi motion, so i change a little to do with almost object type. With vla-rotate, Lines like ceiling fans ^^

Code: [Select]
(defun _grAngle (a b) (grdraw (trans a 0 1) (cadr gr) 1 -1) (angle a b))
(defun _Bound-Center (ent opt / p1 p2 _ent eType mid)
;Get center boundingbox of object. If opt, choice InsertionPoint instead of
(setq  eType (cdadr (entget (vlax-vla-object->ename ent))))
(setq mid (cond ((and opt  (wcmatch eType "INSERT,TEXT,MTEXT"))
(vlax-get ent 'InsertionPoint))
(T
(vla-getboundingbox ent 'p1 'p2)
(mapcar  '(lambda (a b) (* 0.5 (+ a b)))
(vlax-safearray->list p1) (vlax-safearray->list p2))
)
)
))
(defun c:Test1 (/ lst gr pt SelSet)
(vl-load-com)
  (if (and (setq lst (ssget "_:L"))
(setq SelSet (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-acad-object)))))
    (while (eq 5 (car (setq gr (grread T 15 0))))
      (setq pt (trans (cadr gr) 1 0))
      (redraw)
      (vlax-for object Selset (vla-rotate object (vlax-3d-point (_Bound-Center object nil)) (_grAngle (_Bound-Center object nil) pt)))
    )
  )
  (redraw)
  (princ)
)
 
(defun c:Test2 (/ lst gr pt SelSet)
(vl-load-com)
  (if (and (setq lst (ssget "_:L"))
(setq SelSet (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-acad-object)))))
    (while (eq 5 (car (setq gr (grread T 15 0))))
      (setq pt (trans (cadr gr) 1 0))
      (redraw)
      (vlax-for object Selset (vla-rotate object (vlax-3d-point (_Bound-Center object T)) (_grAngle (_Bound-Center object T) pt)))
    )
  )
  (redraw)
  (princ)
)
Title: Re: Examples of usage GRREAD - let's share
Post by: Hugo on December 20, 2011, 02:49:27 PM
Please Help

When I broke off the Lisp if I want to rotate the text.
Thank you

Bitte um Hilfe

Bei mir bricht das Lisp ab wenn ich den Text drehen will.
Danke

Quote
(defun c:THZ ( / e i j ) (vl-load-com) (setq i (/ pi 2.) j -1.);;-1.
      (setq e (entsel "\nText wählen: "))
             (setq el1 (entget (car e)))
             (setq p0 (cdr (assoc 10 el1)))
             (setq muster (cdr (assoc 1 el1)))
    (while (setq p1 (getpoint p0  "\nText anschreiben: "))
      (progn
   (setq p0 p1)
         (setq txt (umw_muster (cdr (assoc 1 el1))))
          (setq el1 (subst (cons 1 txt) (assoc 1 el1) el1))
          (setq el1 (subst (cons 10 p1) (assoc 10 el1) el1))
          (entmake el1)
   )
      ;; © Lee Mac 2011
      (if
   (and
          (setq e (entlast))
          (eq (vla-get-Objectname (setq e (vlax-ename->vla-object e))) "AcDbText")
          (princ "\nPress [Tab] to Change Projection <Accept>")
        )
        (while (= 9 (cadr (grread nil 12 0)))
           (vla-put-rotation     e i)
           (vla-put-obliqueangle e (setq i (* i (setq j (- j)))))
        )
      )
      )
  )


Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on December 20, 2011, 05:13:58 PM
(http://www.theswamp.org/lilly_pond/alanjt/mleaderarrowheadscale.gif)

Code - Auto/Visual Lisp: [Select]
  1. (defun c:test (/ AT:isAnnotative _grdist ent data bp obj scl gr)
  2.   ;; dynamically scale arrowhead size of selected MLeader
  3.   ;; Alan J. Thompson, 12.17.11
  4.  
  5.  
  6.   (defun AT:isAnnotative (ename / check)
  7.     ;; Check if entity is annotative
  8.     ;; ename - ename to check (returns T if annotative)
  9.     ;; Alan J. Thompson
  10.     (and (setq check (cdr (assoc 360 (entget ename))))
  11.          (setq check (dictsearch check "AcDbContextDataManager"))
  12.          (setq check (dictsearch (cdr (assoc -1 check)) "AcDb_AnnotationScales"))
  13.          (assoc 350 check)
  14.     )
  15.   )
  16.  
  17.   (defun _grdist (b p s) (redraw) (grdraw b p 256 -1) (* (distance b p) s))
  18.  
  19.   (cond
  20.     ((not (setq ent (car (entsel "\nSelect multileader to change arrowhead size: ")))))
  21.     ((not (eq (cdr (assoc 0 (setq data (entget ent)))) "MULTILEADER"))
  22.      (princ "\nInvalid object!")
  23.     )
  24.     (T
  25.      (setq bp  (trans (cdr (assoc 10 (cdr (member (assoc 10 (cdr (member (assoc 10 data) data))) data))))
  26.                       ent
  27.                       1
  28.                )
  29.            obj (vlax-ename->vla-object ent)
  30.            scl (if (AT:isAnnotative ent)
  31.                  (getvar 'CANNOSCALEVALUE)
  32.                  (cdr (assoc 40 data))
  33.                )
  34.      )
  35.  
  36.      (while (eq (car (setq gr (grread T 15 0))) 5)
  37.        (vl-catch-all-apply 'vla-put-arrowheadsize (list obj (_grdist bp (cadr gr) scl)))
  38.      )
  39.     )
  40.   )
  41.  
  42.   (redraw)
  43.   (princ)
  44. )
Title: Re: Examples of usage GRREAD - let's share
Post by: FreeBird on December 22, 2011, 09:48:24 AM
Interface function for grread
Code - Auto/Visual Lisp: [Select]
  1. (setq loop T)
  2. (while loop
  3.   (setq code (grread T 8))
  4.   (cond
  5.     ((= (car code) 5)     (do_Move))               ;;; mouse move
  6.     ((= (car code) 3)     (do_Left))               ;;; mouse left button
  7.     ((= (car code) 11)    (do_Right))              ;;; mouse right button, right button as return
  8.     ((= (car code) 25)    (do_Right))              ;;; mouse right button, right button as screen menu
  9.     ((equal code '(2 0))  (do_CTRL-@))             ;;; CTRL-@
  10.     ((equal code '(2 1))  (do_CTRL-A))             ;;; CTRL-A
  11.     ((equal code '(2 2))  (do_F9))                 ;;; CTRL-B or F9
  12.     ((equal code '(2 3))  (do_F12))                ;;; CTRL-C or F12
  13.     ((equal code '(2 4))  (do_F6))                 ;;; CTRL-D or F6
  14.     ((equal code '(2 5))  (do_F5))                 ;;; CTRL-E or F5
  15.     ((equal code '(2 6))  (do_F3))                 ;;; CTRL-F or F3
  16.     ((equal code '(2 7))  (do_F7))                 ;;; CTRL-G or F7
  17.     ((equal code '(2 8))  (do_Back))               ;;; CTRL-H or backspace
  18.     ((equal code '(2 9))  (do_Tab))                ;;; CTRL-I or Tab
  19.     ((equal code '(2 10)) (do_CTRL-J))             ;;; CTRL-J
  20.     ((equal code '(2 11)) (do_CTRL-K))             ;;; CTRL-K
  21.     ((equal code '(2 12)) (do_CTRL-L))             ;;; CTRL-L
  22.     ((equal code '(2 13)) (do_Return))             ;;; CTRL-M or return
  23.     ((equal code '(2 14)) (do_CTRL-N))             ;;; CTRL-N
  24.     ((equal code '(2 15)) (do_F8))                 ;;; CTRL-O or F8
  25.     ((equal code '(2 16)) (do_CTRL-P))             ;;; CTRL-P
  26.     ((equal code '(2 17)) (do_CTRL-Q))             ;;; CTRL-Q
  27.     ((equal code '(2 18)) (do_CTRL-R))             ;;; CTRL-R
  28.     ((equal code '(2 19)) (do_CTRL-S))             ;;; CTRL-S
  29.     ((equal code '(2 20)) (do_F4))                 ;;; CTRL-T or F4
  30.     ((equal code '(2 21)) (do_F10))                ;;; CTRL-U or F10
  31.     ((equal code '(2 22)) (do_CTRL-V))             ;;; CTRL-V
  32.     ((equal code '(2 23)) (do_F11))                ;;; CTRL-W or F11
  33.     ((equal code '(2 24)) (do_CTRL-X))             ;;; CTRL-X
  34.     ((equal code '(2 25)) (do_CTRL-Y))             ;;; CTRL-Y
  35.     ((equal code '(2 26)) (do_CTRL-Z))             ;;; CTRL-Z
  36.     ((equal code '(2 27)) (do_CTRL-[))             ;;; CTRL-[ or ESC
  37.     ((equal code '(2 28)) (do_CTRL-\))             ;;; CTRL-\
  38.     ((equal code '(2 29)) (do_CTRL-]))             ;;; CTRL-]
  39.     ((equal code '(2 30)) (do_CTRL-^))             ;;; CTRL-^
  40.     ((equal code '(2 31)) (do_CTRL-_))             ;;; CTRL-_
  41.     ((equal code '(2 32)) (do_Space))              ;;; space key
  42.     ((equal code '(2 33)) (do_ExclamationMark))    ;;; ! key
  43.     ((equal code '(2 34)) (do_DoubleQuote))        ;;; " key
  44.     ((equal code '(2 35)) (do_Hash))               ;;; # key
  45.     ((equal code '(2 36)) (do_Dollar))             ;;; $ key
  46.     ((equal code '(2 37)) (do_Percent))            ;;; % key
  47.     ((equal code '(2 38)) (do_Ampersand))          ;;; & key
  48.     ((equal code '(2 39)) (do_Apostrophe))         ;;; ' key
  49.     ((equal code '(2 40)) (do_OpenParenthesis))    ;;;  ( key
  50.     ((equal code '(2 41)) (do_CloseParenthesis))   ;;; ) key
  51.     ((equal code '(2 42)) (do_Asterisk))           ;;; * key
  52.     ((equal code '(2 43)) (do_Plus))               ;;; + key
  53.     ((equal code '(2 44)) (do_Comma))              ;;; , key
  54.     ((equal code '(2 45)) (do_Minus))              ;;; - key
  55.     ((equal code '(2 46)) (do_Dot))                ;;; . key
  56.     ((equal code '(2 47)) (do_Slash))              ;;; / key
  57.     ((equal code '(2 48)) (do_0))                  ;;; 0 key
  58.     ((equal code '(2 49)) (do_1))                  ;;; 1 key
  59.     ((equal code '(2 50)) (do_2))                  ;;; 2 key
  60.     ((equal code '(2 51)) (do_3))                  ;;; 3 key
  61.     ((equal code '(2 52)) (do_4))                  ;;; 4 key
  62.     ((equal code '(2 53)) (do_5))                  ;;; 5 key
  63.     ((equal code '(2 54)) (do_6))                  ;;; 6 key
  64.     ((equal code '(2 55)) (do_7))                  ;;; 7 key
  65.     ((equal code '(2 56)) (do_8))                  ;;; 8 key
  66.     ((equal code '(2 57)) (do_9))                  ;;; 9 key
  67.     ((equal code '(2 58)) (do_Colon))              ;;; : key
  68.     ((equal code '(2 59)) (do_Semicolon))          ;;; ; key
  69.     ((equal code '(2 60)) (do_LessThan))           ;;; < key
  70.     ((equal code '(2 61)) (do_Equals))             ;;; = key
  71.     ((equal code '(2 62)) (do_GreatThan))          ;;; > key
  72.     ((equal code '(2 63)) (do_QuestionMark))       ;;; ? key
  73.     ((equal code '(2 64)) (do_At))                 ;;; @ key
  74.     ((equal code '(2 65)) (do_A))                  ;;; A key
  75.     ((equal code '(2 66)) (do_B))                  ;;; B key
  76.     ((equal code '(2 67)) (do_C))                  ;;; C key
  77.     ((equal code '(2 68)) (do_D))                  ;;; D key
  78.     ((equal code '(2 69)) (do_E))                  ;;; E key
  79.     ((equal code '(2 70)) (do_F))                  ;;; F key
  80.     ((equal code '(2 71)) (do_G))                  ;;; G key
  81.     ((equal code '(2 72)) (do_H))                  ;;; H key
  82.     ((equal code '(2 73)) (do_I))                  ;;; I key
  83.     ((equal code '(2 74)) (do_J))                  ;;; J key
  84.     ((equal code '(2 75)) (do_K))                  ;;; K key
  85.     ((equal code '(2 76)) (do_L))                  ;;; L key
  86.     ((equal code '(2 77)) (do_M))                  ;;; M key
  87.     ((equal code '(2 78)) (do_N))                  ;;; N key
  88.     ((equal code '(2 79)) (do_O))                  ;;; O key
  89.     ((equal code '(2 80)) (do_P))                  ;;; P key
  90.     ((equal code '(2 81)) (do_Q))                  ;;; Q key
  91.     ((equal code '(2 82)) (do_R))                  ;;; R key
  92.     ((equal code '(2 83)) (do_S))                  ;;; S key
  93.     ((equal code '(2 84)) (do_T))                  ;;; T key
  94.     ((equal code '(2 85)) (do_U))                  ;;; U key
  95.     ((equal code '(2 86)) (do_V))                  ;;; V key
  96.     ((equal code '(2 87)) (do_W))                  ;;; W key
  97.     ((equal code '(2 88)) (do_X))                  ;;; X key
  98.     ((equal code '(2 89)) (do_Y))                  ;;; Y key
  99.     ((equal code '(2 90)) (do_Z))                  ;;; Z key
  100.     ((equal code '(2 91)) (do_OpenSquareBracket))  ;;; [ key
  101.     ((equal code '(2 92)) (do_BackSlash))          ;;; \ key
  102.     ((equal code '(2 93)) (do_CloseSquareBracket)) ;;; ] key
  103.     ((equal code '(2 94)) (do_Caret))              ;;; ^ key
  104.     ((equal code '(2 95)) (do_UnderScore))         ;;; _ key
  105.     ((equal code '(2 96)) (do_BackQuote))          ;;; ` key
  106.     ((equal code '(2 97)) (do_a))                  ;;; a key
  107.     ((equal code '(2 98)) (do_b))                  ;;; b key
  108.     ((equal code '(2 99)) (do_c))                  ;;; c key
  109.     ((equal code '(2 100))(do_d))                  ;;; d key
  110.     ((equal code '(2 101))(do_e))                  ;;; e key
  111.     ((equal code '(2 102))(do_f))                  ;;; f key
  112.     ((equal code '(2 103))(do_g))                  ;;; g key
  113.     ((equal code '(2 104))(do_h))                  ;;; h key
  114.     ((equal code '(2 105))(do_i))                  ;;; i key
  115.     ((equal code '(2 106))(do_j))                  ;;; j key
  116.     ((equal code '(2 107))(do_k))                  ;;; k key
  117.     ((equal code '(2 108))(do_l))                  ;;; l key
  118.     ((equal code '(2 109))(do_m))                  ;;; m key
  119.     ((equal code '(2 110))(do_n))                  ;;; n key
  120.     ((equal code '(2 111))(do_o))                  ;;; o key
  121.     ((equal code '(2 112))(do_p))                  ;;; p key
  122.     ((equal code '(2 113))(do_q))                  ;;; q key
  123.     ((equal code '(2 114))(do_r))                  ;;; r key
  124.     ((equal code '(2 115))(do_s))                  ;;; s key
  125.     ((equal code '(2 116))(do_t))                  ;;; t key
  126.     ((equal code '(2 117))(do_u))                  ;;; u key
  127.     ((equal code '(2 118))(do_v))                  ;;; v key
  128.     ((equal code '(2 119))(do_w))                  ;;; w key
  129.     ((equal code '(2 120))(do_x))                  ;;; x key
  130.     ((equal code '(2 121))(do_y))                  ;;; y key
  131.     ((equal code '(2 122))(do_z))                  ;;; z key
  132.     ((equal code '(2 123))(do_OpenBrace))          ;;; { key
  133.     ((equal code '(2 124))(do_VerticalBar))        ;;; | key
  134.     ((equal code '(2 125))(do_CloseBrace))         ;;; } key
  135.     ((equal code '(2 126))(do_Tilde))              ;;; ~ key
  136.     ((equal code '(2 127))(do_Delete))             ;;; Delete key
  137.  )
  138. )
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on December 22, 2011, 09:55:09 AM
(https://lh3.googleusercontent.com/-KkJqqHVu0go/TvNFZwlQYZI/AAAAAAAAASE/GHcNZoB9AQo/s685/code.jpg)
Title: Re: Examples of usage GRREAD - let's share
Post by: MP on December 22, 2011, 10:16:28 AM
(http://i40.tinypic.com/1syvs9.jpg)
Title: Re: Examples of usage GRREAD - let's share
Post by: trogg on December 22, 2011, 12:37:21 PM
Dynamic Arrow Size:
Nice one Alan. This will be very helpful
~Greg
Title: Re: Examples of usage GRREAD - let's share
Post by: alanjt on December 22, 2011, 01:00:10 PM
Dynamic Arrow Size:
Nice one Alan. This will be very helpful
~Greg
enjoy.
Title: Re: Examples of usage GRREAD - let's share
Post by: HasanCAD on March 12, 2012, 06:11:29 AM
Quote
Code: [Select]
[quote author=Lee Mac link=topic=12813.msg440380#msg440380 date=1310689668]
Some fun with
...
Combining the two

 :-)

- The Osnap not working to pick the second point. I know that Osnap not Working with GRerad. But I am sure that LEE has a solution
- Is there an ability to insert a block in start and end point of lines. no need for lines

Thanks LEE
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on June 12, 2012, 11:52:33 AM
A short, quick example to add to the collection:

(http://www.theswamp.org/lilly_pond/leemac/GrArcExample.gif)

Code - Auto/Visual Lisp: [Select]
  1. (defun c:test ( / a1 a2 p1 p2 pl )
  2.     (if (setq p1 (getpoint "\nPick 1st Point: "))
  3.         (progn
  4.             (setq a1 (* pi 0.05)
  5.                   a2 (* pi  1.5)    
  6.             )
  7.             (repeat 10
  8.                 (setq pl (cons (polar '(0.0 2.0 0.0) a2 2.0) pl)
  9.                       a2 (+ a2 a1)
  10.                 )
  11.             )
  12.             (setq pl (apply 'append (mapcar 'list pl (cdr pl))))
  13.             (princ "\nPick 2nd Point: ")
  14.             (while (= 5 (car (setq p2 (grread nil 13 0))))
  15.                 (setq p2 (cadr p2)
  16.                       a1 (angle p1 p2)
  17.                 )
  18.                 (redraw)
  19.                 (grvecs (list 3 p1 p2))
  20.                 (grvecs (cons 3 pl)
  21.                     (list
  22.                         (list (cos a1) (- (sin a1)) 0.0 (car  p2))
  23.                         (list (sin a1)    (cos a1)  0.0 (cadr p2))
  24.                        '(0.0 0.0 1.0 0.0)
  25.                        '(0.0 0.0 0.0 1.0)
  26.                     )
  27.                 )
  28.             )
  29.         )
  30.     )
  31.     (redraw) (princ)
  32. )
Title: Re: Examples of usage GRREAD - let's share
Post by: hmspe on July 15, 2012, 11:22:00 PM
I have a routine the requires selection of a single text entity.  Getting custom prompts to work correctly in both Autocad and Bricscad with the native commands has not been going well, and ssget only recognizes the outline of each character.

This function allows for custom prompts and does rollover highlighting of text entities based on the the aligned bounding box for the text entity.



Code: [Select]
(defun c:select_text (/ dim_scale half_pi loop new_entity old_entity
                      ret_val two_pi
                     )

  (defun get_text (cursor_point offset_distance filter / angle1 angle2         ; gets text using a bounding box
                   base_angle base_point box entity LL point1 point2
                   selset text_ename text_height UR
                  )

    (defun delta (a1 a2 / r1)                                                  ; gets the absolute angle between two vectors
      (cond ((> a1 (+ a2 pi)) (setq a2 (+ a2 two_pi)))                         ; based on code by John Uhden
            ((> a2 (+ a1 pi)) (setq a1 (+ a1 two_pi)))
      )
      (setq r1 (- a2 a1))
      (if (< r1 0.0)
        (setq r1 (+ r1 two_pi))
      )
      r1
    )

    (if (vl-string-search "BRICSCAD" (strcase (getvar "acadver")))             ; Bricscad does not like really small selection windows
      (if (< offset_distance 0.001) (setq offset_distance 0.001))
    )
    (setq selset (ssget "c"                                                    ; get the text entities at the cursor
                   (list (- (car cursor_point) offset_distance) (- (cadr cursor_point) offset_distance))
                   (list (+ (car cursor_point) offset_distance) (+ (cadr cursor_point) offset_distance))
                   filter
                 )
    )
    (setq counter    0
          text_ename nil
    )
    (if selset
      (progn
        (setq entity      (entget (ssname selset 0))                           ; just look at first entity
              text_height (cdr (assoc 40 entity))
              base_angle  (cdr (assoc 50 entity))
              base_point  (cdr (assoc 10 entity))
              box    (textbox entity)                                          ; get the normalized containing box
              point1 (car box)                                                 ; normalized LL point
              point2 (cadr box)                                                ; normalized UR point
              LL  (polar (trans (cdr (assoc 10 entity)) 0 1)                   ; actual LL point
                         (+ (angle '(0 0) point1) base_angle)
                         (distance '(0 0) point1)
                  )
              UR  (polar LL                                                    ; actual UR point
                         (+ base_angle (angle point1 point2))
                         (distance point1 point2)
                  )
              angle1 (delta base_angle (angle LL cursor_point))                ; angle from LL to cursor
              angle2 (delta base_angle (angle UR cursor_point))                ; from UL to cursor
        )
        (if (and (>= angle1 0.0)                                               ; test if the cursor is in the included
                 (<= angle1 half_pi)                                           ;   angle at the LL and UL
                 (>= angle2 pi)
                 (<= angle2 (+ pi half_pi))
            )
          (setq text_ename (cdr (assoc -1 entity)))                            ; return the text's ename
        )
        (setq counter (1+ counter))
      )
    )
    text_ename
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (setq old_entity nil
        new_entity nil
        loop       T
        dim_scale (getvar "dimscale")
  )
  (setq half_pi       (* PI 0.5)
        two_pi        (* PI 2.0)
  )
  (princ "\rSelect text: ")
  (while loop
    (setq ret_val (car (setq gr_data (grread t 15 2))))
    (cond ((= ret_val 5)
             (setq new_entity (get_text (cadr gr_data) (* dim_scale 0.05) '((0 . "TEXT"))))
                                                                               ; get text entities at the cursor
             (if (/= new_entity old_entity)                                    ; the entity has changed...
               (if new_entity                                                  ; if the new entity is not nil...
                 (redraw new_entity 3)                                         ; highlight the new entity
                 (if old_entity
                   (redraw old_entity 4)                                       ; unhighlight the old entity
                 )
               )
             )
             (setq old_entity new_entity)                                      ; store the last entity
          )
          ((= ret_val 3)
             (setq loop nil)
          )
    )
  )
  (if new_entity                                                               ; if the new entity is not nil...
    (redraw new_entity 4)                                                      ; highlight the new entity
  )
  (print new_entity)                                                           ; return the entity's ename
  (princ)
)


Title: Re: Examples of usage GRREAD - let's share
Post by: LibertyOne on July 17, 2012, 10:57:47 AM
A short, quick example to add to the collection:

(http://www.theswamp.org/lilly_pond/leemac/GrArcExample.gif)



Hi Lee! I see you are even taking up hockey in your spare time!
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on July 17, 2012, 11:00:52 AM
Hi Lee! I see you are even taking up hockey in your spare time!

 :-D
Title: Re: Examples of usage GRREAD - let's share
Post by: hobleglobsquishyworms on February 15, 2013, 03:00:15 AM
Think I might redefine someone's PL with this :lmao:
Code - Auto/Visual Lisp: [Select]
Title: Re: Examples of usage GRREAD - let's share
Post by: ribarm on May 28, 2014, 04:26:48 PM
The first one is simple CIRCLE...

Code: [Select]
(defun c:cirt ( / cirl p n gr gp an d )

  (defun cirl ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* 2. pi) n))
    (repeat n
      (setq p1 (polar '(0. 0. 0.) (* a (setq k (1+ k))) 1.0))
      (setq p2 (polar '(0. 0. 0.) (* a (1+ k)) 1.0))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )
 
  (setq p (getpoint "\nPick or specify center point : "))
  (prompt "\nSpecify precision (< / >) : ")
  (setq n 6)
  (while (not (eq (car (setq gr (grread t 15 0))) 3))
    (redraw)
    (if (listp (cadr gr))
      (progn
        (setq gp (cadr gr))
        (setq an (angle p gp))
        (setq d (distance p gp))
        (grvecs (cirl n 1)
          (list
            (list (* d (cos an)) (* d (- (sin an))) 0. (car p))
            (list (* d (sin an)) (* d (cos an)) 0. (cadr p))
            (list 0. 0. d (caddr p))
            '(0. 0. 0. 1.)
          )
        )
      )
    )
    (if (eq (cadr gr) 60) (setq n (1- n)))
    (if (eq (cadr gr) 62) (setq n (1+ n)))
    (if (zerop n) (setq n 1))
  )
  (entmake (list '(0 . "CIRCLE") (cons 10 p) (cons 40 d)))
  (redraw)
  (princ)
)

And the second one is G-HELIX - golden spiral - only one turn... :-(

Code: [Select]
(defun c:g-helix ( / *error* _acapp _getosmode _grX _OLE->ACI _OLE->RGB _RGB->ACI _snap _polarangs _polar _ortho ape as osm qcirl1 qcirl2 qcirl3 qcirl4 l1 l2 l3 l4 p1 p2 p3 p4 p5 o p s g pp n gr gp gps gpp an d )

  (vl-load-com)

  (defun *error* ( msg )
    (if ape (setvar 'aperture ape))
    (if as (setvar 'autosnap as))
    (if osm (setvar 'osmode osm))
    (if msg (prompt msg))
    (princ)
  )

  (defun _acapp nil
      (eval (list 'defun '_acapp 'nil (vlax-get-acad-object)))
      (_acapp)
  )

  (defun _getosmode ( os / lst )
      (foreach mode
         '(
              (0001 . "_end")
              (0002 . "_mid")
              (0004 . "_cen")
              (0008 . "_nod")
              (0016 . "_qua")
              (0032 . "_int")
              (0064 . "_ins")
              (0128 . "_per")
              (0256 . "_tan")
              (0512 . "_nea")
              (1024 . "_qui")
              (2048 . "_app")
              (4096 . "_ext")
              (8192 . "_par")
          )
          (if (not (zerop (logand (car mode) os)))
              (setq lst (cons "," (cons (cdr mode) lst)))
          )
      )
      (apply 'strcat (cdr lst))
  )

  (defun _grX ( p s c / -s r j )
      (setq -s (- s)
             r (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
             j p
      )
      (grdraw (mapcar '+ j (list (* r -s) (* r -s))) (mapcar '+ j (list (* r s) (* r s))) c)
      (grdraw (mapcar '+ j (list (* r -s) (* r (1+ -s)))) (mapcar '+ j (list (* r (1- s)) (* r s))) c)
      (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r -s))) (mapcar '+ j (list (* r s) (* r (1- s)))) c)
     
      (grdraw (mapcar '+ j (list (* r -s) (* r s))) (mapcar '+ j (list (* r s) (* r -s))) c)
      (grdraw (mapcar '+ j (list (* r -s) (* r (1- s)))) (mapcar '+ j (list (* r (1- s)) (* r -s))) c)
      (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r s))) (mapcar '+ j (list (* r s) (* r (1+ -s)))) c)

      p
  )

  (defun _OLE->ACI ( c )
      (apply '_RGB->ACI (_OLE->RGB c))
  )

  (defun _OLE->RGB ( c )
      (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(24 16 8))
  )

  (defun _RGB->ACI ( r g b / c o )
      (if (setq o (vla-getinterfaceobject (_acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
          (progn
              (setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
              (vlax-release-object o)
              (if (vl-catch-all-error-p c)
                  (prompt (strcat "\nError: " (vl-catch-all-error-message c)))
                  c
              )
          )
      )
  )

  (defun _snap ( p osm )
    (if (osnap p (_getosmode osm))
      (osnap p (_getosmode osm))
      p
    )
  )

  (defun _polarangs ( ang / n k a l )
    (if (/= ang 0.0)
      (progn
        (setq n (/ 360.1 (cvunit ang "radians" "degrees")))
        (setq k -1.0)
        (repeat (1+ (fix n))
          (setq a (* (setq k (1+ k)) ang))
          (setq l (cons a l))
        )
        l
      )
      (list 0.0)
    )
  )

  (defun _polar ( p0 p flag ang / a b an )
    (if flag
      (progn
        (setq a (car (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
        (setq b (last (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
        (if (< (abs (- (angle p0 p) a)) (abs (- (angle p0 p) b))) (setq an a) (setq an b))
        (inters p0 (polar p0 an 1.0) p (polar p (+ an (* 0.5 pi)) 1.0) nil)
      )
      p
    )
  )

  (defun _ortho ( p0 p flag )
    (if flag
      (_polar p0 p t (* 0.5 pi))
      p
    )
  )

  (defun qcirl1 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* 0.5 pi) n))
    (repeat n
      (setq p1 (polar '(0. 0. 0.) (* a (setq k (1+ k))) 1.))
      (setq p2 (polar '(0. 0. 0.) (* a (1+ k)) 1.))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )
 
  (defun qcirl2 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* 0.5 pi) n))
    (repeat n
      (setq p1 (polar (list 0. (- 1. g) 0.) (+ (* 0.5 pi) (* a (setq k (1+ k)))) g))
      (setq p2 (polar (list 0. (- 1. g) 0.) (+ (* 0.5 pi) (* a (1+ k))) g))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (defun qcirl3 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* 0.5 pi) n))
    (repeat n
      (setq p1 (polar (list (- (- g (* g g))) (- 1. g) 0.) (+ (* 1.0 pi) (* a (setq k (1+ k)))) (* g g)))
      (setq p2 (polar (list (- (- g (* g g))) (- 1. g) 0.) (+ (* 1.0 pi) (* a (1+ k))) (* g g)))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (defun qcirl4 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* 0.5 pi) n))
    (repeat n
      (setq p1 (polar (list (- (- g (* g g))) (* g g g) 0.) (+ (* 1.5 pi) (* a (setq k (1+ k)))) (* g g g)))
      (setq p2 (polar (list (- (- g (* g g))) (* g g g) 0.) (+ (* 1.5 pi) (* a (1+ k))) (* g g g)))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (setq g (/ (- (sqrt 5.) 1.) 2.))
  (setq pp (getpoint "\nPick or specify center point : "))
  (setvar 'orthomode 1)
  (setq ape (getvar 'aperture))
  (setvar 'aperture 40)
  (setq as (getvar 'autosnap))
  (setvar 'autosnap 31)
  (setq osm (getvar 'osmode))
  (setvar 'osmode 15359)
  (if (eq (getvar 'orthomode) 1) (setq o t) (setq o nil))
  (if (eq (logand (getvar 'autosnap) 8) 8) (setq p t) (setq p nil))
  (if (eq (logand (getvar 'autosnap) 16) 16) (setq s t) (setq s nil))
  (prompt "\nSpecify precision (< / >) : ")
  (setq n 6)
  (while (not (eq (car (setq gr (grread t 15 0))) 3))
    (redraw)
    (if (listp (cadr gr))
      (progn
        (setq gp (cadr gr))
        (setq gpp (cadr gr))
        (if gps (setq an (angle pp gps)) (setq an (angle pp gp)))
        (if gps (setq d (distance pp gps)) (setq d (distance pp gp)))
        (setq l1 (qcirl1 n 1))
        (setq l2 (qcirl2 n 1))
        (setq l3 (qcirl3 n 1))
        (setq l4 (qcirl4 n 1))
        (grvecs (append l1 l2 l3 l4)
          (list
            (list (* d (cos an)) (* d (- (sin an))) 0. (car pp))
            (list (* d (sin an)) (* d (cos an)) 0. (cadr pp))
            (list 0. 0. d (caddr pp))
            '(0. 0. 0. 1.)
          )
        )
      )
    )
    (cond
      ( (eq (cadr gr) 15)
        (if (eq o t) (setq o nil) (setq o t))
      )
      ( (eq (cadr gr) 21)
        (if (eq p t) (setq p nil) (setq p t))
      )
      ( (eq (cadr gr) 6)
        (if (eq s t) (setq s nil) (setq s t))
      )
    )
    (cond
      ( (and o p s)
        (setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
      )
      ( (and o (not p) s)
        (setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
      )
      ( (and (not o) p s)
        (setq gps (_snap (_polar pp gp t (getvar 'polarang)) (getvar 'osmode)))
      )
      ( (and (not o) (not p) s)
        (setq gps (_snap gp (getvar 'osmode)))
      )
      ( (and o p (not s))
        (setq gps (_ortho pp gp t))
      )
      ( (and o (not p) (not s))
        (setq gps (_ortho pp gp t))
      )
      ( (and (not o) p (not s))
        (setq gps (_polar pp gp t (getvar 'polarang)))
      )
      ( (and (not o) (not p) (not s))
        (setq gps gp)
      )
    )
    (if (not (equal gps gpp 1e-6))
      (_grX gps (atoi (getenv "AutoSnapSize")) (_OLE->ACI (if (= 1 (getvar 'cvport)) (atoi (getenv "Layout AutoSnap Color")) (atoi (getenv "Model AutoSnap Color")))))
    )
    (if (eq (cadr gr) 60) (setq n (1- n)))
    (if (eq (cadr gr) 62) (setq n (1+ n)))
    (if (zerop n) (setq n 1))
  )
  (setq an (angle pp gps))
  (setq d (distance pp gps))
  (setq p1 (polar pp an d))
  (setq p2 (polar pp (+ (* 0.5 pi) an) d))
  (setq p3 (polar (polar pp (+ (* 0.5 pi) an) (* d g g)) (+ pi an) (* d g)))
  (setq p4 (polar (polar (polar pp (+ (* 0.5 pi) an) (* d g g)) (+ pi an) (* d g g g)) (+ (* 1.5 pi) an) (* d g g)))
  (setq p5 (polar (polar (polar (polar pp (+ (* 0.5 pi) an) (* d g g)) (+ pi an) (* d g g g)) (+ (* 1.5 pi) an) (* d g g g g)) an (* d g g g)))
  (entmake (list
                  '(0 . "LWPOLYLINE")
                  '(100 . "AcDbEntity")
                  '(100 . "AcDbPolyline")
                  '(90 . 5)
                  (cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
                  '(38 . 0.0)
                  (cons 10 p1)
                  (cons 42 (- (sqrt 2.) 1.))
                  (cons 10 p2)
                  (cons 42 (- (sqrt 2.) 1.))
                  (cons 10 p3)
                  (cons 42 (- (sqrt 2.) 1.))
                  (cons 10 p4)
                  (cons 42 (- (sqrt 2.) 1.))
                  (cons 10 p5)
                  (cons 42 0.0)
                  '(210 0.0 0.0 1.0)
           )
  )
  (redraw)
  (while (eq (getstring "\nAnother turn - ENTER; Any other key+ENTER to finish") "")
    (setq pp (polar p5 (+ pi an) (* d g g g g)))
    (setq d (* d g g g g))
    (setq p1 (polar pp an d))
    (setq p2 (polar pp (+ (* 0.5 pi) an) d))
    (setq p3 (polar (polar pp (+ (* 0.5 pi) an) (* d g g)) (+ pi an) (* d g)))
    (setq p4 (polar (polar (polar pp (+ (* 0.5 pi) an) (* d g g)) (+ pi an) (* d g g g)) (+ (* 1.5 pi) an) (* d g g)))
    (setq p5 (polar (polar (polar (polar pp (+ (* 0.5 pi) an) (* d g g)) (+ pi an) (* d g g g)) (+ (* 1.5 pi) an) (* d g g g g)) an (* d g g g)))
    (entmake (list
                    '(0 . "LWPOLYLINE")
                    '(100 . "AcDbEntity")
                    '(100 . "AcDbPolyline")
                    '(90 . 5)
                    (cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
                    '(38 . 0.0)
                    (cons 10 p1)
                    (cons 42 (- (sqrt 2.) 1.))
                    (cons 10 p2)
                    (cons 42 (- (sqrt 2.) 1.))
                    (cons 10 p3)
                    (cons 42 (- (sqrt 2.) 1.))
                    (cons 10 p4)
                    (cons 42 (- (sqrt 2.) 1.))
                    (cons 10 p5)
                    (cons 42 0.0)
                    '(210 0.0 0.0 1.0)
             )
    )
  )
  (*error* nil)
)

Regards, M.R.
Title: Re: Examples of usage GRREAD - let's share
Post by: reltro on May 29, 2014, 08:38:58 AM
 :-)
nice thread...
here a function I wrote...

its some kind of interface to speed up the work with the mouse... normally I type the commands, but then I worked with a pen on a tablet; it was annoying to go all the way to the buttons, so I wrote this (code in the attachment).

Its pretty easy to put in more commands... It identifys also right/left click and also one-char-shortcuts... It don't reconize enter or space yet to repeat the last command, but I wanna add this soon...

Have a look...
command = Interface

reltro
Title: Re: Examples of usage GRREAD - let's share
Post by: kruuger on May 29, 2014, 08:51:31 AM
:)
nice thread...
here a function I wrote...

its some kind of interface to speed up the work with the mouse... normally I type the commands, but then I worked with a pen on a tablet; it was annoying to go all the way to the buttons, so I wrote this (code in the attachment).

Its pretty easy to put in more commands... It identifys also right/left click and also one-char-shortcuts... It don't reconize enter or space yet to repeat the last command, but I wanna add this soon...

Have a look...
command = Interface

reltro
how to use it ? sample please ?
Title: Re: Examples of usage GRREAD - let's share
Post by: reltro on May 29, 2014, 08:52:48 AM
Hey kruuger...

load it and then type Interface... ;)
Title: Re: Examples of usage GRREAD - let's share
Post by: kruuger on May 29, 2014, 08:57:27 AM
Hey kruuger...

load it and then type Interface... ;)
ahh those crazy evel
thanks


EDIT:o sh... sick... :)
Title: Re: Examples of usage GRREAD - let's share
Post by: ronjonp on May 29, 2014, 09:04:13 AM
:)
nice thread...
here a function I wrote...

its some kind of interface to speed up the work with the mouse... normally I type the commands, but then I worked with a pen on a tablet; it was annoying to go all the way to the buttons, so I wrote this (code in the attachment).

Its pretty easy to put in more commands... It identifys also right/left click and also one-char-shortcuts... It don't reconize enter or space yet to repeat the last command, but I wanna add this soon...

Have a look...
command = Interface

reltro


That's pretty cool  :kewl:
Title: Re: Examples of usage GRREAD - let's share
Post by: reltro on May 29, 2014, 09:12:37 AM
EDIT:o sh... sick... :)

That's pretty cool  :kewl:

:) thanks a lot...
Will add a guide to modify it... and the repeat-last-command... but at the moment there isn't much time...
Any other suggestions?

reltro
Title: Re: Examples of usage GRREAD - let's share
Post by: kruuger on May 29, 2014, 10:10:39 AM
EDIT:o sh... sick... :)

That's pretty cool  :kewl:

:) thanks a lot...
Will add a guide to modify it... and the repeat-last-command... but at the moment there isn't much time...
Any other suggestions?

reltro
what method do you use to draw this "interfaca"?
Title: Re: Examples of usage GRREAD - let's share
Post by: reltro on May 29, 2014, 10:27:58 AM
what method do you use to draw this "interfaca"?

It uses (grvecs ... ...) to draw and (redraw) to clean the display...

reltro
Title: Re: Examples of usage GRREAD - let's share
Post by: kruuger on May 29, 2014, 12:35:34 PM
what method do you use to draw this "interfaca"?
It uses (grvecs ... ...) to draw and (redraw) to clean the display...

reltro

i mean how do you calculate all those points.? how do you prepare your "graphics"?
k.
Title: Re: Examples of usage GRREAD - let's share
Post by: reltro on May 29, 2014, 12:54:56 PM
i mean how do you calculate all those points.? how do you prepare your "graphics"?
k.

Ah ok ;)
I think the parts of the circles aren't the problem? simple math...

The graphics are hardcoded...

The "graphics" I draw in acad using colored lines and then I use the code below to prepare them for (grvecs.
The "line-graphic" should be drawn near the WCS-origin, (0,0,0) will be the "InsertPoint"

In the main-code they are transformed (rotated, scaled) to fit in the circle-part-boundary (simple vector-math) ;)

Code: [Select]
;;reading the start-/end-point and also the color of any selected line-object...

(defun C:CreateSymbol (/ s Out ent)
    (princ "\nselect Lines")
    (if (setq s (ssget '((0 . "LINE"))))
        (foreach e (ssnamex s)
            (if (= 'ename (type (cadr e)))
                (setq    ent (entget (cadr e))
                        Out    (cons
                                (cons
                                    (    (lambda (c / )
                                            (if c
                                                c
                                                7
                                            )
                                        )
                                        (cdr (assoc 62 ent))
                                    )
                                    (mapcar
                                        '(lambda (g / p)
                                            (setq p (cdr (assoc g ent)))
                                            (mapcar
                                                '(lambda (a / )
                                                    (fix (* a 1000))
                                                )
                                                (list (car p) (cadr p))
                                               
                                            )
                                        )
                                        '(10 11)
                                    )
                                )
                                Out
                            )
                )
            )
        )
    )
    (apply 'append Out)
)

for the text look at this thread http://www.theswamp.org/index.php?topic=46966.0

reltro
Title: Re: Examples of usage GRREAD - let's share
Post by: TimSpangler on May 29, 2014, 01:06:21 PM
That is sick.....I love it!
Title: Re: Examples of usage GRREAD - let's share
Post by: ymg on May 29, 2014, 01:08:07 PM
reltro,

Cool!!  8-)

Reminds me of Radial Menu in Autohotkey.

ymg
Title: Re: Examples of usage GRREAD - let's share
Post by: ribarm on May 30, 2014, 05:48:16 AM
Additions to helixes...

G-HELIX (golden spiral - cw)

Code: [Select]
(defun c:ghcw ( / *error* trp mxm mxv _acapp _getosmode _grX _OLE->ACI _OLE->RGB _RGB->ACI _snap _polarangs _polar _ortho ape as osm qcirl1 qcirl2 qcirl3 qcirl4 l1 l2 l3 l4 p1 p2 p3 p4 p5 o p s g pp n z gr gp gps gpp an d )

  (vl-load-com)

  (defun *error* ( msg )
    (if ape (setvar 'aperture ape))
    (if as (setvar 'autosnap as))
    (if osm (setvar 'osmode osm))
    (if msg (prompt msg))
    (princ)
  )

  ;; Matrix Transpose  -  Doug Wilson
  ;; Args: m - nxn matrix
   
  (defun trp ( m )
      (apply 'mapcar (cons 'list m))
  )
   
  ;; Matrix x Matrix  -  Vladimir Nesterovsky
  ;; Args: m,n - nxn matrices
   
  (defun mxm ( m n )
      ((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
  )
   
  ;; Matrix x Vector  -  Vladimir Nesterovsky
  ;; Args: m - nxn matrix, v - vector in R^n
   
  (defun mxv ( m v )
      (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
  )

  (defun _acapp nil
      (eval (list 'defun '_acapp 'nil (vlax-get-acad-object)))
      (_acapp)
  )

  (defun _getosmode ( os / lst )
      (foreach mode
         '(
              (0001 . "_end")
              (0002 . "_mid")
              (0004 . "_cen")
              (0008 . "_nod")
              (0016 . "_qua")
              (0032 . "_int")
              (0064 . "_ins")
              (0128 . "_per")
              (0256 . "_tan")
              (0512 . "_nea")
              (1024 . "_qui")
              (2048 . "_app")
              (4096 . "_ext")
              (8192 . "_par")
          )
          (if (not (zerop (logand (car mode) os)))
              (setq lst (cons "," (cons (cdr mode) lst)))
          )
      )
      (apply 'strcat (cdr lst))
  )

  (defun _grX ( p s c / -s r j )
      (setq -s (- s)
             r (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
             j p
      )
      (grdraw (mapcar '+ j (list (* r -s) (* r -s))) (mapcar '+ j (list (* r s) (* r s))) c)
      (grdraw (mapcar '+ j (list (* r -s) (* r (1+ -s)))) (mapcar '+ j (list (* r (1- s)) (* r s))) c)
      (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r -s))) (mapcar '+ j (list (* r s) (* r (1- s)))) c)
     
      (grdraw (mapcar '+ j (list (* r -s) (* r s))) (mapcar '+ j (list (* r s) (* r -s))) c)
      (grdraw (mapcar '+ j (list (* r -s) (* r (1- s)))) (mapcar '+ j (list (* r (1- s)) (* r -s))) c)
      (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r s))) (mapcar '+ j (list (* r s) (* r (1+ -s)))) c)

      p
  )

  (defun _OLE->ACI ( c )
      (apply '_RGB->ACI (_OLE->RGB c))
  )

  (defun _OLE->RGB ( c )
      (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(24 16 8))
  )

  (defun _RGB->ACI ( r g b / c o )
      (if (setq o (vla-getinterfaceobject (_acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
          (progn
              (setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
              (vlax-release-object o)
              (if (vl-catch-all-error-p c)
                  (prompt (strcat "\nError: " (vl-catch-all-error-message c)))
                  c
              )
          )
      )
  )

  (defun _snap ( p osm )
    (if (osnap p (_getosmode osm))
      (osnap p (_getosmode osm))
      p
    )
  )

  (defun _polarangs ( ang / n k a l )
    (if (/= ang 0.0)
      (progn
        (setq n (/ 360.1 (cvunit ang "radians" "degrees")))
        (setq k -1.0)
        (repeat (1+ (fix n))
          (setq a (* (setq k (1+ k)) ang))
          (setq l (cons a l))
        )
        l
      )
      (list 0.0)
    )
  )

  (defun _polar ( p0 p flag ang / a b an )
    (if flag
      (progn
        (setq a (car (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
        (setq b (last (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
        (if (< (abs (- (angle p0 p) a)) (abs (- (angle p0 p) b))) (setq an a) (setq an b))
        (inters p0 (polar p0 an 1.0) p (polar p (+ an (* 0.5 pi)) 1.0) nil)
      )
      p
    )
  )

  (defun _ortho ( p0 p flag )
    (if flag
      (_polar p0 p t (* 0.5 pi))
      p
    )
  )

  (defun qcirl1 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* -0.5 pi) n))
    (repeat n
      (setq p1 (polar '(0. 0. 0.) (* a (setq k (1+ k))) 1.))
      (setq p2 (polar '(0. 0. 0.) (* a (1+ k)) 1.))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )
 
  (defun qcirl2 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* -0.5 pi) n))
    (repeat n
      (setq p1 (polar (list 0. (- (- 1. g)) 0.) (+ (* -0.5 pi) (* a (setq k (1+ k)))) g))
      (setq p2 (polar (list 0. (- (- 1. g)) 0.) (+ (* -0.5 pi) (* a (1+ k))) g))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (defun qcirl3 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* -0.5 pi) n))
    (repeat n
      (setq p1 (polar (list (- (- g (* g g))) (- (- 1. g)) 0.) (+ (* -1.0 pi) (* a (setq k (1+ k)))) (* g g)))
      (setq p2 (polar (list (- (- g (* g g))) (- (- 1. g)) 0.) (+ (* -1.0 pi) (* a (1+ k))) (* g g)))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (defun qcirl4 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* -0.5 pi) n))
    (repeat n
      (setq p1 (polar (list (- (- g (* g g))) (- (* g g g)) 0.) (+ (* -1.5 pi) (* a (setq k (1+ k)))) (* g g g)))
      (setq p2 (polar (list (- (- g (* g g))) (- (* g g g)) 0.) (+ (* -1.5 pi) (* a (1+ k))) (* g g g)))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (setq g (/ (- (sqrt 5.) 1.) 2.))
  (setq pp (getpoint "\nPick or specify center point : "))
  (setvar 'orthomode 1)
  (setq ape (getvar 'aperture))
  (setvar 'aperture 40)
  (setq as (getvar 'autosnap))
  (setvar 'autosnap 31)
  (setq osm (getvar 'osmode))
  (setvar 'osmode 15359)
  (if (eq (getvar 'orthomode) 1) (setq o t) (setq o nil))
  (if (eq (logand (getvar 'autosnap) 8) 8) (setq p t) (setq p nil))
  (if (eq (logand (getvar 'autosnap) 16) 16) (setq s t) (setq s nil))
  (prompt "\nSpecify precision (< / >) : ")
  (setq n 6)
  (setq z (trp (mapcar '(lambda ( x ) (trans x 1 2 t)) '((1.0 0.0) (0.0 1.0) (0.0 0.0)))))
  (while (not (eq (car (setq gr (grread t 15 0))) 3))
    (redraw)
    (if (listp (cadr gr))
      (progn
        (setq gp (cadr gr))
        (setq gpp (cadr gr))
        (if gps (setq an (angle pp gps)) (setq an (angle pp gp)))
        (if gps (setq d (distance pp gps)) (setq d (distance pp gp)))
        (setq l1 (qcirl1 n -1))
        (setq l2 (qcirl2 n -1))
        (setq l3 (qcirl3 n -1))
        (setq l4 (qcirl4 n -1))
        (grvecs (append l1 l2 l3 l4)
          (append
            (mapcar 'append
              (mxm z
                (list
                  (list (* d (cos an)) (* d (sin (- an))) 0.0)
                  (list (* d (sin an)) (* d (cos an))     0.0)
                 '(0.0 0.0 1.0)
                )
              )
              (mapcar 'list (trans pp 1 2))
            )
           '((0.0 0.0 0.0 1.0))
          )
        )
      )
    )
    (cond
      ( (eq (cadr gr) 15)
        (if (eq o t) (setq o nil) (setq o t))
      )
      ( (eq (cadr gr) 21)
        (if (eq p t) (setq p nil) (setq p t))
      )
      ( (eq (cadr gr) 6)
        (if (eq s t) (setq s nil) (setq s t))
      )
    )
    (cond
      ( (and o p s)
        (setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
      )
      ( (and o (not p) s)
        (setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
      )
      ( (and (not o) p s)
        (setq gps (_snap (_polar pp gp t (getvar 'polarang)) (getvar 'osmode)))
      )
      ( (and (not o) (not p) s)
        (setq gps (_snap gp (getvar 'osmode)))
      )
      ( (and o p (not s))
        (setq gps (_ortho pp gp t))
      )
      ( (and o (not p) (not s))
        (setq gps (_ortho pp gp t))
      )
      ( (and (not o) p (not s))
        (setq gps (_polar pp gp t (getvar 'polarang)))
      )
      ( (and (not o) (not p) (not s))
        (setq gps gp)
      )
    )
    (if (not (equal gps gpp 1e-6))
      (_grX gps (atoi (getenv "AutoSnapSize")) (_OLE->ACI (if (= 1 (getvar 'cvport)) (atoi (getenv "Layout AutoSnap Color")) (atoi (getenv "Model AutoSnap Color")))))
    )
    (if (eq (cadr gr) 60) (setq n (1- n)))
    (if (eq (cadr gr) 62) (setq n (1+ n)))
    (if (zerop n) (setq n 1))
  )
  (setq an (angle pp gps))
  (setq d (distance pp gps))
  (setq z (trans '(0.0 0.0 1.0) 1 0 t))
  (setq p1 (polar pp an d))
  (setq p2 (polar pp (+ (* -0.5 pi) an) d))
  (setq p3 (polar (polar pp (+ (* -0.5 pi) an) (* d g g)) (+ (- pi) an) (* d g)))
  (setq p4 (polar (polar (polar pp (+ (* -0.5 pi) an) (* d g g)) (+ (- pi) an) (* d g g g)) (+ (* -1.5 pi) an) (* d g g)))
  (setq p5 (polar (polar (polar (polar pp (+ (* -0.5 pi) an) (* d g g)) (+ (- pi) an) (* d g g g)) (+ (* -1.5 pi) an) (* d g g g g)) an (* d g g g)))
  (entmake (list
                  '(0 . "LWPOLYLINE")
                  '(100 . "AcDbEntity")
                  '(100 . "AcDbPolyline")
                  '(90 . 5)
                  (cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
                  (cons 38 (caddr (trans pp 1 z)))
                  (cons 10 (trans p1 1 z))
                  (cons 42 (- (- (sqrt 2.) 1.)))
                  (cons 10 (trans p2 1 z))
                  (cons 42 (- (- (sqrt 2.) 1.)))
                  (cons 10 (trans p3 1 z))
                  (cons 42 (- (- (sqrt 2.) 1.)))
                  (cons 10 (trans p4 1 z))
                  (cons 42 (- (- (sqrt 2.) 1.)))
                  (cons 10 (trans p5 1 z))
                  (cons 42 0.0)
                  (cons 210 z)
           )
  )
  (redraw)
  (while (eq (getstring "\nAnother turn - ENTER; Any other key+ENTER to finish") "")
    (setq pp (polar p5 (+ pi an) (* d g g g g)))
    (setq d (* d g g g g))
    (setq p1 (polar pp an d))
    (setq p2 (polar pp (+ (* -0.5 pi) an) d))
    (setq p3 (polar (polar pp (+ (* -0.5 pi) an) (* d g g)) (+ (- pi) an) (* d g)))
    (setq p4 (polar (polar (polar pp (+ (* -0.5 pi) an) (* d g g)) (+ (- pi) an) (* d g g g)) (+ (* -1.5 pi) an) (* d g g)))
    (setq p5 (polar (polar (polar (polar pp (+ (* -0.5 pi) an) (* d g g)) (+ (- pi) an) (* d g g g)) (+ (* -1.5 pi) an) (* d g g g g)) an (* d g g g)))
    (entmake (list
                    '(0 . "LWPOLYLINE")
                    '(100 . "AcDbEntity")
                    '(100 . "AcDbPolyline")
                    '(90 . 5)
                    (cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
                    (cons 38 (caddr (trans pp 1 z)))
                    (cons 10 (trans p1 1 z))
                    (cons 42 (- (- (sqrt 2.) 1.)))
                    (cons 10 (trans p2 1 z))
                    (cons 42 (- (- (sqrt 2.) 1.)))
                    (cons 10 (trans p3 1 z))
                    (cons 42 (- (- (sqrt 2.) 1.)))
                    (cons 10 (trans p4 1 z))
                    (cons 42 (- (- (sqrt 2.) 1.)))
                    (cons 10 (trans p5 1 z))
                    (cons 42 0.0)
                    (cons 210 z)
             )
    )
  )
  (*error* nil)
)
Title: Re: Examples of usage GRREAD - let's share
Post by: ribarm on May 30, 2014, 05:49:01 AM
G-HELIX (golden spiral - ccw)

Code: [Select]
(defun c:ghccw ( / *error* trp mxm mxv _acapp _getosmode _grX _OLE->ACI _OLE->RGB _RGB->ACI _snap _polarangs _polar _ortho ape as osm qcirl1 qcirl2 qcirl3 qcirl4 l1 l2 l3 l4 p1 p2 p3 p4 p5 o p s g pp n z gr gp gps gpp an d )

  (vl-load-com)

  (defun *error* ( msg )
    (if ape (setvar 'aperture ape))
    (if as (setvar 'autosnap as))
    (if osm (setvar 'osmode osm))
    (if msg (prompt msg))
    (princ)
  )

  ;; Matrix Transpose  -  Doug Wilson
  ;; Args: m - nxn matrix
   
  (defun trp ( m )
      (apply 'mapcar (cons 'list m))
  )
   
  ;; Matrix x Matrix  -  Vladimir Nesterovsky
  ;; Args: m,n - nxn matrices
   
  (defun mxm ( m n )
      ((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
  )
   
  ;; Matrix x Vector  -  Vladimir Nesterovsky
  ;; Args: m - nxn matrix, v - vector in R^n
   
  (defun mxv ( m v )
      (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
  )

  (defun _acapp nil
      (eval (list 'defun '_acapp 'nil (vlax-get-acad-object)))
      (_acapp)
  )

  (defun _getosmode ( os / lst )
      (foreach mode
         '(
              (0001 . "_end")
              (0002 . "_mid")
              (0004 . "_cen")
              (0008 . "_nod")
              (0016 . "_qua")
              (0032 . "_int")
              (0064 . "_ins")
              (0128 . "_per")
              (0256 . "_tan")
              (0512 . "_nea")
              (1024 . "_qui")
              (2048 . "_app")
              (4096 . "_ext")
              (8192 . "_par")
          )
          (if (not (zerop (logand (car mode) os)))
              (setq lst (cons "," (cons (cdr mode) lst)))
          )
      )
      (apply 'strcat (cdr lst))
  )

  (defun _grX ( p s c / -s r j )
      (setq -s (- s)
             r (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
             j p
      )
      (grdraw (mapcar '+ j (list (* r -s) (* r -s))) (mapcar '+ j (list (* r s) (* r s))) c)
      (grdraw (mapcar '+ j (list (* r -s) (* r (1+ -s)))) (mapcar '+ j (list (* r (1- s)) (* r s))) c)
      (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r -s))) (mapcar '+ j (list (* r s) (* r (1- s)))) c)
     
      (grdraw (mapcar '+ j (list (* r -s) (* r s))) (mapcar '+ j (list (* r s) (* r -s))) c)
      (grdraw (mapcar '+ j (list (* r -s) (* r (1- s)))) (mapcar '+ j (list (* r (1- s)) (* r -s))) c)
      (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r s))) (mapcar '+ j (list (* r s) (* r (1+ -s)))) c)

      p
  )

  (defun _OLE->ACI ( c )
      (apply '_RGB->ACI (_OLE->RGB c))
  )

  (defun _OLE->RGB ( c )
      (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(24 16 8))
  )

  (defun _RGB->ACI ( r g b / c o )
      (if (setq o (vla-getinterfaceobject (_acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
          (progn
              (setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
              (vlax-release-object o)
              (if (vl-catch-all-error-p c)
                  (prompt (strcat "\nError: " (vl-catch-all-error-message c)))
                  c
              )
          )
      )
  )

  (defun _snap ( p osm )
    (if (osnap p (_getosmode osm))
      (osnap p (_getosmode osm))
      p
    )
  )

  (defun _polarangs ( ang / n k a l )
    (if (/= ang 0.0)
      (progn
        (setq n (/ 360.1 (cvunit ang "radians" "degrees")))
        (setq k -1.0)
        (repeat (1+ (fix n))
          (setq a (* (setq k (1+ k)) ang))
          (setq l (cons a l))
        )
        l
      )
      (list 0.0)
    )
  )

  (defun _polar ( p0 p flag ang / a b an )
    (if flag
      (progn
        (setq a (car (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
        (setq b (last (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
        (if (< (abs (- (angle p0 p) a)) (abs (- (angle p0 p) b))) (setq an a) (setq an b))
        (inters p0 (polar p0 an 1.0) p (polar p (+ an (* 0.5 pi)) 1.0) nil)
      )
      p
    )
  )

  (defun _ortho ( p0 p flag )
    (if flag
      (_polar p0 p t (* 0.5 pi))
      p
    )
  )

  (defun qcirl1 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* 0.5 pi) n))
    (repeat n
      (setq p1 (polar '(0. 0. 0.) (* a (setq k (1+ k))) 1.))
      (setq p2 (polar '(0. 0. 0.) (* a (1+ k)) 1.))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )
 
  (defun qcirl2 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* 0.5 pi) n))
    (repeat n
      (setq p1 (polar (list 0. (- 1. g) 0.) (+ (* 0.5 pi) (* a (setq k (1+ k)))) g))
      (setq p2 (polar (list 0. (- 1. g) 0.) (+ (* 0.5 pi) (* a (1+ k))) g))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (defun qcirl3 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* 0.5 pi) n))
    (repeat n
      (setq p1 (polar (list (- (- g (* g g))) (- 1. g) 0.) (+ (* 1.0 pi) (* a (setq k (1+ k)))) (* g g)))
      (setq p2 (polar (list (- (- g (* g g))) (- 1. g) 0.) (+ (* 1.0 pi) (* a (1+ k))) (* g g)))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (defun qcirl4 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* 0.5 pi) n))
    (repeat n
      (setq p1 (polar (list (- (- g (* g g))) (* g g g) 0.) (+ (* 1.5 pi) (* a (setq k (1+ k)))) (* g g g)))
      (setq p2 (polar (list (- (- g (* g g))) (* g g g) 0.) (+ (* 1.5 pi) (* a (1+ k))) (* g g g)))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (setq g (/ (- (sqrt 5.) 1.) 2.))
  (setq pp (getpoint "\nPick or specify center point : "))
  (setvar 'orthomode 1)
  (setq ape (getvar 'aperture))
  (setvar 'aperture 40)
  (setq as (getvar 'autosnap))
  (setvar 'autosnap 31)
  (setq osm (getvar 'osmode))
  (setvar 'osmode 15359)
  (if (eq (getvar 'orthomode) 1) (setq o t) (setq o nil))
  (if (eq (logand (getvar 'autosnap) 8) 8) (setq p t) (setq p nil))
  (if (eq (logand (getvar 'autosnap) 16) 16) (setq s t) (setq s nil))
  (prompt "\nSpecify precision (< / >) : ")
  (setq n 6)
  (setq z (trp (mapcar '(lambda ( x ) (trans x 1 2 t)) '((1.0 0.0) (0.0 1.0) (0.0 0.0)))))
  (while (not (eq (car (setq gr (grread t 15 0))) 3))
    (redraw)
    (if (listp (cadr gr))
      (progn
        (setq gp (cadr gr))
        (setq gpp (cadr gr))
        (if gps (setq an (angle pp gps)) (setq an (angle pp gp)))
        (if gps (setq d (distance pp gps)) (setq d (distance pp gp)))
        (setq l1 (qcirl1 n -1))
        (setq l2 (qcirl2 n -1))
        (setq l3 (qcirl3 n -1))
        (setq l4 (qcirl4 n -1))
        (grvecs (append l1 l2 l3 l4)
          (append
            (mapcar 'append
              (mxm z
                (list
                  (list (* d (cos an)) (* d (sin (- an))) 0.0)
                  (list (* d (sin an)) (* d (cos an))     0.0)
                 '(0.0 0.0 1.0)
                )
              )
              (mapcar 'list (trans pp 1 2))
            )
           '((0.0 0.0 0.0 1.0))
          )
        )
      )
    )
    (cond
      ( (eq (cadr gr) 15)
        (if (eq o t) (setq o nil) (setq o t))
      )
      ( (eq (cadr gr) 21)
        (if (eq p t) (setq p nil) (setq p t))
      )
      ( (eq (cadr gr) 6)
        (if (eq s t) (setq s nil) (setq s t))
      )
    )
    (cond
      ( (and o p s)
        (setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
      )
      ( (and o (not p) s)
        (setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
      )
      ( (and (not o) p s)
        (setq gps (_snap (_polar pp gp t (getvar 'polarang)) (getvar 'osmode)))
      )
      ( (and (not o) (not p) s)
        (setq gps (_snap gp (getvar 'osmode)))
      )
      ( (and o p (not s))
        (setq gps (_ortho pp gp t))
      )
      ( (and o (not p) (not s))
        (setq gps (_ortho pp gp t))
      )
      ( (and (not o) p (not s))
        (setq gps (_polar pp gp t (getvar 'polarang)))
      )
      ( (and (not o) (not p) (not s))
        (setq gps gp)
      )
    )
    (if (not (equal gps gpp 1e-6))
      (_grX gps (atoi (getenv "AutoSnapSize")) (_OLE->ACI (if (= 1 (getvar 'cvport)) (atoi (getenv "Layout AutoSnap Color")) (atoi (getenv "Model AutoSnap Color")))))
    )
    (if (eq (cadr gr) 60) (setq n (1- n)))
    (if (eq (cadr gr) 62) (setq n (1+ n)))
    (if (zerop n) (setq n 1))
  )
  (setq an (angle pp gps))
  (setq d (distance pp gps))
  (setq z (trans '(0.0 0.0 1.0) 1 0 t))
  (setq p1 (polar pp an d))
  (setq p2 (polar pp (+ (* 0.5 pi) an) d))
  (setq p3 (polar (polar pp (+ (* 0.5 pi) an) (* d g g)) (+ pi an) (* d g)))
  (setq p4 (polar (polar (polar pp (+ (* 0.5 pi) an) (* d g g)) (+ pi an) (* d g g g)) (+ (* 1.5 pi) an) (* d g g)))
  (setq p5 (polar (polar (polar (polar pp (+ (* 0.5 pi) an) (* d g g)) (+ pi an) (* d g g g)) (+ (* 1.5 pi) an) (* d g g g g)) an (* d g g g)))
  (entmake (list
                  '(0 . "LWPOLYLINE")
                  '(100 . "AcDbEntity")
                  '(100 . "AcDbPolyline")
                  '(90 . 5)
                  (cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
                  (cons 38 (caddr (trans pp 1 z)))
                  (cons 10 (trans p1 1 z))
                  (cons 42 (- (sqrt 2.) 1.))
                  (cons 10 (trans p2 1 z))
                  (cons 42 (- (sqrt 2.) 1.))
                  (cons 10 (trans p3 1 z))
                  (cons 42 (- (sqrt 2.) 1.))
                  (cons 10 (trans p4 1 z))
                  (cons 42 (- (sqrt 2.) 1.))
                  (cons 10 (trans p5 1 z))
                  (cons 42 0.0)
                  (cons 210 z)
           )
  )
  (redraw)
  (while (eq (getstring "\nAnother turn - ENTER; Any other key+ENTER to finish") "")
    (setq pp (polar p5 (+ pi an) (* d g g g g)))
    (setq d (* d g g g g))
    (setq p1 (polar pp an d))
    (setq p2 (polar pp (+ (* 0.5 pi) an) d))
    (setq p3 (polar (polar pp (+ (* 0.5 pi) an) (* d g g)) (+ pi an) (* d g)))
    (setq p4 (polar (polar (polar pp (+ (* 0.5 pi) an) (* d g g)) (+ pi an) (* d g g g)) (+ (* 1.5 pi) an) (* d g g)))
    (setq p5 (polar (polar (polar (polar pp (+ (* 0.5 pi) an) (* d g g)) (+ pi an) (* d g g g)) (+ (* 1.5 pi) an) (* d g g g g)) an (* d g g g)))
    (entmake (list
                    '(0 . "LWPOLYLINE")
                    '(100 . "AcDbEntity")
                    '(100 . "AcDbPolyline")
                    '(90 . 5)
                    (cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
                    (cons 38 (caddr (trans pp 1 z)))
                    (cons 10 (trans p1 1 z))
                    (cons 42 (- (sqrt 2.) 1.))
                    (cons 10 (trans p2 1 z))
                    (cons 42 (- (sqrt 2.) 1.))
                    (cons 10 (trans p3 1 z))
                    (cons 42 (- (sqrt 2.) 1.))
                    (cons 10 (trans p4 1 z))
                    (cons 42 (- (sqrt 2.) 1.))
                    (cons 10 (trans p5 1 z))
                    (cons 42 0.0)
                    (cons 210 z)
             )
    )
  )
  (*error* nil)
)
Title: Re: Examples of usage GRREAD - let's share
Post by: ribarm on May 30, 2014, 05:50:13 AM
Half circles HELIX (cw)

Code: [Select]
(defun c:chcw ( / *error* trp mxm mxv _acapp _getosmode _grX _OLE->ACI _OLE->RGB _RGB->ACI _snap _polarangs _polar _ortho ape as osm hcirl1 hcirl2 hcirl3 hcirl4 l1 l2 l3 l4 p1 p2 p3 p4 p5 o p s pp n z gr gp gps gpp an d )

  (vl-load-com)

  (defun *error* ( msg )
    (if ape (setvar 'aperture ape))
    (if as (setvar 'autosnap as))
    (if osm (setvar 'osmode osm))
    (if msg (prompt msg))
    (princ)
  )

  ;; Matrix Transpose  -  Doug Wilson
  ;; Args: m - nxn matrix
   
  (defun trp ( m )
      (apply 'mapcar (cons 'list m))
  )
   
  ;; Matrix x Matrix  -  Vladimir Nesterovsky
  ;; Args: m,n - nxn matrices
   
  (defun mxm ( m n )
      ((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
  )
   
  ;; Matrix x Vector  -  Vladimir Nesterovsky
  ;; Args: m - nxn matrix, v - vector in R^n
   
  (defun mxv ( m v )
      (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
  )

  (defun _acapp nil
      (eval (list 'defun '_acapp 'nil (vlax-get-acad-object)))
      (_acapp)
  )

  (defun _getosmode ( os / lst )
      (foreach mode
         '(
              (0001 . "_end")
              (0002 . "_mid")
              (0004 . "_cen")
              (0008 . "_nod")
              (0016 . "_qua")
              (0032 . "_int")
              (0064 . "_ins")
              (0128 . "_per")
              (0256 . "_tan")
              (0512 . "_nea")
              (1024 . "_qui")
              (2048 . "_app")
              (4096 . "_ext")
              (8192 . "_par")
          )
          (if (not (zerop (logand (car mode) os)))
              (setq lst (cons "," (cons (cdr mode) lst)))
          )
      )
      (apply 'strcat (cdr lst))
  )

  (defun _grX ( p s c / -s r j )
      (setq -s (- s)
             r (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
             j p
      )
      (grdraw (mapcar '+ j (list (* r -s) (* r -s))) (mapcar '+ j (list (* r s) (* r s))) c)
      (grdraw (mapcar '+ j (list (* r -s) (* r (1+ -s)))) (mapcar '+ j (list (* r (1- s)) (* r s))) c)
      (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r -s))) (mapcar '+ j (list (* r s) (* r (1- s)))) c)
     
      (grdraw (mapcar '+ j (list (* r -s) (* r s))) (mapcar '+ j (list (* r s) (* r -s))) c)
      (grdraw (mapcar '+ j (list (* r -s) (* r (1- s)))) (mapcar '+ j (list (* r (1- s)) (* r -s))) c)
      (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r s))) (mapcar '+ j (list (* r s) (* r (1+ -s)))) c)

      p
  )

  (defun _OLE->ACI ( c )
      (apply '_RGB->ACI (_OLE->RGB c))
  )

  (defun _OLE->RGB ( c )
      (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(24 16 8))
  )

  (defun _RGB->ACI ( r g b / c o )
      (if (setq o (vla-getinterfaceobject (_acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
          (progn
              (setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
              (vlax-release-object o)
              (if (vl-catch-all-error-p c)
                  (prompt (strcat "\nError: " (vl-catch-all-error-message c)))
                  c
              )
          )
      )
  )

  (defun _snap ( p osm )
    (if (osnap p (_getosmode osm))
      (osnap p (_getosmode osm))
      p
    )
  )

  (defun _polarangs ( ang / n k a l )
    (if (/= ang 0.0)
      (progn
        (setq n (/ 360.1 (cvunit ang "radians" "degrees")))
        (setq k -1.0)
        (repeat (1+ (fix n))
          (setq a (* (setq k (1+ k)) ang))
          (setq l (cons a l))
        )
        l
      )
      (list 0.0)
    )
  )

  (defun _polar ( p0 p flag ang / a b an )
    (if flag
      (progn
        (setq a (car (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
        (setq b (last (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
        (if (< (abs (- (angle p0 p) a)) (abs (- (angle p0 p) b))) (setq an a) (setq an b))
        (inters p0 (polar p0 an 1.0) p (polar p (+ an (* 0.5 pi)) 1.0) nil)
      )
      p
    )
  )

  (defun _ortho ( p0 p flag )
    (if flag
      (_polar p0 p t (* 0.5 pi))
      p
    )
  )

  (defun hcirl1 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* -1.0 pi) n))
    (repeat n
      (setq p1 (polar '(0. 0. 0.) (* a (setq k (1+ k))) 1.))
      (setq p2 (polar '(0. 0. 0.) (* a (1+ k)) 1.))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )
 
  (defun hcirl2 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* -1.0 pi) n))
    (repeat n
      (setq p1 (polar (list -0.5 0. 0.) (+ (* -1.0 pi) (* a (setq k (1+ k)))) 0.5))
      (setq p2 (polar (list -0.5 0. 0.) (+ (* -1.0 pi) (* a (1+ k))) 0.5))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (defun hcirl3 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* -1.0 pi) n))
    (repeat n
      (setq p1 (polar (list -0.25 0. 0.) (+ (* 0.0 pi) (* a (setq k (1+ k)))) 0.25))
      (setq p2 (polar (list -0.25 0. 0.) (+ (* 0.0 pi) (* a (1+ k))) 0.25))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (defun hcirl4 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* -1.0 pi) n))
    (repeat n
      (setq p1 (polar (list -0.375 0. 0.) (+ (* -1.0 pi) (* a (setq k (1+ k)))) 0.125))
      (setq p2 (polar (list -0.375 0. 0.) (+ (* -1.0 pi) (* a (1+ k))) 0.125))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (setq pp (getpoint "\nPick or specify center point : "))
  (setvar 'orthomode 1)
  (setq ape (getvar 'aperture))
  (setvar 'aperture 40)
  (setq as (getvar 'autosnap))
  (setvar 'autosnap 31)
  (setq osm (getvar 'osmode))
  (setvar 'osmode 15359)
  (if (eq (getvar 'orthomode) 1) (setq o t) (setq o nil))
  (if (eq (logand (getvar 'autosnap) 8) 8) (setq p t) (setq p nil))
  (if (eq (logand (getvar 'autosnap) 16) 16) (setq s t) (setq s nil))
  (prompt "\nSpecify precision (< / >) : ")
  (setq n 12)
  (setq z (trp (mapcar '(lambda ( x ) (trans x 1 2 t)) '((1.0 0.0) (0.0 1.0) (0.0 0.0)))))
  (while (not (eq (car (setq gr (grread t 15 0))) 3))
    (redraw)
    (if (listp (cadr gr))
      (progn
        (setq gp (cadr gr))
        (setq gpp (cadr gr))
        (if gps (setq an (angle pp gps)) (setq an (angle pp gp)))
        (if gps (setq d (distance pp gps)) (setq d (distance pp gp)))
        (setq l1 (hcirl1 n -1))
        (setq l2 (hcirl2 n -1))
        (setq l3 (hcirl3 n -1))
        (setq l4 (hcirl4 n -1))
        (grvecs (append l1 l2 l3 l4)
          (append
            (mapcar 'append
              (mxm z
                (list
                  (list (* d (cos an)) (* d (sin (- an))) 0.0)
                  (list (* d (sin an)) (* d (cos an))     0.0)
                 '(0.0 0.0 1.0)
                )
              )
              (mapcar 'list (trans pp 1 2))
            )
           '((0.0 0.0 0.0 1.0))
          )
        )
      )
    )
    (cond
      ( (eq (cadr gr) 15)
        (if (eq o t) (setq o nil) (setq o t))
      )
      ( (eq (cadr gr) 21)
        (if (eq p t) (setq p nil) (setq p t))
      )
      ( (eq (cadr gr) 6)
        (if (eq s t) (setq s nil) (setq s t))
      )
    )
    (cond
      ( (and o p s)
        (setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
      )
      ( (and o (not p) s)
        (setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
      )
      ( (and (not o) p s)
        (setq gps (_snap (_polar pp gp t (getvar 'polarang)) (getvar 'osmode)))
      )
      ( (and (not o) (not p) s)
        (setq gps (_snap gp (getvar 'osmode)))
      )
      ( (and o p (not s))
        (setq gps (_ortho pp gp t))
      )
      ( (and o (not p) (not s))
        (setq gps (_ortho pp gp t))
      )
      ( (and (not o) p (not s))
        (setq gps (_polar pp gp t (getvar 'polarang)))
      )
      ( (and (not o) (not p) (not s))
        (setq gps gp)
      )
    )
    (if (not (equal gps gpp 1e-6))
      (_grX gps (atoi (getenv "AutoSnapSize")) (_OLE->ACI (if (= 1 (getvar 'cvport)) (atoi (getenv "Layout AutoSnap Color")) (atoi (getenv "Model AutoSnap Color")))))
    )
    (if (eq (cadr gr) 60) (setq n (1- n)))
    (if (eq (cadr gr) 62) (setq n (1+ n)))
    (if (zerop n) (setq n 1))
  )
  (setq an (angle pp gps))
  (setq d (distance pp gps))
  (setq z (trans '(0.0 0.0 1.0) 1 0 t))
  (setq p1 (polar pp an d))
  (setq p2 (polar pp (+ (* 1.0 pi) an) d))
  (setq p3 pp)
  (setq p4 (polar pp (+ (* 1.0 pi) an) (* 0.5 d)))
  (setq p5 (polar pp (+ (* 1.0 pi) an) (* 0.25 d)))
  (entmake (list
                  '(0 . "LWPOLYLINE")
                  '(100 . "AcDbEntity")
                  '(100 . "AcDbPolyline")
                  '(90 . 5)
                  (cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
                  (cons 38 (caddr (trans pp 1 z)))
                  (cons 10 (trans p1 1 z))
                  (cons 42 -1.0)
                  (cons 10 (trans p2 1 z))
                  (cons 42 -1.0)
                  (cons 10 (trans p3 1 z))
                  (cons 42 -1.0)
                  (cons 10 (trans p4 1 z))
                  (cons 42 -1.0)
                  (cons 10 (trans p5 1 z))
                  (cons 42 0.0)
                  (cons 210 z)
           )
  )
  (redraw)
  (while (eq (getstring "\nAnother turn - ENTER; Any other key+ENTER to finish") "")
    (setq pp (polar p5 (+ (* 1.0 pi) an) (* 0.0625 d)))
    (setq d (* 0.0625 d))
    (setq p1 (polar pp an d))
    (setq p2 (polar pp (+ (* 1.0 pi) an) d))
    (setq p3 pp)
    (setq p4 (polar pp (+ (* 1.0 pi) an) (* 0.5 d)))
    (setq p5 (polar pp (+ (* 1.0 pi) an) (* 0.25 d)))
    (entmake (list
                    '(0 . "LWPOLYLINE")
                    '(100 . "AcDbEntity")
                    '(100 . "AcDbPolyline")
                    '(90 . 5)
                    (cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
                    (cons 38 (caddr (trans pp 1 z)))
                    (cons 10 (trans p1 1 z))
                    (cons 42 -1.0)
                    (cons 10 (trans p2 1 z))
                    (cons 42 -1.0)
                    (cons 10 (trans p3 1 z))
                    (cons 42 -1.0)
                    (cons 10 (trans p4 1 z))
                    (cons 42 -1.0)
                    (cons 10 (trans p5 1 z))
                    (cons 42 0.0)
                    (cons 210 z)
             )
    )
  )
  (*error* nil)
)
Title: Re: Examples of usage GRREAD - let's share
Post by: ribarm on May 30, 2014, 05:50:55 AM
Half circles HELIX (ccw)

Code: [Select]
(defun c:chccw ( / *error* trp mxm mxv _acapp _getosmode _grX _OLE->ACI _OLE->RGB _RGB->ACI _snap _polarangs _polar _ortho ape as osm hcirl1 hcirl2 hcirl3 hcirl4 l1 l2 l3 l4 p1 p2 p3 p4 p5 o p s pp n z gr gp gps gpp an d )

  (vl-load-com)

  (defun *error* ( msg )
    (if ape (setvar 'aperture ape))
    (if as (setvar 'autosnap as))
    (if osm (setvar 'osmode osm))
    (if msg (prompt msg))
    (princ)
  )

  ;; Matrix Transpose  -  Doug Wilson
  ;; Args: m - nxn matrix
   
  (defun trp ( m )
      (apply 'mapcar (cons 'list m))
  )
   
  ;; Matrix x Matrix  -  Vladimir Nesterovsky
  ;; Args: m,n - nxn matrices
   
  (defun mxm ( m n )
      ((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
  )
   
  ;; Matrix x Vector  -  Vladimir Nesterovsky
  ;; Args: m - nxn matrix, v - vector in R^n
   
  (defun mxv ( m v )
      (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
  )

  (defun _acapp nil
      (eval (list 'defun '_acapp 'nil (vlax-get-acad-object)))
      (_acapp)
  )

  (defun _getosmode ( os / lst )
      (foreach mode
         '(
              (0001 . "_end")
              (0002 . "_mid")
              (0004 . "_cen")
              (0008 . "_nod")
              (0016 . "_qua")
              (0032 . "_int")
              (0064 . "_ins")
              (0128 . "_per")
              (0256 . "_tan")
              (0512 . "_nea")
              (1024 . "_qui")
              (2048 . "_app")
              (4096 . "_ext")
              (8192 . "_par")
          )
          (if (not (zerop (logand (car mode) os)))
              (setq lst (cons "," (cons (cdr mode) lst)))
          )
      )
      (apply 'strcat (cdr lst))
  )

  (defun _grX ( p s c / -s r j )
      (setq -s (- s)
             r (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
             j p
      )
      (grdraw (mapcar '+ j (list (* r -s) (* r -s))) (mapcar '+ j (list (* r s) (* r s))) c)
      (grdraw (mapcar '+ j (list (* r -s) (* r (1+ -s)))) (mapcar '+ j (list (* r (1- s)) (* r s))) c)
      (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r -s))) (mapcar '+ j (list (* r s) (* r (1- s)))) c)
     
      (grdraw (mapcar '+ j (list (* r -s) (* r s))) (mapcar '+ j (list (* r s) (* r -s))) c)
      (grdraw (mapcar '+ j (list (* r -s) (* r (1- s)))) (mapcar '+ j (list (* r (1- s)) (* r -s))) c)
      (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r s))) (mapcar '+ j (list (* r s) (* r (1+ -s)))) c)

      p
  )

  (defun _OLE->ACI ( c )
      (apply '_RGB->ACI (_OLE->RGB c))
  )

  (defun _OLE->RGB ( c )
      (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(24 16 8))
  )

  (defun _RGB->ACI ( r g b / c o )
      (if (setq o (vla-getinterfaceobject (_acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
          (progn
              (setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
              (vlax-release-object o)
              (if (vl-catch-all-error-p c)
                  (prompt (strcat "\nError: " (vl-catch-all-error-message c)))
                  c
              )
          )
      )
  )

  (defun _snap ( p osm )
    (if (osnap p (_getosmode osm))
      (osnap p (_getosmode osm))
      p
    )
  )

  (defun _polarangs ( ang / n k a l )
    (if (/= ang 0.0)
      (progn
        (setq n (/ 360.1 (cvunit ang "radians" "degrees")))
        (setq k -1.0)
        (repeat (1+ (fix n))
          (setq a (* (setq k (1+ k)) ang))
          (setq l (cons a l))
        )
        l
      )
      (list 0.0)
    )
  )

  (defun _polar ( p0 p flag ang / a b an )
    (if flag
      (progn
        (setq a (car (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
        (setq b (last (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
        (if (< (abs (- (angle p0 p) a)) (abs (- (angle p0 p) b))) (setq an a) (setq an b))
        (inters p0 (polar p0 an 1.0) p (polar p (+ an (* 0.5 pi)) 1.0) nil)
      )
      p
    )
  )

  (defun _ortho ( p0 p flag )
    (if flag
      (_polar p0 p t (* 0.5 pi))
      p
    )
  )

  (defun hcirl1 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* 1.0 pi) n))
    (repeat n
      (setq p1 (polar '(0. 0. 0.) (* a (setq k (1+ k))) 1.))
      (setq p2 (polar '(0. 0. 0.) (* a (1+ k)) 1.))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )
 
  (defun hcirl2 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* 1.0 pi) n))
    (repeat n
      (setq p1 (polar (list -0.5 0. 0.) (+ (* 1.0 pi) (* a (setq k (1+ k)))) 0.5))
      (setq p2 (polar (list -0.5 0. 0.) (+ (* 1.0 pi) (* a (1+ k))) 0.5))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (defun hcirl3 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* 1.0 pi) n))
    (repeat n
      (setq p1 (polar (list -0.25 0. 0.) (+ (* 0.0 pi) (* a (setq k (1+ k)))) 0.25))
      (setq p2 (polar (list -0.25 0. 0.) (+ (* 0.0 pi) (* a (1+ k))) 0.25))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (defun hcirl4 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* 1.0 pi) n))
    (repeat n
      (setq p1 (polar (list -0.375 0. 0.) (+ (* 1.0 pi) (* a (setq k (1+ k)))) 0.125))
      (setq p2 (polar (list -0.375 0. 0.) (+ (* 1.0 pi) (* a (1+ k))) 0.125))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (setq pp (getpoint "\nPick or specify center point : "))
  (setvar 'orthomode 1)
  (setq ape (getvar 'aperture))
  (setvar 'aperture 40)
  (setq as (getvar 'autosnap))
  (setvar 'autosnap 31)
  (setq osm (getvar 'osmode))
  (setvar 'osmode 15359)
  (if (eq (getvar 'orthomode) 1) (setq o t) (setq o nil))
  (if (eq (logand (getvar 'autosnap) 8) 8) (setq p t) (setq p nil))
  (if (eq (logand (getvar 'autosnap) 16) 16) (setq s t) (setq s nil))
  (prompt "\nSpecify precision (< / >) : ")
  (setq n 12)
  (setq z (trp (mapcar '(lambda ( x ) (trans x 1 2 t)) '((1.0 0.0) (0.0 1.0) (0.0 0.0)))))
  (while (not (eq (car (setq gr (grread t 15 0))) 3))
    (redraw)
    (if (listp (cadr gr))
      (progn
        (setq gp (cadr gr))
        (setq gpp (cadr gr))
        (if gps (setq an (angle pp gps)) (setq an (angle pp gp)))
        (if gps (setq d (distance pp gps)) (setq d (distance pp gp)))
        (setq l1 (hcirl1 n -1))
        (setq l2 (hcirl2 n -1))
        (setq l3 (hcirl3 n -1))
        (setq l4 (hcirl4 n -1))
        (grvecs (append l1 l2 l3 l4)
          (append
            (mapcar 'append
              (mxm z
                (list
                  (list (* d (cos an)) (* d (sin (- an))) 0.0)
                  (list (* d (sin an)) (* d (cos an))     0.0)
                 '(0.0 0.0 1.0)
                )
              )
              (mapcar 'list (trans pp 1 2))
            )
           '((0.0 0.0 0.0 1.0))
          )
        )
      )
    )
    (cond
      ( (eq (cadr gr) 15)
        (if (eq o t) (setq o nil) (setq o t))
      )
      ( (eq (cadr gr) 21)
        (if (eq p t) (setq p nil) (setq p t))
      )
      ( (eq (cadr gr) 6)
        (if (eq s t) (setq s nil) (setq s t))
      )
    )
    (cond
      ( (and o p s)
        (setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
      )
      ( (and o (not p) s)
        (setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
      )
      ( (and (not o) p s)
        (setq gps (_snap (_polar pp gp t (getvar 'polarang)) (getvar 'osmode)))
      )
      ( (and (not o) (not p) s)
        (setq gps (_snap gp (getvar 'osmode)))
      )
      ( (and o p (not s))
        (setq gps (_ortho pp gp t))
      )
      ( (and o (not p) (not s))
        (setq gps (_ortho pp gp t))
      )
      ( (and (not o) p (not s))
        (setq gps (_polar pp gp t (getvar 'polarang)))
      )
      ( (and (not o) (not p) (not s))
        (setq gps gp)
      )
    )
    (if (not (equal gps gpp 1e-6))
      (_grX gps (atoi (getenv "AutoSnapSize")) (_OLE->ACI (if (= 1 (getvar 'cvport)) (atoi (getenv "Layout AutoSnap Color")) (atoi (getenv "Model AutoSnap Color")))))
    )
    (if (eq (cadr gr) 60) (setq n (1- n)))
    (if (eq (cadr gr) 62) (setq n (1+ n)))
    (if (zerop n) (setq n 1))
  )
  (setq an (angle pp gps))
  (setq d (distance pp gps))
  (setq z (trans '(0.0 0.0 1.0) 1 0 t))
  (setq p1 (polar pp an d))
  (setq p2 (polar pp (+ (* 1.0 pi) an) d))
  (setq p3 pp)
  (setq p4 (polar pp (+ (* 1.0 pi) an) (* 0.5 d)))
  (setq p5 (polar pp (+ (* 1.0 pi) an) (* 0.25 d)))
  (entmake (list
                  '(0 . "LWPOLYLINE")
                  '(100 . "AcDbEntity")
                  '(100 . "AcDbPolyline")
                  '(90 . 5)
                  (cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
                  (cons 38 (caddr (trans pp 1 z)))
                  (cons 10 (trans p1 1 z))
                  (cons 42 1.0)
                  (cons 10 (trans p2 1 z))
                  (cons 42 1.0)
                  (cons 10 (trans p3 1 z))
                  (cons 42 1.0)
                  (cons 10 (trans p4 1 z))
                  (cons 42 1.0)
                  (cons 10 (trans p5 1 z))
                  (cons 42 0.0)
                  (cons 210 z)
           )
  )
  (redraw)
  (while (eq (getstring "\nAnother turn - ENTER; Any other key+ENTER to finish") "")
    (setq pp (polar p5 (+ (* 1.0 pi) an) (* 0.0625 d)))
    (setq d (* 0.0625 d))
    (setq p1 (polar pp an d))
    (setq p2 (polar pp (+ (* 1.0 pi) an) d))
    (setq p3 pp)
    (setq p4 (polar pp (+ (* 1.0 pi) an) (* 0.5 d)))
    (setq p5 (polar pp (+ (* 1.0 pi) an) (* 0.25 d)))
    (entmake (list
                    '(0 . "LWPOLYLINE")
                    '(100 . "AcDbEntity")
                    '(100 . "AcDbPolyline")
                    '(90 . 5)
                    (cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
                    (cons 38 (caddr (trans pp 1 z)))
                    (cons 10 (trans p1 1 z))
                    (cons 42 1.0)
                    (cons 10 (trans p2 1 z))
                    (cons 42 1.0)
                    (cons 10 (trans p3 1 z))
                    (cons 42 1.0)
                    (cons 10 (trans p4 1 z))
                    (cons 42 1.0)
                    (cons 10 (trans p5 1 z))
                    (cons 42 0.0)
                    (cons 210 z)
             )
    )
  )
  (*error* nil)
)
Title: Re: Examples of usage GRREAD - let's share
Post by: ribarm on May 30, 2014, 05:51:53 AM
Three quarter circles HELIX (cw)

Code: [Select]
(defun c:cqhcw ( / *error* trp mxm mxv _acapp _getosmode _grX _OLE->ACI _OLE->RGB _RGB->ACI _snap _polarangs _polar _ortho ape as osm hcirl1 hcirl2 hcirl3 hcirl4 l1 l2 l3 l4 p1 p2 p3 p4 p5 o p s pp n z gr gp gps gpp an d )

  (vl-load-com)

  (defun *error* ( msg )
    (if ape (setvar 'aperture ape))
    (if as (setvar 'autosnap as))
    (if osm (setvar 'osmode osm))
    (if msg (prompt msg))
    (princ)
  )

  ;; Matrix Transpose  -  Doug Wilson
  ;; Args: m - nxn matrix
   
  (defun trp ( m )
      (apply 'mapcar (cons 'list m))
  )
   
  ;; Matrix x Matrix  -  Vladimir Nesterovsky
  ;; Args: m,n - nxn matrices
   
  (defun mxm ( m n )
      ((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
  )
   
  ;; Matrix x Vector  -  Vladimir Nesterovsky
  ;; Args: m - nxn matrix, v - vector in R^n
   
  (defun mxv ( m v )
      (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
  )

  (defun _acapp nil
      (eval (list 'defun '_acapp 'nil (vlax-get-acad-object)))
      (_acapp)
  )

  (defun _getosmode ( os / lst )
      (foreach mode
         '(
              (0001 . "_end")
              (0002 . "_mid")
              (0004 . "_cen")
              (0008 . "_nod")
              (0016 . "_qua")
              (0032 . "_int")
              (0064 . "_ins")
              (0128 . "_per")
              (0256 . "_tan")
              (0512 . "_nea")
              (1024 . "_qui")
              (2048 . "_app")
              (4096 . "_ext")
              (8192 . "_par")
          )
          (if (not (zerop (logand (car mode) os)))
              (setq lst (cons "," (cons (cdr mode) lst)))
          )
      )
      (apply 'strcat (cdr lst))
  )

  (defun _grX ( p s c / -s r j )
      (setq -s (- s)
             r (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
             j p
      )
      (grdraw (mapcar '+ j (list (* r -s) (* r -s))) (mapcar '+ j (list (* r s) (* r s))) c)
      (grdraw (mapcar '+ j (list (* r -s) (* r (1+ -s)))) (mapcar '+ j (list (* r (1- s)) (* r s))) c)
      (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r -s))) (mapcar '+ j (list (* r s) (* r (1- s)))) c)
     
      (grdraw (mapcar '+ j (list (* r -s) (* r s))) (mapcar '+ j (list (* r s) (* r -s))) c)
      (grdraw (mapcar '+ j (list (* r -s) (* r (1- s)))) (mapcar '+ j (list (* r (1- s)) (* r -s))) c)
      (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r s))) (mapcar '+ j (list (* r s) (* r (1+ -s)))) c)

      p
  )

  (defun _OLE->ACI ( c )
      (apply '_RGB->ACI (_OLE->RGB c))
  )

  (defun _OLE->RGB ( c )
      (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(24 16 8))
  )

  (defun _RGB->ACI ( r g b / c o )
      (if (setq o (vla-getinterfaceobject (_acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
          (progn
              (setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
              (vlax-release-object o)
              (if (vl-catch-all-error-p c)
                  (prompt (strcat "\nError: " (vl-catch-all-error-message c)))
                  c
              )
          )
      )
  )

  (defun _snap ( p osm )
    (if (osnap p (_getosmode osm))
      (osnap p (_getosmode osm))
      p
    )
  )

  (defun _polarangs ( ang / n k a l )
    (if (/= ang 0.0)
      (progn
        (setq n (/ 360.1 (cvunit ang "radians" "degrees")))
        (setq k -1.0)
        (repeat (1+ (fix n))
          (setq a (* (setq k (1+ k)) ang))
          (setq l (cons a l))
        )
        l
      )
      (list 0.0)
    )
  )

  (defun _polar ( p0 p flag ang / a b an )
    (if flag
      (progn
        (setq a (car (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
        (setq b (last (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
        (if (< (abs (- (angle p0 p) a)) (abs (- (angle p0 p) b))) (setq an a) (setq an b))
        (inters p0 (polar p0 an 1.0) p (polar p (+ an (* 0.5 pi)) 1.0) nil)
      )
      p
    )
  )

  (defun _ortho ( p0 p flag )
    (if flag
      (_polar p0 p t (* 0.5 pi))
      p
    )
  )

  (defun hcirl1 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* -1.0 pi) n))
    (repeat n
      (setq p1 (polar '(0. 0. 0.) (* a (setq k (1+ k))) 1.))
      (setq p2 (polar '(0. 0. 0.) (* a (1+ k)) 1.))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )
 
  (defun hcirl2 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* -1.0 pi) n))
    (repeat n
      (setq p1 (polar (list -0.25 0. 0.) (+ (* -1.0 pi) (* a (setq k (1+ k)))) 0.75))
      (setq p2 (polar (list -0.25 0. 0.) (+ (* -1.0 pi) (* a (1+ k))) 0.75))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (defun hcirl3 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* -1.0 pi) n))
    (repeat n
      (setq p1 (polar (list -0.0625 0. 0.) (+ (* 0.0 pi) (* a (setq k (1+ k)))) 0.5625))
      (setq p2 (polar (list -0.0625 0. 0.) (+ (* 0.0 pi) (* a (1+ k))) 0.5625))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (defun hcirl4 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* -1.0 pi) n))
    (repeat n
      (setq p1 (polar (list -0.203125 0. 0.) (+ (* -1.0 pi) (* a (setq k (1+ k)))) 0.421875))
      (setq p2 (polar (list -0.203125 0. 0.) (+ (* -1.0 pi) (* a (1+ k))) 0.421875))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (setq pp (getpoint "\nPick or specify center point : "))
  (setvar 'orthomode 1)
  (setq ape (getvar 'aperture))
  (setvar 'aperture 40)
  (setq as (getvar 'autosnap))
  (setvar 'autosnap 31)
  (setq osm (getvar 'osmode))
  (setvar 'osmode 15359)
  (if (eq (getvar 'orthomode) 1) (setq o t) (setq o nil))
  (if (eq (logand (getvar 'autosnap) 8) 8) (setq p t) (setq p nil))
  (if (eq (logand (getvar 'autosnap) 16) 16) (setq s t) (setq s nil))
  (prompt "\nSpecify precision (< / >) : ")
  (setq n 12)
  (setq z (trp (mapcar '(lambda ( x ) (trans x 1 2 t)) '((1.0 0.0) (0.0 1.0) (0.0 0.0)))))
  (while (not (eq (car (setq gr (grread t 15 0))) 3))
    (redraw)
    (if (listp (cadr gr))
      (progn
        (setq gp (cadr gr))
        (setq gpp (cadr gr))
        (if gps (setq an (angle pp gps)) (setq an (angle pp gp)))
        (if gps (setq d (distance pp gps)) (setq d (distance pp gp)))
        (setq l1 (hcirl1 n -1))
        (setq l2 (hcirl2 n -1))
        (setq l3 (hcirl3 n -1))
        (setq l4 (hcirl4 n -1))
        (grvecs (append l1 l2 l3 l4)
          (append
            (mapcar 'append
              (mxm z
                (list
                  (list (* d (cos an)) (* d (sin (- an))) 0.0)
                  (list (* d (sin an)) (* d (cos an))     0.0)
                 '(0.0 0.0 1.0)
                )
              )
              (mapcar 'list (trans pp 1 2))
            )
           '((0.0 0.0 0.0 1.0))
          )
        )
      )
    )
    (cond
      ( (eq (cadr gr) 15)
        (if (eq o t) (setq o nil) (setq o t))
      )
      ( (eq (cadr gr) 21)
        (if (eq p t) (setq p nil) (setq p t))
      )
      ( (eq (cadr gr) 6)
        (if (eq s t) (setq s nil) (setq s t))
      )
    )
    (cond
      ( (and o p s)
        (setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
      )
      ( (and o (not p) s)
        (setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
      )
      ( (and (not o) p s)
        (setq gps (_snap (_polar pp gp t (getvar 'polarang)) (getvar 'osmode)))
      )
      ( (and (not o) (not p) s)
        (setq gps (_snap gp (getvar 'osmode)))
      )
      ( (and o p (not s))
        (setq gps (_ortho pp gp t))
      )
      ( (and o (not p) (not s))
        (setq gps (_ortho pp gp t))
      )
      ( (and (not o) p (not s))
        (setq gps (_polar pp gp t (getvar 'polarang)))
      )
      ( (and (not o) (not p) (not s))
        (setq gps gp)
      )
    )
    (if (not (equal gps gpp 1e-6))
      (_grX gps (atoi (getenv "AutoSnapSize")) (_OLE->ACI (if (= 1 (getvar 'cvport)) (atoi (getenv "Layout AutoSnap Color")) (atoi (getenv "Model AutoSnap Color")))))
    )
    (if (eq (cadr gr) 60) (setq n (1- n)))
    (if (eq (cadr gr) 62) (setq n (1+ n)))
    (if (zerop n) (setq n 1))
  )
  (setq an (angle pp gps))
  (setq d (distance pp gps))
  (setq z (trans '(0.0 0.0 1.0) 1 0 t))
  (setq p1 (polar pp an d))
  (setq p2 (polar pp (+ (* 1.0 pi) an) d))
  (setq p3 (polar pp an (* 0.5 d)))
  (setq p4 (polar pp (+ (* 1.0 pi) an) (* 0.625 d)))
  (setq p5 (polar pp an (* 0.21875 d)))
  (entmake (list
                  '(0 . "LWPOLYLINE")
                  '(100 . "AcDbEntity")
                  '(100 . "AcDbPolyline")
                  '(90 . 5)
                  (cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
                  (cons 38 (caddr (trans pp 1 z)))
                  (cons 10 (trans p1 1 z))
                  (cons 42 -1.0)
                  (cons 10 (trans p2 1 z))
                  (cons 42 -1.0)
                  (cons 10 (trans p3 1 z))
                  (cons 42 -1.0)
                  (cons 10 (trans p4 1 z))
                  (cons 42 -1.0)
                  (cons 10 (trans p5 1 z))
                  (cons 42 0.0)
                  (cons 210 z)
           )
  )
  (redraw)
  (while (eq (getstring "\nAnother turn - ENTER; Any other key+ENTER to finish") "")
    (setq pp (polar p5 (+ (* 1.0 pi) an) (* 0.31640625 d)))
    (setq d (* 0.31640625 d))
    (setq p1 (polar pp an d))
    (setq p2 (polar pp (+ (* 1.0 pi) an) d))
    (setq p3 (polar pp an (* 0.5 d)))
    (setq p4 (polar pp (+ (* 1.0 pi) an) (* 0.625 d)))
    (setq p5 (polar pp an (* 0.21875 d)))
    (entmake (list
                    '(0 . "LWPOLYLINE")
                    '(100 . "AcDbEntity")
                    '(100 . "AcDbPolyline")
                    '(90 . 5)
                    (cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
                    (cons 38 (caddr (trans pp 1 z)))
                    (cons 10 (trans p1 1 z))
                    (cons 42 -1.0)
                    (cons 10 (trans p2 1 z))
                    (cons 42 -1.0)
                    (cons 10 (trans p3 1 z))
                    (cons 42 -1.0)
                    (cons 10 (trans p4 1 z))
                    (cons 42 -1.0)
                    (cons 10 (trans p5 1 z))
                    (cons 42 0.0)
                    (cons 210 z)
             )
    )
  )
  (*error* nil)
)
Title: Re: Examples of usage GRREAD - let's share
Post by: ribarm on May 30, 2014, 05:52:38 AM
Three quarter circles HELIX (ccw)

Code: [Select]
(defun c:cqhccw ( / *error* trp mxm mxv _acapp _getosmode _grX _OLE->ACI _OLE->RGB _RGB->ACI _snap _polarangs _polar _ortho ape as osm hcirl1 hcirl2 hcirl3 hcirl4 l1 l2 l3 l4 p1 p2 p3 p4 p5 o p s pp n z gr gp gps gpp an d )

  (vl-load-com)

  (defun *error* ( msg )
    (if ape (setvar 'aperture ape))
    (if as (setvar 'autosnap as))
    (if osm (setvar 'osmode osm))
    (if msg (prompt msg))
    (princ)
  )

  ;; Matrix Transpose  -  Doug Wilson
  ;; Args: m - nxn matrix
   
  (defun trp ( m )
      (apply 'mapcar (cons 'list m))
  )
   
  ;; Matrix x Matrix  -  Vladimir Nesterovsky
  ;; Args: m,n - nxn matrices
   
  (defun mxm ( m n )
      ((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
  )
   
  ;; Matrix x Vector  -  Vladimir Nesterovsky
  ;; Args: m - nxn matrix, v - vector in R^n
   
  (defun mxv ( m v )
      (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
  )

  (defun _acapp nil
      (eval (list 'defun '_acapp 'nil (vlax-get-acad-object)))
      (_acapp)
  )

  (defun _getosmode ( os / lst )
      (foreach mode
         '(
              (0001 . "_end")
              (0002 . "_mid")
              (0004 . "_cen")
              (0008 . "_nod")
              (0016 . "_qua")
              (0032 . "_int")
              (0064 . "_ins")
              (0128 . "_per")
              (0256 . "_tan")
              (0512 . "_nea")
              (1024 . "_qui")
              (2048 . "_app")
              (4096 . "_ext")
              (8192 . "_par")
          )
          (if (not (zerop (logand (car mode) os)))
              (setq lst (cons "," (cons (cdr mode) lst)))
          )
      )
      (apply 'strcat (cdr lst))
  )

  (defun _grX ( p s c / -s r j )
      (setq -s (- s)
             r (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
             j p
      )
      (grdraw (mapcar '+ j (list (* r -s) (* r -s))) (mapcar '+ j (list (* r s) (* r s))) c)
      (grdraw (mapcar '+ j (list (* r -s) (* r (1+ -s)))) (mapcar '+ j (list (* r (1- s)) (* r s))) c)
      (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r -s))) (mapcar '+ j (list (* r s) (* r (1- s)))) c)
     
      (grdraw (mapcar '+ j (list (* r -s) (* r s))) (mapcar '+ j (list (* r s) (* r -s))) c)
      (grdraw (mapcar '+ j (list (* r -s) (* r (1- s)))) (mapcar '+ j (list (* r (1- s)) (* r -s))) c)
      (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r s))) (mapcar '+ j (list (* r s) (* r (1+ -s)))) c)

      p
  )

  (defun _OLE->ACI ( c )
      (apply '_RGB->ACI (_OLE->RGB c))
  )

  (defun _OLE->RGB ( c )
      (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(24 16 8))
  )

  (defun _RGB->ACI ( r g b / c o )
      (if (setq o (vla-getinterfaceobject (_acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
          (progn
              (setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
              (vlax-release-object o)
              (if (vl-catch-all-error-p c)
                  (prompt (strcat "\nError: " (vl-catch-all-error-message c)))
                  c
              )
          )
      )
  )

  (defun _snap ( p osm )
    (if (osnap p (_getosmode osm))
      (osnap p (_getosmode osm))
      p
    )
  )

  (defun _polarangs ( ang / n k a l )
    (if (/= ang 0.0)
      (progn
        (setq n (/ 360.1 (cvunit ang "radians" "degrees")))
        (setq k -1.0)
        (repeat (1+ (fix n))
          (setq a (* (setq k (1+ k)) ang))
          (setq l (cons a l))
        )
        l
      )
      (list 0.0)
    )
  )

  (defun _polar ( p0 p flag ang / a b an )
    (if flag
      (progn
        (setq a (car (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
        (setq b (last (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
        (if (< (abs (- (angle p0 p) a)) (abs (- (angle p0 p) b))) (setq an a) (setq an b))
        (inters p0 (polar p0 an 1.0) p (polar p (+ an (* 0.5 pi)) 1.0) nil)
      )
      p
    )
  )

  (defun _ortho ( p0 p flag )
    (if flag
      (_polar p0 p t (* 0.5 pi))
      p
    )
  )

  (defun hcirl1 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* 1.0 pi) n))
    (repeat n
      (setq p1 (polar '(0. 0. 0.) (* a (setq k (1+ k))) 1.))
      (setq p2 (polar '(0. 0. 0.) (* a (1+ k)) 1.))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )
 
  (defun hcirl2 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* 1.0 pi) n))
    (repeat n
      (setq p1 (polar (list -0.25 0. 0.) (+ (* 1.0 pi) (* a (setq k (1+ k)))) 0.75))
      (setq p2 (polar (list -0.25 0. 0.) (+ (* 1.0 pi) (* a (1+ k))) 0.75))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (defun hcirl3 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* 1.0 pi) n))
    (repeat n
      (setq p1 (polar (list -0.0625 0. 0.) (+ (* 0.0 pi) (* a (setq k (1+ k)))) 0.5625))
      (setq p2 (polar (list -0.0625 0. 0.) (+ (* 0.0 pi) (* a (1+ k))) 0.5625))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (defun hcirl4 ( n c / k a p1 p2 li lst )
    (setq k -1)
    (setq a (/ (* 1.0 pi) n))
    (repeat n
      (setq p1 (polar (list -0.203125 0. 0.) (+ (* 1.0 pi) (* a (setq k (1+ k)))) 0.421875))
      (setq p2 (polar (list -0.203125 0. 0.) (+ (* 1.0 pi) (* a (1+ k))) 0.421875))
      (setq li (cons c (list p1 p2)))
      (setq lst (cons li lst))
    )
    (apply 'append (reverse lst))
  )

  (setq pp (getpoint "\nPick or specify center point : "))
  (setvar 'orthomode 1)
  (setq ape (getvar 'aperture))
  (setvar 'aperture 40)
  (setq as (getvar 'autosnap))
  (setvar 'autosnap 31)
  (setq osm (getvar 'osmode))
  (setvar 'osmode 15359)
  (if (eq (getvar 'orthomode) 1) (setq o t) (setq o nil))
  (if (eq (logand (getvar 'autosnap) 8) 8) (setq p t) (setq p nil))
  (if (eq (logand (getvar 'autosnap) 16) 16) (setq s t) (setq s nil))
  (prompt "\nSpecify precision (< / >) : ")
  (setq n 12)
  (setq z (trp (mapcar '(lambda ( x ) (trans x 1 2 t)) '((1.0 0.0) (0.0 1.0) (0.0 0.0)))))
  (while (not (eq (car (setq gr (grread t 15 0))) 3))
    (redraw)
    (if (listp (cadr gr))
      (progn
        (setq gp (cadr gr))
        (setq gpp (cadr gr))
        (if gps (setq an (angle pp gps)) (setq an (angle pp gp)))
        (if gps (setq d (distance pp gps)) (setq d (distance pp gp)))
        (setq l1 (hcirl1 n -1))
        (setq l2 (hcirl2 n -1))
        (setq l3 (hcirl3 n -1))
        (setq l4 (hcirl4 n -1))
        (grvecs (append l1 l2 l3 l4)
          (append
            (mapcar 'append
              (mxm z
                (list
                  (list (* d (cos an)) (* d (sin (- an))) 0.0)
                  (list (* d (sin an)) (* d (cos an))     0.0)
                 '(0.0 0.0 1.0)
                )
              )
              (mapcar 'list (trans pp 1 2))
            )
           '((0.0 0.0 0.0 1.0))
          )
        )
      )
    )
    (cond
      ( (eq (cadr gr) 15)
        (if (eq o t) (setq o nil) (setq o t))
      )
      ( (eq (cadr gr) 21)
        (if (eq p t) (setq p nil) (setq p t))
      )
      ( (eq (cadr gr) 6)
        (if (eq s t) (setq s nil) (setq s t))
      )
    )
    (cond
      ( (and o p s)
        (setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
      )
      ( (and o (not p) s)
        (setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
      )
      ( (and (not o) p s)
        (setq gps (_snap (_polar pp gp t (getvar 'polarang)) (getvar 'osmode)))
      )
      ( (and (not o) (not p) s)
        (setq gps (_snap gp (getvar 'osmode)))
      )
      ( (and o p (not s))
        (setq gps (_ortho pp gp t))
      )
      ( (and o (not p) (not s))
        (setq gps (_ortho pp gp t))
      )
      ( (and (not o) p (not s))
        (setq gps (_polar pp gp t (getvar 'polarang)))
      )
      ( (and (not o) (not p) (not s))
        (setq gps gp)
      )
    )
    (if (not (equal gps gpp 1e-6))
      (_grX gps (atoi (getenv "AutoSnapSize")) (_OLE->ACI (if (= 1 (getvar 'cvport)) (atoi (getenv "Layout AutoSnap Color")) (atoi (getenv "Model AutoSnap Color")))))
    )
    (if (eq (cadr gr) 60) (setq n (1- n)))
    (if (eq (cadr gr) 62) (setq n (1+ n)))
    (if (zerop n) (setq n 1))
  )
  (setq an (angle pp gps))
  (setq d (distance pp gps))
  (setq z (trans '(0.0 0.0 1.0) 1 0 t))
  (setq p1 (polar pp an d))
  (setq p2 (polar pp (+ (* 1.0 pi) an) d))
  (setq p3 (polar pp an (* 0.5 d)))
  (setq p4 (polar pp (+ (* 1.0 pi) an) (* 0.625 d)))
  (setq p5 (polar pp an (* 0.21875 d)))
  (entmake (list
                  '(0 . "LWPOLYLINE")
                  '(100 . "AcDbEntity")
                  '(100 . "AcDbPolyline")
                  '(90 . 5)
                  (cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
                  (cons 38 (caddr (trans pp 1 z)))
                  (cons 10 (trans p1 1 z))
                  (cons 42 1.0)
                  (cons 10 (trans p2 1 z))
                  (cons 42 1.0)
                  (cons 10 (trans p3 1 z))
                  (cons 42 1.0)
                  (cons 10 (trans p4 1 z))
                  (cons 42 1.0)
                  (cons 10 (trans p5 1 z))
                  (cons 42 0.0)
                  (cons 210 z)
           )
  )
  (redraw)
  (while (eq (getstring "\nAnother turn - ENTER; Any other key+ENTER to finish") "")
    (setq pp (polar p5 (+ (* 1.0 pi) an) (* 0.31640625 d)))
    (setq d (* 0.31640625 d))
    (setq p1 (polar pp an d))
    (setq p2 (polar pp (+ (* 1.0 pi) an) d))
    (setq p3 (polar pp an (* 0.5 d)))
    (setq p4 (polar pp (+ (* 1.0 pi) an) (* 0.625 d)))
    (setq p5 (polar pp an (* 0.21875 d)))
    (entmake (list
                    '(0 . "LWPOLYLINE")
                    '(100 . "AcDbEntity")
                    '(100 . "AcDbPolyline")
                    '(90 . 5)
                    (cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
                    (cons 38 (caddr (trans pp 1 z)))
                    (cons 10 (trans p1 1 z))
                    (cons 42 1.0)
                    (cons 10 (trans p2 1 z))
                    (cons 42 1.0)
                    (cons 10 (trans p3 1 z))
                    (cons 42 1.0)
                    (cons 10 (trans p4 1 z))
                    (cons 42 1.0)
                    (cons 10 (trans p5 1 z))
                    (cons 42 0.0)
                    (cons 210 z)
             )
    )
  )
  (*error* nil)
)
Title: Re: Examples of usage GRREAD - let's share
Post by: reltro on May 30, 2014, 12:33:15 PM
Here is an other to draw a rectangle with a specific ratio...

Starts with 1:2

Its a lil useless without OSNAP... :(

Code: [Select]
(defun C:Rect,Ratio ( / P1 P vector,Len vector,Len,get vector,Len,set vector,cross opt arsin arcos opt2 Rect0 Rect1 Rect2 Rect3 tmpRatio typed UserPrompt)
    (setq    P1                (getpoint "Pick StartPoint: ")
            vector,Len,get    (lambda (v / )        (sqrt (apply '+ (mapcar '(lambda (a / ) (expt a 2)) v))))
            vector,Len,set    (lambda (v l / f)    (setq f (/ (float l) (vector,Len,get v))) (mapcar '(lambda (a /) (* a f)) v))
            vector,cross    (lambda (a b)
                                (mapcar
                                    '(lambda (n / )
                                        (-
                                            (* (nth (car n) a)(nth (cadr n) b))
                                            (* (nth (cadr n) a) (nth (car n) b))
                                        )
                                    )
                                    '((1 2) (2 0) (0 1))
                                )
                            )
            arsin            (lambda (x)
                                (cond
                                    ((= x 1.0) (/ pi 2.0))
                                    ((= x -1.0) (/ pi -2.0))
                                    ((< (abs x) 1.0) (atan (/ x (sqrt (- 1.0 (* x x))))))
                                    ('default (*error* (strcat "\n error: bad argument: " (rtos (abs x) 2) ">1.0\n ")))
                                )
                            )
            opt                0
            opt2            0
            ratio            2
    )
    (setq UserPrompt (lambda (/) (princ "\nPick Second Point or toogle between modes with RIGHTMOUSE and TAB or enter a new ratio (1:x) ")))
   
    (eval
        (list 'defun '*error* '(msg / )
            (list
                (lambda (err / )
                    (setq *error* err)
                    (redraw)
                    (if msg
                        (progn
                            (if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*"))
                                (princ msg)
                            )
                            (*error* msg)
                        )
                    )
                )
                *error*
            )
        )
    )
   
    (UserPrompt)
   
    (while (not (= (car (setq P (grread 'T))) 3))
        (cond
            ((= (car P) 5)
                (    (lambda (P / v l v,perp H ang)
                        (setq    v (mapcar '- P P1)
                                l (vector,Len,get v)
                        )
                        (if (> l 0)
                            (cond
                                ((= opt 0)
                                    (setq v,perp
                                        (vector,Len,set
                                            (vector,cross v '(0 0 1))
                                            (if (= opt2 0)
                                                (/ l (float ratio))
                                                (* l ratio)
                                            )
                                        )
                                    )
                                   
                                    (setq    Rect0 P1
                                            Rect1 (mapcar '+ P1 v,perp)
                                            Rect2 (mapcar '+ Rect1 v)
                                            Rect3 P
                                    )
                                    (redraw)
                                    (grvecs (list -7 Rect0 Rect1 Rect1 Rect2 Rect2 Rect3 Rect3 Rect0))
                                )
                                ((= opt 1)
                                    (setq v,perp
                                        (vector,Len,set
                                            (vector,cross v '(0 0 -1))
                                            (if (= opt2 0)
                                                (/ l (float ratio))
                                                (* l ratio)
                                            )
                                        )
                                    )
                                   
                                    (setq    Rect0 P1
                                            Rect1 (mapcar '+ P1 v,perp)
                                            Rect2 (mapcar '+ Rect1 v)
                                            Rect3 P
                                    )
                                    (redraw)
                                    (grvecs (list -7 Rect0 Rect1 Rect1 Rect2 Rect2 Rect3 Rect3 Rect0))
                                )
                                ((= opt 2)
                                    (setq H (sqrt (+ 1 (expt ratio 2))))
                                    (setq ang (arsin (/ ratio H)))
                                    (setq l    (* (cos ang) l))
                                   
                                    (setq ang
                                        (if (= opt2 0)
                                            (- (angle P1 P) ang)
                                            (+ (angle P1 P) ang)
                                        )
                                    )
                                   
                                    (setq    Rect0 P1
                                            Rect1 (polar P1 ang l)
                                            Rect2 P
                                            Rect3 (polar Rect2 ang (* -1 l))
                                    )
                                   
                                    (redraw)
                                    (grvecs (list -7 Rect0 Rect1 Rect1 Rect2 Rect2 Rect3 Rect3 Rect0))
                                )
                            )
                        )
                    )
                    (cadr P)
                )
            )
            ((= (car P) 25)
                (if (= opt 2)
                    (setq opt 0)
                    (setq opt (1+ opt))
                )
            )
            ((and (= (car P) 2) (or (and (> (cadr P) 47) (< (cadr P) 58)) (= (cadr P) 46)))
                (setq typed (chr (cadr P)))
                (princ typed)
                (setq tmpRatio (cons typed tmpRatio))
            )
            ((and (= (car P) 2) (= (cadr P) 8))
                (princ (chr (cadr P)))
                (setq tmpRatio (cdr tmpRatio))
            )
            ((and (= (car P) 2) (or (= (cadr P) 13) (= (cadr P) 32)))
                (if tmpRatio
                    (setq    ratio        (read (apply 'strcat (reverse tmpRatio)))
                            tmpRatio    nil
                    )
                )
                (UserPrompt)
            )
            ((and (= (car P) 2) (= (cadr P) 9))
                (if (= opt2 1)
                    (setq opt2 0)
                    (setq opt2 1)
                )
            )
        )
    )
    (if (apply 'and '(Rect0 Rect1 Rect2 Rect3))
        (command "_pline" Rect0 Rect1 Rect2 Rect3 "_close")
    )
   
    (*error* nil)
)

reltro
Title: Re: Examples of usage GRREAD - let's share
Post by: ribarm on May 30, 2014, 02:38:48 PM
Its a lil useless without OSNAP... :(

This reminds me on this topic... grread without dynamic draw...
Here is how would Lee Mac make it work with SNAPS...

http://www.cadtutor.net/forum/showthread.php?82662-Rectangle-lisp.Little-help-!/page3&p=#25
Title: Re: Examples of usage GRREAD - let's share
Post by: Jeremy on May 30, 2014, 03:34:42 PM
Reltro,

Very neat menu concept! Have you considered using entmake to create text on the fly rather than vectoring it? One small suggestion, make the text that names the current command a different color than white so that it stands out a little more.
Title: Re: Examples of usage GRREAD - let's share
Post by: ribarm on May 31, 2014, 02:15:03 AM
Reltro,

I've implemented Lee's SNAPS to your function... Hope you don't mind...

Code: [Select]
(defun C:Rect,Ratio ( / _acapp _getosmode _grX _OLE->ACI _OLE->RGB _RGB->ACI _snap _polarangs _polar _ortho P1 P PS oo pp ss vector,Len vector,Len,get vector,Len,set vector,cross opt arsin arcos opt2 Rect0 Rect1 Rect2 Rect3 tmpRatio typed UserPrompt )

    (vl-load-com)

    (defun _acapp nil
        (eval (list 'defun '_acapp 'nil (vlax-get-acad-object)))
        (_acapp)
    )

    (defun _getosmode ( os / lst )
        (foreach mode
           '(
                (0001 . "_end")
                (0002 . "_mid")
                (0004 . "_cen")
                (0008 . "_nod")
                (0016 . "_qua")
                (0032 . "_int")
                (0064 . "_ins")
                (0128 . "_per")
                (0256 . "_tan")
                (0512 . "_nea")
                (1024 . "_qui")
                (2048 . "_app")
                (4096 . "_ext")
                (8192 . "_par")
            )
            (if (not (zerop (logand (car mode) os)))
                (setq lst (cons "," (cons (cdr mode) lst)))
            )
        )
        (apply 'strcat (cdr lst))
    )

    (defun _grX ( p s c / -s r j )
        (setq -s (- s)
               r (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
               j p
        )
        (grdraw (mapcar '+ j (list (* r -s) (* r -s))) (mapcar '+ j (list (* r s) (* r s))) c)
        (grdraw (mapcar '+ j (list (* r -s) (* r (1+ -s)))) (mapcar '+ j (list (* r (1- s)) (* r s))) c)
        (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r -s))) (mapcar '+ j (list (* r s) (* r (1- s)))) c)
       
        (grdraw (mapcar '+ j (list (* r -s) (* r s))) (mapcar '+ j (list (* r s) (* r -s))) c)
        (grdraw (mapcar '+ j (list (* r -s) (* r (1- s)))) (mapcar '+ j (list (* r (1- s)) (* r -s))) c)
        (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r s))) (mapcar '+ j (list (* r s) (* r (1+ -s)))) c)

        p
    )

    (defun _OLE->ACI ( c )
        (apply '_RGB->ACI (_OLE->RGB c))
    )

    (defun _OLE->RGB ( c )
        (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(24 16 8))
    )

    (defun _RGB->ACI ( r g b / c o )
        (if (setq o (vla-getinterfaceobject (_acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
            (progn
                (setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
                (vlax-release-object o)
                (if (vl-catch-all-error-p c)
                    (prompt (strcat "\nError: " (vl-catch-all-error-message c)))
                    c
                )
            )
        )
    )

    (defun _snap ( p osm )
      (if (osnap p (_getosmode osm))
        (osnap p (_getosmode osm))
        p
      )
    )

    (defun _polarangs ( ang / n k a l )
      (if (/= ang 0.0)
        (progn
          (setq n (/ 360.1 (cvunit ang "radians" "degrees")))
          (setq k -1.0)
          (repeat (1+ (fix n))
            (setq a (* (setq k (1+ k)) ang))
            (setq l (cons a l))
          )
          l
        )
        (list 0.0)
      )
    )

    (defun _polar ( p0 p flag ang / a b an )
      (if flag
        (progn
          (setq a (car (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
          (setq b (last (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
          (if (< (abs (- (angle p0 p) a)) (abs (- (angle p0 p) b))) (setq an a) (setq an b))
          (inters p0 (polar p0 an 1.0) p (polar p (+ an (* 0.5 pi)) 1.0) nil)
        )
        p
      )
    )

    (defun _ortho ( p0 p flag )
      (if flag
        (_polar p0 p t (* 0.5 pi))
        p
      )
    )

    (setq   P1              (getpoint "\nPick StartPoint : ")
            vector,Len,get  (lambda (v / ) (sqrt (apply '+ (mapcar '(lambda (a / ) (expt a 2)) v))))
            vector,Len,set  (lambda (v l / f) (setq f (/ (float l) (vector,Len,get v))) (mapcar '(lambda (a /) (* a f)) v))
            vector,cross    (lambda (a b)
                                (mapcar
                                    '(lambda (n / )
                                        (-
                                            (* (nth (car n) a)(nth (cadr n) b))
                                            (* (nth (cadr n) a) (nth (car n) b))
                                        )
                                    )
                                    '((1 2) (2 0) (0 1))
                                )
                            )
            arsin           (lambda (x)
                                (cond
                                    ((= x 1.0) (/ pi 2.0))
                                    ((= x -1.0) (/ pi -2.0))
                                    ((< (abs x) 1.0) (atan (/ x (sqrt (- 1.0 (* x x))))))
                                    ('default (*error* (strcat "\n error: bad argument: " (rtos (abs x) 2) ">1.0\n ")))
                                )
                            )
            opt             0
            opt2            0
            ratio           2
    )
    (setq UserPrompt (lambda (/) (princ "\nPick Second Point or toogle between modes with RIGHTMOUSE and TAB or enter a new ratio (1:x) = 1:")))
   
    (setvar 'orthomode 1)
    (setq ape (getvar 'aperture))
    (setvar 'aperture 40)
    (setq as (getvar 'autosnap))
    (setvar 'autosnap 31)
    (setq osm (getvar 'osmode))
    (setvar 'osmode 15359)
    (if (eq (getvar 'orthomode) 1) (setq oo t) (setq oo nil))
    (if (eq (logand (getvar 'autosnap) 8) 8) (setq pp t) (setq pp nil))
    (if (eq (logand (getvar 'autosnap) 16) 16) (setq ss t) (setq ss nil))
   
    (eval
        (list 'defun '*error* '(msg / )
            (list
                (lambda (err / )
                    (setq *error* err)
                    (if ape (setvar 'aperture ape))
                    (if as (setvar 'autosnap as))
                    (if osm (setvar 'osmode osm))
                    (redraw)
                    (if msg
                        (progn
                            (if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*"))
                                (princ msg)
                            )
                            (*error* msg)
                        )
                    )
                    (princ)
                )
                *error*
            )
        )
    )
   
    (UserPrompt)
   
    (while (not (= (car (setq P (grread 'T))) 3))
        (cond
            ((= (car P) 5)
                (   (lambda (P / v l v,perp H ang)
                        (cond
                            ( (and oo pp ss)
                              (setq PS (_snap (_ortho P1 P t) (getvar 'osmode)))
                            )
                            ( (and oo (not pp) ss)
                              (setq PS (_snap (_ortho P1 P t) (getvar 'osmode)))
                            )
                            ( (and (not oo) pp ss)
                              (setq PS (_snap (_polar P1 P t (getvar 'polarang)) (getvar 'osmode)))
                            )
                            ( (and (not oo) (not pp) ss)
                              (setq PS (_snap P (getvar 'osmode)))
                            )
                            ( (and oo pp (not ss))
                              (setq PS (_ortho P1 P t))
                            )
                            ( (and oo (not pp) (not ss))
                              (setq PS (_ortho P1 P t))
                            )
                            ( (and (not oo) pp (not ss))
                              (setq PS (_polar P1 P t (getvar 'polarang)))
                            )
                            ( (and (not oo) (not pp) (not ss))
                              (setq PS P)
                            )
                        )
                        (setq   v (mapcar '- PS P1)
                                l (vector,Len,get v)
                        )
                        (if (> l 0)
                            (cond
                                ((= opt 0)
                                    (setq v,perp
                                        (vector,Len,set
                                            (vector,cross v '(0 0 1))
                                            (if (= opt2 0)
                                                (/ l (float ratio))
                                                (* l ratio)
                                            )
                                        )
                                    )
                                   
                                    (setq   Rect0 P1
                                            Rect1 (mapcar '+ P1 v,perp)
                                            Rect2 (mapcar '+ Rect1 v)
                                            Rect3 PS
                                    )
                                    (redraw)
                                    (grvecs (list -7 Rect0 Rect1 Rect1 Rect2 Rect2 Rect3 Rect3 Rect0))
                                )
                                ((= opt 1)
                                    (setq v,perp
                                        (vector,Len,set
                                            (vector,cross v '(0 0 -1))
                                            (if (= opt2 0)
                                                (/ l (float ratio))
                                                (* l ratio)
                                            )
                                        )
                                    )
                                   
                                    (setq   Rect0 P1
                                            Rect1 (mapcar '+ P1 v,perp)
                                            Rect2 (mapcar '+ Rect1 v)
                                            Rect3 PS
                                    )
                                    (redraw)
                                    (grvecs (list -7 Rect0 Rect1 Rect1 Rect2 Rect2 Rect3 Rect3 Rect0))
                                )
                                ((= opt 2)
                                    (setq H (sqrt (+ 1 (expt ratio 2))))
                                    (setq ang (arsin (/ ratio H)))
                                    (setq l    (* (cos ang) l))
                                   
                                    (setq ang
                                        (if (= opt2 0)
                                            (- (angle P1 PS) ang)
                                            (+ (angle P1 PS) ang)
                                        )
                                    )
                                   
                                    (setq   Rect0 P1
                                            Rect1 (polar P1 ang l)
                                            Rect2 PS
                                            Rect3 (polar Rect2 ang (* -1 l))
                                    )
                                   
                                    (redraw)
                                    (grvecs (list -7 Rect0 Rect1 Rect1 Rect2 Rect2 Rect3 Rect3 Rect0))
                                )
                            )
                        )
                    )
                    (cadr P)
                )
            )
            ((= (car P) 25)
                (if (= opt 2)
                    (setq opt 0)
                    (setq opt (1+ opt))
                )
            )
            ((and (= (car P) 2) (or (and (> (cadr P) 47) (< (cadr P) 58)) (= (cadr P) 46)))
                (setq typed (chr (cadr P)))
                (princ typed)
                (setq tmpRatio (cons typed tmpRatio))
            )
            ((and (= (car P) 2) (= (cadr P) 8))
                (princ (chr (cadr P)))
                (setq tmpRatio (cdr tmpRatio))
            )
            ((and (= (car P) 2) (or (= (cadr P) 13) (= (cadr P) 32)))
                (if tmpRatio
                    (setq ratio (read (apply 'strcat (reverse tmpRatio)))
                          tmpRatio nil
                    )
                )
                (UserPrompt)
            )
            ((and (= (car P) 2) (= (cadr P) 9))
                (if (= opt2 1)
                    (setq opt2 0)
                    (setq opt2 1)
                )
            )
            ((and (= (car P) 2) (= (cadr P) 15))
              (if (eq oo t) (setq oo nil) (setq oo t))
            )
            ((and (= (car P) 2) (= (cadr P) 21))
              (if (eq pp t) (setq pp nil) (setq pp t))
            )
            ((and (= (car P) 2) (= (cadr P) 6))
              (if (eq ss t) (setq ss nil) (setq ss t))
            )
        )
        (if (not (equal PS (cadr P) 1e-6))
          (_grX PS (atoi (getenv "AutoSnapSize")) (_OLE->ACI (if (= 1 (getvar 'cvport)) (atoi (getenv "Layout AutoSnap Color")) (atoi (getenv "Model AutoSnap Color")))))
        )
    )
   
    (if (apply 'and '(Rect0 Rect1 Rect2 Rect3))
        (command "_pline" "_non" Rect0 "_non" Rect1 "_non" Rect2 "_non" Rect3 "_close")
    )
   
    (*error* nil)
)

EDIT : Forgot to add (vl-load-com)
Title: Re: Examples of usage GRREAD - let's share
Post by: ribarm on May 31, 2014, 03:50:13 AM
I've noticed my wrong input for 'osmode - now changed to :

(setvar 'osmode 15359)

Code updated also here on cadtutor...
http://www.cadtutor.net/forum/showthread.php?86255-Choose-midpoint-and-endpoint-draw-line.&p=#4

Also changed :
(setvar 'aperture 40)

M.R.
Title: Re: Examples of usage GRREAD - let's share
Post by: reltro on May 31, 2014, 05:53:01 AM
Reltro,

Very neat menu concept! Have you considered using entmake to create text on the fly rather than vectoring it? One small suggestion, make the text that names the current command a different color than white so that it stands out a little more.

Hey...
I improved the Menu a lil bit and added also a version with Mtext to display the title...
http://www.theswamp.org/index.php?topic=47177.msg522100#msg522100

the Text in the circle-parts are still vectors... they are precalculated, so it would be harder to modify...
I prefer the version where all the stuff are vectors...

greets
reltro
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on May 31, 2014, 10:41:23 AM
I've implemented Lee's SNAPS to your function... Hope you don't mind...

Why do you insist on removing my name & author prefix from every line of code that you steal from me...?
Title: Re: Examples of usage GRREAD - let's share
Post by: ribarm on May 31, 2014, 12:09:50 PM
Why do you insist on removing my name & author prefix from every line of code that you steal from me...?

I haven't stolen anything (where do you see MR: as prefix of functions I borrowed from you)... Simple reason of removing prefixes is to avoid confusion, to shorten code and to make it more readable... For purpose of stating the source of codes I provided link from where it was borrowed... Beside this I make my own functions which I consider are useful in describing method more complete and combine them to make program functionality better... Only subfunctions are the pieces I borrow from time to time, and you are not the only person I refer to; the main body of program I shared is unique and so is the main function name - I am just trying to make progression in terms of CAD - that's my hobby - to make life easier to myself and to the others who are using achievements that are shared and from time to time I make some mistakes I hope I correct meanwhile on the time I get... I am very responsible person and I don't like to leave some started things unfinished, just making sure I leave correct footprints for those people that like to participate and make progress of community greater like myself...
Title: Re: Examples of usage GRREAD - let's share
Post by: John Kaul (Se7en) on May 31, 2014, 12:14:10 PM
I've implemented Lee's SNAPS to your function... Hope you don't mind...
Why do you insist on removing my name & author prefix from every line of code that you steal from me...?

Whilst ignoring the elephant--you put the code online--in the room; maybe add your header below the defun line.
Code - Auto/Visual Lisp: [Select]
  1. (defun foo ( / )
  2. ;; Copyright © 2014 John
  3.  
  4. ;; Awesome-sauce code here
  5.  
  6. )
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on May 31, 2014, 12:26:20 PM
Why do you insist on removing my name & author prefix from every line of code that you steal from me...?

Simple reason of removing prefixes is to avoid confusion, to shorten code and to make it more readable...

That is feeble excuse in my opinion -
Removing the author prefix shortens the code by what, 2 characters?
And if anything, the headers add clarity to the code, as they describe the purpose of each function.

I don't wish to derail this thread, but in short, if you are going to copy/paste entire chunks of my code, at least have the courtesy to retain the few headers which accompany it, and not go to every effort to remove all attribution from the code.
Title: Re: Examples of usage GRREAD - let's share
Post by: John Kaul (Se7en) on May 31, 2014, 12:59:24 PM
Why do you insist on removing my name & author prefix from every line of code that you steal from me...?

Simple reason of removing prefixes is to avoid confusion, to shorten code and to make it more readable...

That is feeble excuse in my opinion -
Removing the author prefix shortens the code by what, 2 characters?
And if anything, the headers add clarity to the code, as they describe the purpose of each function.

I don't wish to derail this thread, but in short, if you are going to copy/paste entire chunks of my code, at least have the courtesy to retain the few headers which accompany it, and not go to every effort to remove all attribution from the code.

Removing prefixes (changing function names) does/can make the code more readable.

Removing headers does NOT make the code more readable; I, personally, only tried to add to existing headers and/or convert them to "my style" if needed. I also found adding a link to the thread or website where the code was found was helpful as well.

Lee,
Please try harder to be nicer to other members of theSwamp (stop being nasty). And, please try to not cast stones.
Title: Re: Examples of usage GRREAD - let's share
Post by: Lee Mac on May 31, 2014, 01:08:24 PM
What has happened to this place... see ya.
Title: Re: Examples of usage GRREAD - let's share
Post by: John Kaul (Se7en) on May 31, 2014, 01:13:28 PM
Nothing has happened to this place (don't blame others); you choose to accuse instead of PMing or being more diplomatic. I asked you to stop (nothing complicated).
Title: Re: Examples of usage GRREAD - let's share
Post by: MP on May 31, 2014, 02:57:24 PM
John, Lee has every right to be incensed that all his efforts to attribute his code were entirely stripped. The fact that Lee chooses to identify his code differently than you or I is irrelevant.
Title: Re: Examples of usage GRREAD - let's share
Post by: John Kaul (Se7en) on May 31, 2014, 04:17:01 PM
I agree but do you accuse someone of "stealing" when it happens. …We all need a break time to time.

The part about adding a header in a different location was my way of hinting at but not actually saying: it happens. move on. Besides all this stuff we post resides on someones personal hard drive -i.e. not OURS.

Ive recently learned there are far too many other things to focus on other then how someone used something someone posted on the internet. If you don't want it used, abused, taken, stolen, learned from, taken apart, etc. don't post it. People are going to use it many different ways, you can't dictate how people are going use the knowledge you part with.
Title: Re: Examples of usage GRREAD - let's share
Post by: MP on May 31, 2014, 04:45:00 PM
Sorty, I'm with Lee on this one. I find it odd you'd rather turn a blind eye to plagerism in the interests of "not making waves". Didn't realize honor had become unfashionable.
Title: Re: Examples of usage GRREAD - let's share
Post by: John Kaul (Se7en) on May 31, 2014, 05:00:22 PM
Im not turing a blind eye nor do I condone it but I also didn't think Lee was going to get very far going at it the way he did. Take our current conversation for example, have either of us insulted or accused one another; no. We are having a discussion. …Lee's approach immediately put the other on the defense. At that moment the conversation was over and no common ground was going to be reached (neither stick was going to bend. only snap).

If we want to wave our sticks around and see who's is larger to settle disputes we can do that but you better not choose to use that method when it's something you actually want to resolve.
Title: Re: Examples of usage GRREAD - let's share
Post by: MP on May 31, 2014, 09:40:09 PM
Im not turning a blind eye nor do I condone ...

Well fact remains all you've done is admonish Lee for expressing his outrage (which he is fully entitled) that someone deliberately removed all attribution from source code -- you might as well pat him ribarm on the back for a job well done.

ribarm: This practice of yours will only result an a complete loss of respect by your peers, as does dismissing or playing down the issue.
Title: Re: Examples of usage GRREAD - let's share
Post by: John Kaul (Se7en) on May 31, 2014, 10:30:30 PM
Ok. point(s) taken MP. …the only point you made I want to address is for Lee's benefit though. I was far from admonishing him; I only asked him to keep his cool. Shift to a more respectful tack. Flies with honey. Open the lines of communication (I even started by giving personal opinions/habits). This kind of stuff happens all the time so keep calm and deal with it. etc. etc.
Title: Re: Examples of usage GRREAD - let's share
Post by: MP on June 01, 2014, 01:12:11 AM
This passive crap is baffling and symptomatic of a pc world gone wrong. Kudos to Lee for calling fowl and not dancing around the issue.
Title: Re: Examples of usage GRREAD - let's share
Post by: WILL HATCH on June 01, 2014, 01:18:23 AM
Got to add my $0.02 (rounds down in Canada now tho so it's worthless)

I'm with Lee 100% here.  This community has immense power because of the people who freely contribute and they have earned the right to be recognized for it.
Title: Re: Examples of usage GRREAD - let's share
Post by: fixo on June 01, 2014, 01:44:10 AM
Why do you insist on removing my name & author prefix from every line of code that you steal from me...?

Simple reason of removing prefixes is to avoid confusion, to shorten code and to make it more readable...


That is feeble excuse in my opinion -
Removing the author prefix shortens the code by what, 2 characters?
And if anything, the headers add clarity to the code, as they describe the purpose of each function.

I don't wish to derail this thread, but in short, if you are going to copy/paste entire chunks of my code, at least have the courtesy to retain the few headers which accompany it, and not go to every effort to remove all attribution from the code.
I'm with you, bud :)
Title: Re: Examples of usage GRREAD - let's share
Post by: John Kaul (Se7en) on June 01, 2014, 07:47:30 AM
Ah, well, I apologize for trying to keep the conversation civil then. Feel free to insult, abuse, attack, insult as you see fit.

…where were you guys during my "moderator cleanup effort", "subject lines are good", and "or is evil campaign"?
Title: Re: Examples of usage GRREAD - let's share
Post by: danallen on June 01, 2014, 08:57:37 AM
I'm in agreement that stripping headers and posting someone else's routines in your code in multiple forums is pretty much stealing / taking credit (and extremely ungrateful) for someone else's work. When I grab code from forums and the author didn't bother to put in headers, I still make the effort to provide credit by referencing their username and url/thread the post was in.

Dan
Title: Re: Examples of usage GRREAD - let's share
Post by: mjfarrell on June 01, 2014, 09:51:12 AM
As a person who doesn't do any coding, I still understand the that the written
or unwritten "Honour Code" of coding has always been to give credit to the
ORIGINATOR of the code.

True there could be a tactful way to to bring this up; however is the person
that is engaged in this activity being tactful?  Do they deserve the courtesy
that they themselves fail to extend?
Title: Re: Examples of usage GRREAD - let's share
Post by: ribarm on June 01, 2014, 10:02:09 AM
I've pointed the credits to Lee's codes that were used, but I suppose that for the codes I and reltro posted the credits should be ours... I just used Lee's subfunctions like I said to make main functions more useful... If you continue to insult me and others that attempt to make this forum better than you shouldn't be using www at all... The main point of www is to make all the people support each other and not the opposite... I've changed my postings of codes to the point I thought will don't discredit anyone in any way... I thought Lee would be happy to see that his subfunctions are used in many situations and now I find that this was just opposite... I sincerely think I shouldn't post anything I did, specially for the people like those that are selfish and not willing to show their gratitude to us that are posting and sharing codes for free... I won't stand back like I did before as I see now that I was wrong. I don't know why Lee Mac is sharing his knowledge if he isn't willing to accept the fact that it would be used for learning and using it in practical and theoretical ways... I am really greatly disappointed in Lee's way of providing help and in many others that are supporting this kind of attitude... I don't care if someone would use my codes in any way as I never make programs that are harmful in any way, further more I would be glad to see it it was used as I am sure the purpose would be totally beneficial and correct...
Title: Re: Examples of usage GRREAD - let's share
Post by: MP on June 01, 2014, 10:03:51 AM
Jeez, don't go hyperbolic John, no one's advocating that kind of dialog as normal exchange. Lee's response was appropriate in this context.

How about being as adamant that participants should do their very best to attribute code?
Title: Re: Examples of usage GRREAD - let's share
Post by: MP on June 01, 2014, 10:13:40 AM
M.R. - this is no problem with the way Lee shares his knowledge but the manner in which it was used -- which has been discussed ad nauseum.
Title: Re: Examples of usage GRREAD - let's share
Post by: danallen on June 01, 2014, 10:21:16 AM
Marko,

It is as simple as leaving in reference/remarks to original author of code, not just in your message. You don't need to leave all the original author's comments in (unless they state code should remain unmodified), but you should leave at least one line reference to either swamp message url or Lee's website.

Dan
Title: Re: Examples of usage GRREAD - let's share
Post by: RAIN CODE on June 05, 2014, 05:16:38 AM

I support Lee on this.

He may have lost his cool and over reacted.

When you copy or borrow someone code
with the author initial in the subr name, it
is best to leave it alone

when I copied CAB code over to my
program he didnt put his initial in the subr
name and I changed the whole subr name
but when I copied Lee Mac code over I
noticed his initial in front and I told myself
I think I better leave that alone untouched.

Lee have contributed alot to this
community and I respect Lee Mac for his effort.










Title: Re: Examples of usage GRREAD - let's share
Post by: rkmcswain on June 26, 2014, 12:27:36 PM
I'm with Lee 100% here.  This community has immense power because of the people who freely contribute and they have earned the right to be recognized for it.

Ditto that comment ^^^^^^^
Title: Re: Examples of usage GRREAD - let's share
Post by: cmwade77 on June 26, 2014, 01:01:37 PM
Looking through this thread, I personally think Lee was actually very reasonable about this and I definitely feel that Lee is owed an apology for the way he was treated as well, he rightfully called someone out for not providing credit for his code (asking why they always removed his credit form his code when posting) and then was told that he overreacted. This doesn't seem right to me in the least, as far as I am aware, it has been a long standing policy of these boards to make sure that credit is included in any code that you post that uses other's code.

I have looked through some of the other posts that the person that Lee took issue with and it appears that this person expects credit to be given to them for their code, but removes credit to others when they reuse their code. They do give credit in their post and not in the code, but the credit should remain as remarks in the code, so that credit also gets copied over if someone else reuses the posted code.

I definitely don't think Lee overreacted, he puts a lot of time and effort into helping us all. I know my routines would be no where near what they are without him and I hope for the benefit of all of us those that didn't give the proper credit and those that treated Lee so harshly for asking for the credit will reach out to Lee to apologize for their poor behavior.
Title: Re: Examples of usage GRREAD - let's share
Post by: cmwade77 on June 26, 2014, 01:16:52 PM
Ah, well, I apologize for trying to keep the conversation civil then. Feel free to insult, abuse, attack, insult as you see fit.

…where were you guys during my "moderator cleanup effort", "subject lines are good", and "or is evil campaign"?
Lee did not insult or abuse, he simply asked why the person always removes his credit from his posts.

Based on the person's other posts, this does seem to be a valid question, as this person did appear to always remove the credit and given the amount that is missing the credit in their codes I think Lee was very tactful about it.

I still maintain there was nothing wrong with what Lee did. It also has brought this to our attention, so that we can be more careful about checking that person's code so that we can make sure that if we use it, we will give the appropriate credit.
Title: Re: Examples of usage GRREAD - let's share
Post by: CAB on June 27, 2014, 08:35:32 AM
My comments here: http://www.theswamp.org/index.php?topic=41837.msg523515#msg523515
Title: Re: Examples of usage GRREAD - let's share
Post by: Jeremy on June 29, 2014, 07:41:30 PM
In the interest of getting us back to GRREAD .......

Code: [Select]
(vl-load-com)

;; I usually set these globally before any drawing session begins but I explicitly set them
;; here to make the code work for you.
(setq *ax-acad-object*     (vlax-get-acad-object)
      *ax-active-document* (vla-get-ActiveDocument *ax-acad-object*)
)

;; test function
(defun c:activetext ( / gr cp obj oldh ip h hr)

   ;...initially create our mtext before actively moving it
   (setq hr   60)
   (setq cp   (getvar 'VIEWCTR))
   (setq oldh (getvar 'VIEWSIZE))
   (setq obj  (axdraw-mtext (pt-to-callout cp) cp 8))
   (vla-put-AttachmentPoint obj acAttachmentPointMiddleCenter)
   (vla-put-Height obj (/ oldh hr))
   (put-transparency nil 15)
   ;....move the text around
   (while (= 5 (car (setq gr (grread T 1 0))))
     (setq p  (cadr gr) ;this is the current cursor position
           ip (vla-get-InsertionPoint obj)
     )
     (vla-put-TextString obj (pt-to-callout p))
     ;...if we have zoomed in or out then readjust the text height to remain constant
     (if (/= oldh (setq h (getvar 'VIEWSIZE)))
       (progn
         (vla-ScaleEntity obj ip (/ h oldh))
         (setq oldh h)
       )
     )
     ;...if the cursor has moved then move the mtext to comply
     (if (not (equal ip p))(vla-move obj ip (vlax-3D-point p)))
   )

   (vla-Delete obj) ;now delete the text because we picked a point on the screen
   (princ)
)

;; Change the transparency of an entity
(defun put-transparency ( nam n / echo )
  (setq echo (getvar 'CMDECHO))
  (if (null nam)(setq nam (entlast)))
  (setvar 'CMDECHO 0)
  (vl-cmdf "._CHPROP" nam "TR" n "" "")
  (setvar 'CMDECHO echo)
)

;; Return the object for the space that the user is currently in.
(defun ActiveSpace nil
    (vlax-get-property (eval *ax-active-document*)
                       (if (= (getvar 'CVPORT) 1) 'PaperSpace 'ModelSpace)))


;; Place a piece of mtext into the drawing
(defun axdraw-mtext ( str ip wid )
  (vla-AddMtext (ActiveSpace) (vlax-3D-point (trans ip 1 0)) wid str)
)


;; Given a point format a text input for the coordinates of the point
(defun pt-to-callout ( p / x y xstr yxtr )
  (setq x    (car  p)
        y    (cadr p)
        xstr (strcat "X: " (rtos x 2 6))
        ystr (strcat "Y: " (rtos y 2 6))
  )
  (strcat xstr "\\P" ystr)
)

Lee Mac wrote a little example where he had text made out of grdraw vectors display the X and Y values as the user moved their cursor around. I have done the same task but I create an MTEXT entity using active-X methods and use the Move and ScaleEntity properties to change it on the fly. I mostly did this to see if there would be any appreciable slowdowns or not as I have not done something like this before. I also wanted to see if I could get the better display choices inherent in Mtext. I was quite happy to see that it works quite well. I used the CHPROP command to alter the transparency of the text. I wanted to use active-X but could not find any transparency property for drawing entities. Does anyone know how to do this in active-X?

My next target is to make a simple dialog box that is nothing more than a block composed of control blocks within it. Doing dialogs this way can free us from the DCL file altogether and give us more formatting options, but one thing at a time. :-D
Title: Re: Examples of usage GRREAD - let's share (pointer with osnap)
Post by: hanhphuc on August 15, 2014, 09:29:22 PM
;hp#13 <<grread revisited>>

(hp:pointer pt color en )

similar (getpoint ) for the 2nd point, just add grread visual effect (osnap can be changed default is "_nea")
;returns the list xyz of last point (depend on osnap mode)
Code: [Select]
;v1.1: add object
(defun hp:pointer (_pt c obj / p tp l ip vs) ; v1.1
 (if obj (setq obj(vlax-ename->vla-object obj)))
  (while (and (= (setq p (car (setq tp (grread t 15 0)))) 5) (setq l (cadr tp)))
    (redraw)
       (grvecs
(apply
'append
(mapcar
  ''((x)
     (list
      6
      _pt
      (polar _pt (* pi x)(* 50. (setq vs (/ (getvar "viewsize") (cadr (getvar "screensize"))))))
      )
     )
  '(0.0 0.5 1.0 1.5)
  ) ;_ end of mapcar
) ;_ end of apply
) ;_ end of grvecs


  (setq ip  (osnap l "_nea")
ip  (if ip
      ip
      l
      ) ;_ end of if

a   (angle _pt ip)
sz  (* 50. vs)
ang (/ pi 6.37)
d   (* sz 0.25)
ep  (polar ip (+ a pi) 0. );(* sz 0.5)
) ;_ end of setq
   (grvecs
     (apply 'append
    (mapcar ''((x) (list c ep x))
    (list (polar ip a sz ) (polar ep (+ a ang) d) (polar ep (- a ang) d))
    ) ;_ end of mapcar
    ) ;_ end of apply
     ) ;_ end of grvecs
   
  (if obj
  (vlax-put obj "InsertionPoint" (polar _pt (angle _pt ip) (+(distance _pt ip) 0.2 sz))))

    ) ;_ end of while
 
;;;  (redraw)

  ip
  ) ;_ end of defun

http://www.theswamp.org/index.php?topic=12813.225
;example call:
(hp:pointer (getvar "viewctr") 2 nil) ;<-- nil no entity
Code: [Select]
(defun c:test (/ tx)
(setq tx  (car (entsel)))
(hp:pointer (getpoint) 2 tx))
Title: Re: Examples of usage GRREAD - let's share
Post by: ribarm on August 19, 2014, 02:53:23 AM
I've just wrote "myline" implementation of SNAPS for grread - I've found some functions in Lee's DynOff lisp and I've added my subs for polar, ortho and Lee's and Evgeniy's osnap... So this should now imitate almost exactly how "LINE" command works... Hope you'll like it and find it useful if you plan seriously implementation of SNAPS...

Code: [Select]
(defun c:myline ( / *error* osm omo aus ape doc drft osGrv o p s
                    osMark _getosmode get_osmode osmode-grvecs-lst _snap _polarangs _polar _ortho
                    pt gr gp oPt gps )

  (vl-load-com)

  (defun *error* (msg)
    (if osm (setvar 'osmode osm))
    (if omo (setvar 'orthomode omo))
    (if aus (setvar 'autosnap aus))
    (if ape (setvar 'aperture ape))
    (if msg (prompt msg))
    (redraw)
    (princ)
  )
 
  (setq osm (getvar 'osmode))
  (setq omo (getvar 'orthomode))
  (setq aus (getvar 'autosnap))
  (if (eq omo 1) (setq o t) (setq o nil))
  (if (eq (logand aus 8) 8) (setq p t) (setq p nil))
  (if (< 0 osm 16384) (setq s t) (setq s nil))
  (setq ape (getvar 'aperture))
  (setvar 'aperture 10)

  (defun _getosmode (os / lst)
      (foreach mode
         '(
              (0001 . "_end")
              (0002 . "_mid")
              (0004 . "_cen")
              (0008 . "_nod")
              (0016 . "_qua")
              (0032 . "_int")
              (0064 . "_ins")
              (0128 . "_per")
              (0256 . "_tan")
              (0512 . "_nea")
              (1024 . "_qui")
              (2048 . "_app")
              (4096 . "_ext")
              (8192 . "_par")
          )
          (if (not (zerop (logand (car mode) os)))
              (setq lst (cons "," (cons (cdr mode) lst)))
          )
      )
      (apply 'strcat (cdr lst))
  )

  (defun osMark (o / s)
    (setq s (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE")))
          o (cons (trans (car o) 1 3) (cdr o)))

    (grvecs (cdr (assoc (cadr o) osGrv))
            (list (list s 0. 0. (caar o))
                  (list 0. s 0. (cadar o))
                  (list 0. 0. s 0.)
                  (list 0. 0. 0. 1.))))

  (defun get_osmode nil ; by Evgeniy Elpanov
    (mapcar
      (function cdr)
        (vl-remove-if
          (function (lambda (x) (zerop (logand (getvar "OSMODE") (car x)))))
          '((0    . "_non")
            (1    . "_end")
            (2    . "_mid")
            (4    . "_cen")
            (8    . "_nod")
            (16   . "_qua")
            (32   . "_int")
            (64   . "_ins")
            (128  . "_per")
            (256  . "_tan")
            (512  . "_nea")
            (2048 . "_app")))))

  (defun osmode-grvecs-lst (col ass / -ass)
     ; By Evgeniy Elpanov (Modified by Lee Mac)
   
    (setq -ass (- ass))
   
    (list (list "_non"
                col (list 0.0 -ass) (list 0.0  ass)
                col (list -ass 0.0) (list ass 0.0))

          (list "_end"
                col (list -ass -ass) (list -ass  ass)
                col (list (1-  -ass) (1- -ass)) (list (1- -ass) (1+  ass))             
                col (list -ass  ass) (list  ass  ass)
                col (list (1-  -ass) (1+  ass)) (list (1+  ass) (1+  ass))             
                col (list  ass  ass) (list  ass -ass)
                col (list (1+   ass) (1+  ass)) (list (1+  ass) (1- -ass))             
                col (list  ass -ass) (list -ass -ass)
                col (list (1+   ass) (1- -ass)) (list (1- -ass) (1- -ass)))
         
          (list "_mid"
                col (list -ass -ass) (list    0. ass)
                col (list (1-  -ass) (1- -ass)) (list 0. (1+  ass))
                col (list    0. ass) (list  ass -ass)
                col (list 0. (1+  ass)) (list (1+  ass) (1- -ass))
                col (list  ass -ass) (list -ass -ass)
                col (list (1+   ass) (1- -ass)) (list (1- -ass) (1- -ass)))
         
          (list "_cen"
                7   (list (* -ass 0.2) 0.)  (list (*  ass 0.2) 0.)
                7   (list  0. (* -ass 0.2)) (list  0.  (*  ass 0.2))
                col (list    -ass   0.)     (list (* -ass 0.86) (* ass  0.5))
                col (list (* -ass 0.86) (* ass  0.5))  (list (* -ass  0.5) (* ass 0.86))
                col (list (* -ass  0.5) (* ass 0.86))  (list 0. ass)
                col (list 0. ass) (list (* ass 0.5)    (* ass 0.86))
                col (list (* ass 0.5)   (* ass 0.86))  (list (* ass 0.86) (* ass 0.5))
                col (list (* ass 0.86)  (* ass 0.5))   (list ass 0.)
                col (list ass 0.) (list (* ass 0.86)   (* -ass 0.5))
                col (list (* ass 0.86)  (* -ass 0.5))  (list (* ass 0.5) (* -ass 0.86))
                col (list (* ass 0.5)   (* -ass 0.86)) (list 0. -ass)
                col (list 0. -ass)(list (* -ass 0.5)   (* -ass 0.86))
                col (list (* -ass 0.5)  (* -ass 0.86)) (list (* -ass 0.86) (* -ass 0.5))
                col (list (* -ass 0.86) (* -ass 0.5))  (list -ass 0.))

          (list "_nod"
                col (list -ass -ass)    (list ass ass)
                col (list -ass ass)     (list ass -ass)
                col (list -ass 0.)      (list (* -ass 0.86) (* ass 0.5))
                col (list (* -ass 0.86) (* ass 0.5))   (list (* -ass 0.5) (* ass 0.86))
                col (list (* -ass 0.5)  (* ass 0.86))  (list 0. ass)
                col (list 0. ass) (list (* ass 0.5)    (* ass 0.86))
                col (list (* ass 0.5)   (* ass 0.86))  (list (* ass 0.86) (* ass 0.5))
                col (list (* ass 0.86)  (* ass 0.5))   (list ass 0.)
                col (list ass 0.) (list (* ass 0.86)   (* -ass 0.5))
                col (list (* ass 0.86)  (* -ass 0.5))  (list (* ass 0.5) (* -ass 0.86))
                col (list (* ass 0.5)   (* -ass 0.86)) (list 0. -ass)
                col (list 0. -ass)(list (* -ass 0.5)   (* -ass 0.86))
                col (list (* -ass 0.5)  (* -ass 0.86)) (list (* -ass 0.86) (* -ass 0.5))
                col (list (* -ass 0.86) (* -ass 0.5))  (list -ass 0.))

          (list "_qua"
                col (list 0. -ass)   (list -ass 0.)
                col (list 0. (1- -ass))   (list (1- -ass) 0.)
                col (list -ass 0.)   (list 0. ass)
                col (list (1- -ass) 0.)   (list 0. (1+ ass))
                col (list 0. ass)    (list ass 0.)
                col (list 0. (1+ ass))    (list (1+ ass) 0.)
                col (list ass 0.)    (list 0. -ass)
                col (list (1+ ass) 0.)    (list 0. (1- -ass)))

          (list "_int"
                col (list -ass -ass) (list ass ass)
                col (list -ass (1+ -ass)) (list ass (1+ ass))
                col (list (1+ -ass) -ass) (list (1+ ass) ass)
                col (list -ass ass)  (list ass -ass)
                col (list -ass (1+ ass))  (list ass (1+ -ass))
                col (list (1+ -ass) ass)  (list (1+ ass) -ass))

          (list "_ins"
                col (list (* -ass 0.1) (* -ass 0.1)) (list -ass (* -ass 0.1))
                col (list -ass (* -ass 0.1)) (list -ass ass)
                col (list -ass ass) (list (* ass 0.1) ass)
                col (list (* ass 0.1) ass)   (list (* ass 0.1) (* ass 0.1))
                col (list (* ass 0.1) (* ass 0.1))   (list ass (* ass 0.1))
                col (list ass (* ass 0.1))   (list ass -ass)
                col (list ass -ass) (list (* -ass 0.1) -ass)
                col (list (* -ass 0.1) -ass) (list (* -ass 0.1) (* -ass 0.1))
                col (list (1- (* -ass 0.1)) (1- (* -ass 0.1))) (list (1- -ass) (1- (* -ass 0.1)))
                col (list (1- -ass) (1- (* -ass 0.1))) (list (1- -ass) (1+ ass))
                col (list (1- -ass) (1+ ass)) (list (1+ (* ass 0.1)) (1+ ass))
                col (list (1+ (* ass 0.1)) (1+ ass)) (list (1+ (* ass 0.1)) (1+ (* ass 0.1)))
                col (list (1+ (* ass 0.1)) (1+ (* ass 0.1))) (list (1+ ass) (1+ (* ass 0.1)))
                col (list (1+ ass) (1+ (* ass 0.1)))   (list (1+ ass) (1- -ass))
                col (list (1+ ass) (1- -ass)) (list (1- (* -ass 0.1)) (1- -ass))
                col (list (1- (* -ass 0.1))   (1- -ass)) (list (1- (* -ass 0.1)) (1- (* -ass 0.1))))

          (list "_tan"
                col (list -ass ass) (list ass ass)
                col (list (1- -ass) (1+ ass)) (list (1+ ass) (1+ ass))
                col (list -ass 0.)  (list (* -ass 0.86) (* ass 0.5))
                col (list (* -ass 0.86) (* ass 0.5)) (list (* -ass 0.5) (* ass 0.86))
                col (list (* -ass 0.5) (* ass 0.86)) (list 0. ass)
                col (list 0. ass) (list  (* ass 0.5) (* ass 0.86))
                col (list (* ass 0.5)  (* ass 0.86)) (list (* ass 0.86) (* ass 0.5))
                col (list (* ass 0.86)  (* ass 0.5)) (list ass 0.)
                col (list ass 0.) (list (* ass 0.86) (* -ass 0.5))
                col (list (* ass 0.86) (* -ass 0.5)) (list (* ass 0.5) (* -ass 0.86))
                col (list (* ass 0.5) (* -ass 0.86)) (list 0. -ass)
                col (list 0. -ass)(list (* -ass 0.5) (* -ass 0.86))
                col (list (* -ass 0.5)(* -ass 0.86)) (list (* -ass 0.86) (* -ass 0.5))
                col (list (* -ass 0.86)(* -ass 0.5)) (list -ass 0.))

          (list "_per"
                col (list -ass -ass) (list -ass ass)
                col (list (1- -ass)  (1- -ass)) (list (1- -ass) (1+ ass))
                col (list ass -ass)  (list -ass -ass)
                col (list (1+ ass)   (1- -ass)) (list (1- -ass) (1- -ass))
                col (list -ass 0.)   (list 0. 0.)
                col (list -ass -1.)  (list 0. -1.)
                col (list 0. 0.)     (list 0. -ass)
                col (list -1. 0.)    (list -1. -ass))

          (list "_nea"
                col (list -ass -ass) (list ass ass)
                col (list -ass ass)  (list ass ass)
                col (list (1- -ass)  (1+ ass)) (list (1+ ass) (1+ ass))
                col (list -ass ass)  (list ass -ass)
                col (list ass -ass)  (list -ass -ass)
                col (list (1+ ass) (1- -ass)) (list (1- -ass) (1- -ass)))

          (list "_app"
                col (list -ass -ass) (list ass ass)
                col (list ass -ass)  (list -ass ass)
                col (list -ass -ass) (list -ass ass)
                col (list (1- -ass)  (1- -ass)) (list (1- -ass) (1+ ass))
                col (list -ass ass)  (list ass ass)
                col (list (1- -ass)  (1+ ass))  (list (1+ ass) (1+ ass))
                col (list ass ass)   (list ass -ass)
                col (list (1+ ass)   (1+ ass))  (list (1+ ass) (1- -ass))
                col (list ass -ass)  (list -ass -ass)
                col (list (1+ ass)   (1- -ass)) (list (1- -ass) (1- -ass)))))
             
  (defun _snap (p os)
    (if (osnap p (_getosmode os))
      (osnap p (_getosmode os))
      p
    )
  )

  (defun _polarangs (ang / n k a l)
    (if (/= ang 0.0)
      (progn
        (setq n (/ 360.1 (cvunit ang "radians" "degrees")))
        (setq k -1.0)
        (repeat (1+ (fix n))
          (setq a (* (setq k (1+ k)) ang))
          (setq l (cons a l))
        )
        l
      )
      (list 0.0)
    )
  )

  (defun _polar (p0 p flag ang / a b an)
    (if flag
      (progn
        (setq a (car (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
        (setq b (last (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
        (if (< (abs (- (angle p0 p) a)) (abs (- (angle p0 p) b))) (setq an a) (setq an b))
        (inters p0 (polar p0 an 1.0) p (polar p (+ an (* 0.5 pi)) 1.0) nil)
      )
      p
    )
  )

  (defun _ortho (p0 p flag)
    (if flag
      (_polar p0 p t (* 0.5 pi))
      p
    )
  )

  (setq doc   (vla-get-ActiveDocument
                (vlax-get-acad-object))
       
        drft  (vla-get-drafting
                (vla-get-preferences
                  (vlax-get-acad-object)))
       
        osGrv (osmode-grvecs-lst
                (vla-get-AutoSnapMarkerColor drft)
                  (vla-get-AutoSnapMarkerSize drft)))
 
  ;;;--------- main function ---------;;;

  (setq pt (getpoint "\nPick or specify point : "))
  (while (/= 3 (car (setq gr (grread 't 15 0))))
    (redraw)
    (cond
      ( (and (= (car gr) 5) (listp (setq gp (cadr gr))))
        (if (and (< 0 (getvar "OSMODE") 16384)
                 (setq oPt (vl-remove-if (function null)
                             (mapcar
                               (function
                                 (lambda (x / o)
                                   (if (setq o (osnap gp x))
                                     (list (distance gp o) o x gp)))) (get_osmode)))))

          (setq oPt (cdar (vl-sort oPt (function (lambda (a b) (< (car a) (car b)))))))
          (setq oPt (list (osnap gp "_non") "_non" gp)))

        (and oPt (OsMark oPt))
        (cond
          ( (and o p s)
            (setq gps (_snap (_ortho pt gp t) (getvar 'osmode)))
          )
          ( (and o (not p) s)
            (setq gps (_snap (_ortho pt gp t) (getvar 'osmode)))
          )
          ( (and (not o) p s)
            (setq gps (_snap (_polar pt gp t (getvar 'polarang)) (getvar 'osmode)))
          )
          ( (and (not o) (not p) s)
            (setq gps (_snap gp (getvar 'osmode)))
          )
          ( (and o p (not s))
            (setq gps (_ortho pt gp t))
          )
          ( (and o (not p) (not s))
            (setq gps (_ortho pt gp t))
          )
          ( (and (not o) p (not s))
            (setq gps (_polar pt gp t (getvar 'polarang)))
          )
          ( (and (not o) (not p) (not s))
            (setq gps gp)
          )
        )
        (grdraw pt gps 3 1)
      )
      ( (and (= (car gr) 2) (= (cadr gr) 6))
        (cond
          ( (< 0 osm 16384) (setq osm (+ osm 16384)) (setvar 'osmode osm) )
          ( (>= osm 16384) (setq osm (- osm 16384)) (setvar 'osmode osm) )
        )
        (if (eq s t) (setq s nil) (setq s t))
      )
      ( (and (= (car gr) 2) (= (cadr gr) 15))
        (cond
          ( (= omo 0) (setq omo 1) (setvar 'orthomode 1) )
          ( (= omo 1) (setq omo 0) (setvar 'orthomode 0) )
        )
        (if (eq o t) (setq o nil) (setq o t))
      )
      ( (and (= (car gr) 2) (= (cadr gr) 21))
        (cond
          ( (= aus 0) (setq aus 8) (setvar 'autosnap 8) )
          ( (= aus 8) (setq aus 0) (setvar 'autosnap 0) )
          ( (= aus 16) (setq aus 24) (setvar 'autosnap 24) )
          ( (= aus 24) (setq aus 16) (setvar 'autosnap 16) )
        )
        (if (eq p t) (setq p nil) (setq p t))
      )
      ( (and (= (car gr) 2) (= (cadr gr) 23))
    &n