Author Topic: Examples of usage GRREAD - let's share  (Read 199107 times)

0 Members and 1 Guest are viewing this topic.

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
Re: Examples of usage GRREAD - let's share
« Reply #15 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. :-)
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.

ElpanovEvgeniy

  • Water Moccasin
  • Posts: 1569
  • Moscow (Russia)
Re: Examples of usage GRREAD - let's share
« Reply #16 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  :-(

Tramber

  • Guest
Re: Examples of usage GRREAD - let's share
« Reply #17 on: October 13, 2006, 03:45:56 PM »
Desvidania Eugêne !

Groovy !

What a collection of great codes.

qjchen

  • Bull Frog
  • Posts: 285
  • Best wishes to all
Re: Examples of usage GRREAD - let's share
« Reply #18 on: October 13, 2006, 08:27:02 PM »
Evgeniy, Very nice rountine, Thank you for share it.
http://qjchen.mjtd.com
My blog http://chenqj.blogspot.com (Chinese, can be translate into English)

ElpanovEvgeniy

  • Water Moccasin
  • Posts: 1569
  • Moscow (Russia)
Re: Examples of usage GRREAD - let's share
« Reply #19 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

ElpanovEvgeniy

  • Water Moccasin
  • Posts: 1569
  • Moscow (Russia)
Re: Examples of usage GRREAD - let's share
« Reply #20 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.
« Last Edit: October 14, 2006, 10:03:16 AM by ElpanovEvgeniy »

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
Re: Examples of usage GRREAD - let's share
« Reply #21 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
  )

)   
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.

qjchen

  • Bull Frog
  • Posts: 285
  • Best wishes to all
Re: Examples of usage GRREAD - let's share
« Reply #22 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~
http://qjchen.mjtd.com
My blog http://chenqj.blogspot.com (Chinese, can be translate into English)

JohnK

  • Administrator
  • Seagull
  • Posts: 10605
Re: Examples of usage GRREAD - let's share
« Reply #23 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.
TheSwamp.org (serving the CAD community since 2003)
Member location map - Add yourself

Donate to TheSwamp.org

Didge

  • Bull Frog
  • Posts: 211
Re: Examples of usage GRREAD - let's share
« Reply #24 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)
)
Think Slow......

GDF

  • Water Moccasin
  • Posts: 2081
Re: Examples of usage GRREAD - let's share
« Reply #25 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)
)
Why is there never enough time to do it right, but always enough time to do it over?
BricsCAD 2020x64 Windows 10x64

gile

  • Gator
  • Posts: 2507
  • Marseille, France
Re: Examples of usage GRREAD - let's share
« Reply #26 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)
)
Speaking English as a French Frog

Pepe

  • Newt
  • Posts: 85
Re: Examples of usage GRREAD - let's share
« Reply #27 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...")
« Last Edit: January 09, 2008, 09:13:45 AM by Pepe »

Lee Mac

  • Seagull
  • Posts: 12906
  • London, England
Re: Examples of usage GRREAD - let's share
« Reply #28 on: December 18, 2009, 07:53:30 PM »
As posted 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.




Extension of this idea here
« Last Edit: December 19, 2009, 03:11:39 PM by Lee Mac »

Kerry

  • Mesozoic relic
  • Seagull
  • Posts: 11654
  • class keyThumper<T>:ILazy<T>
Re: Examples of usage GRREAD - let's share
« Reply #29 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
kdub, kdub_nz in other timelines.
Perfection is not optional.
Everything will work just as you expect it to, unless your expectations are incorrect.
Discipline: None at all.