Script to create a temporary cursor

Anonymous · ‎10-31-2014

I am trying to develop a script that will be a generic subroutine to place in my Autolisp programs that will be a temporary cursor symbol designed

to disappear at some point later in the program. I created a script that I inteded would draw a cursor, and then erase it and redraw it when the cursor position moved due to the movement of the user's hand. The script that I tried to create doesn't work right, because instead of erasing the old cursor, it leaves it there, and so you get a trail of lines all over the screen when the user moves his hand. Many other Autolisp programmers have done this type of routine before, but the blogs about how to do it that come up when I use the Google search engine have faulty coding that doesn't compile/interpret in my Autocad. I am posting the source code of what I have currently done here.

Kent1Cooper · ‎10-31-2014

I think a lot of things can be consolidated/simplified, and you need to get rid of an extraneous left parenthesis at the right end of one of the lines, but as to the specific issue of clearing the cursor as you move around, try this adjustment:

....

    (setq pt3 (list pt3x pt3y))
    (setq pt4 (list pt4x pt4y))
    (redraw);;;;; added this
    (grdraw pt1 pt2 1)
    (grdraw pt2 pt3 1)
    (grdraw pt3 pt4 1)
    (grdraw pt4 pt1 1)
    ;((command "_.DELAY" 100)
;;;;; eliminated these   (grdraw pt1 pt2 -1)
;;;;;    (grdraw pt2 pt3 -1)
;;;;;    (grdraw pt3 pt4 -1)
;;;;;    (grdraw pt4 pt1 -1)
)

.....

You would need to build an additional (redraw) into whatever happens when you've picked something or whatever you're after, so the last temporary cursor will also be cleared.

There's also a way to have it actually draw the cursor shape with (entmakex), and erase the one it just drew and draw a new one whenever the cursor moves. That gives you some possibilities that (grdraw) [or (grvecs)] won't, such as Polyline width, or to use a Circle instead of a square. Here are some relevant snippets from another routine of mine, adjusted in a way that may serve your purposes [adjustments untested], including a much more concise way of determing the four corners:

....

(while
    (and (not done) (setq cur (grread T 12 0)))
    (cond
      ((= (car cur) 5); 5 = first number in (grread) return from moving pointing device
        (if square (entdel square)); eliminate previous one, if any
        (setq

          pos (list (caadr cur) (cadadr cur)); X,Y only of cursor position
          cor1 (mapcar '- pos '(5 5)); lower left
          cor2 (mapcar '+ pos '(5 -5)); lower right

cor3 (mapcar '+ pos '(5 5)); upper right

cor4 (mapcar '+ pos '(-5 5)); upper left

        ); setq
        (setq square (entmakex (.... entity data for a Polyline, including those four corners as vertex entries ....)))
      ); 5 condition
      ((= (car cur) 3); 3 = picked a point

(entdel square); eliminate temporary cursor

(setq done T); end (while) loop

(.... do whatever is appropriate with point picked ....)

); 3 condition

;; (.... other conditions are possible, such as keyboard entry ....)
); cond - grread possibilities

); while

....

Kent Cooper, AIA

Lee_Mac · ‎11-02-2014

Here is another way to approach it:

The following function will emulate the AutoLISP getpoint function whilst offering the ability to display a custom vector graphic around the cursor. The function will accept two arguments: a user prompt to be printed to the command-line, and a vector list (in the same format as supplied to the grvecs function) in pixel units describing the cursor to be displayed during the getpoint prompt.

The following code also uses my GrSnap utility to enable Object Snap functionality within the grread loop, and should also perform correctly under all UCS & View settings.

;; Getpoint with Custom Cursor  -  Lee Mac
;; Prompts the user to specify a point whilst displaying a custom cursor
;; msg - [str] User prompt
;; cur - [lst] grvecs vector list in pixel units

(defun LM:getpointwithcustomcursor ( msg cur / *error* gr1 gr2 mat ocs osf osm pt1 rtn scl str tmp )
 
    (defun *error* ( msg )
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\nError: " msg))
        )
        (redraw) (princ)
    )

    (setq mat  (trp (mapcar '(lambda ( x ) (trans x 1 2 t)) '((1.0 0.0) (0.0 1.0) (0.0 0.0))))
          ocs  (trans '(0.0 0.0 1.0) 1 0 t)
          osf  (LM:grsnap:snapfunction)
          osm  (getvar 'osmode)
          str  ""
    )
    (princ msg)
    (while
        (progn
            (setq gr1 (grread t 15 0)
                  gr2 (cadr gr1)
                  gr1 (car  gr1)
            )
            (cond
                (   (or (= 5 gr1) (= 3 gr1))
                    (redraw)
                    (osf gr2 osm)
                    (setq scl (/ (getvar 'viewsize) (cadr (getvar 'screensize))))
                    (grvecs cur
                        (append
                            (mapcar 'append
                                (mxm mat
                                    (list
                                        (list scl 0.0 0.0)
                                        (list 0.0 scl 0.0)
                                       '(0.0 0.0 1.0)
                                    )
                                )
                                (mapcar 'list (trans gr2 1 2))
                            )
                           '((0.0 0.0 0.0 1.0))
                        )
                    )
                    (= 5 gr1)
                )
                (   (= 2 gr1)
                    (cond
                        (   (= 6 gr2)
                            (if (zerop (logand 16384 (setq osm (setvar 'osmode (boole 6 16384 (getvar 'osmode))))))
                                (princ "\n<Osnap on>")
                                (princ "\n<Osnap off>")
                            )
                            (princ msg)
                        )
                        (   (= 8 gr2)
                            (if (< 0 (strlen str))
                                (progn
                                    (princ "\010\040\010")
                                    (setq str (substr str 1 (1- (strlen str))))
                                )
                            )
                            t
                        )
                        (   (< 32 gr2 127)
                            (setq str (strcat str (princ (chr gr2))))
                        )
                        (   (member gr2 '(13 32))
                            (cond
                                (   (= "" str) nil)
                                (   (setq gr2 (LM:grsnap:parsepoint pt1 str))
                                    (setq osm 16384)
                                    nil
                                )
                                (   (setq tmp (LM:grsnap:snapmode str))
                                    (setq osm tmp
                                          str ""
                                    )
                                )
                                (   (setq str "")
                                    (princ (strcat "\n2D / 3D Point Required." msg))
                                )
                            )
                        )
                    )
                )
            )
        )
    )
    (if (listp gr2) (setq rtn (osf gr2 osm)))
    (redraw)
    rtn
)

;; Object Snap for grread: Snap Function  -  Lee Mac
;; Returns: [fun] A function requiring two arguments:
;; p - [lst] UCS Point to be snapped
;; o - [int] Object Snap bit code
;; The returned function returns either the snapped point (displaying an appropriate snap symbol)
;; or the supplied point if the snap failed for the given Object Snap bit code.

(defun LM:grsnap:snapfunction ( )
    (eval
        (list 'lambda '( p o / q )
            (list 'if '(zerop (logand 16384 o))
                (list 'if
                   '(setq q
                        (cdar
                            (vl-sort
                                (vl-remove-if 'null
                                    (mapcar
                                        (function
                                            (lambda ( a / b )
                                                (if (and (= (car a) (logand (car a) o)) (setq b (osnap p (cdr a))))
                                                    (list (distance p b) b (car a))
                                                )
                                            )
                                        )
                                       '(
                                            (0001 . "_end")
                                            (0002 . "_mid")
                                            (0004 . "_cen")
                                            (0008 . "_nod")
                                            (0016 . "_qua")
                                            (0032 . "_int")
                                            (0064 . "_ins")
                                            (0128 . "_per")
                                            (0256 . "_tan")
                                            (0512 . "_nea")
                                            (2048 . "_app")
                                            (8192 . "_par")
                                        )
                                    )
                                )
                               '(lambda ( a b ) (< (car a) (car b)))
                            )
                        )
                    )
                    (list 'LM:grsnap:displaysnap '(car q)
                        (list 'cdr
                            (list 'assoc '(cadr q)
                                (list 'quote
                                    (LM:grsnap:snapsymbols
                                        (atoi (cond ((getenv "AutoSnapSize")) ("5")))
                                    )
                                )
                            )
                        )
                        (LM:OLE->ACI
                            (if (= 1 (getvar 'cvport))
                                (atoi (cond ((getenv "Layout AutoSnap Color")) ("117761")))
                                (atoi (cond ((getenv  "Model AutoSnap Color")) ("104193")))
                            )
                        )
                    )
                )
            )
           '(cond ((car q)) (p))
        )
    )
)

;; Object Snap for grread: Display Snap  -  Lee Mac
;; pnt - [lst] UCS point at which to display the symbol
;; lst - [lst] grvecs vector list
;; col - [int] ACI colour for displayed symbol
;; Returns nil

(defun LM:grsnap:displaysnap ( pnt lst col / scl )
    (setq scl (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
          pnt (trans pnt 1 2)
    )
    (grvecs (cons col lst)
        (list
            (list scl 0.0 0.0 (car  pnt))
            (list 0.0 scl 0.0 (cadr pnt))
            (list 0.0 0.0 scl 0.0)
           '(0.0 0.0 0.0 1.0)
        )
    )
)

;; Object Snap for grread: Snap Symbols  -  Lee Mac
;; p - [int] Size of snap symbol in pixels
;; Returns: [lst] List of vector lists describing each Object Snap symbol

(defun LM:grsnap:snapsymbols ( p / -p -q -r a c i l q r )
    (setq -p (- p) q (1+  p)
          -q (- q) r (+ 2 p)
          -r (- r) i (/ pi 6.0)
           a 0.0
    )
    (repeat 12
        (setq l (cons (list (* r (cos a)) (* r (sin a))) l)
              a (- a i)
        )
    )
    (setq c (apply 'append (mapcar 'list (cons (last l) l) l)))
    (list
        (list 1
            (list -p -p) (list p -p) (list p -p) (list p p) (list p p) (list -p p) (list -p p) (list -p -p)
            (list -q -q) (list q -q) (list q -q) (list q q) (list q q) (list -q q) (list -q q) (list -q -q)
        )
        (list 2
            (list -r -q) (list 0  r) (list 0  r) (list r -q)
            (list -p -p) (list p -p) (list p -p) (list 0  p) (list 0  p) (list -p -p)
            (list -q -q) (list q -q) (list q -q) (list 0  q) (list 0  q) (list -q -q)
        )
        (cons 4 c)
        (vl-list* 8 (list -r -r) (list r r) (list r -r) (list -r r) c)
        (list 16
            (list p 0) (list 0 p) (list 0 p) (list -p 0) (list -p 0) (list 0 -p) (list 0 -p) (list p 0)
            (list q 0) (list 0 q) (list 0 q) (list -q 0) (list -q 0) (list 0 -q) (list 0 -q) (list q 0)
            (list r 0) (list 0 r) (list 0 r) (list -r 0) (list -r 0) (list 0 -r) (list 0 -r) (list r 0)
        )
        (list 32
            (list  r r) (list -r -r) (list  r q) (list -q -r) (list  q r) (list -r -q)
            (list -r r) (list  r -r) (list -q r) (list  r -q) (list -r q) (list  q -r)
        )
        (list 64
            '( 0  1) (list  0  p) (list  0  p) (list -p  p) (list -p  p) (list -p -1) (list -p -1) '( 0 -1)
            '( 0 -1) (list  0 -p) (list  0 -p) (list  p -p) (list  p -p) (list  p  1) (list  p  1) '( 0  1)
            '( 1  2) (list  1  q) (list  1  q) (list -q  q) (list -q  q) (list -q -2) (list -q -2) '(-1 -2)
            '(-1 -2) (list -1 -q) (list -1 -q) (list  q -q) (list  q -q) (list  q  2) (list  q  2) '( 1  2)
        )
        (list 128
            (list (1+ -p) 0) '(0 0) '(0 0) (list 0 (1+ -p))
            (list (1+ -p) 1) '(1 1) '(1 1) (list 1 (1+ -p))
            (list -p q) (list -p -p) (list -p -p) (list q -p)
            (list -q q) (list -q -q) (list -q -q) (list q -q)
        )
        (vl-list* 256 (list -r r)  (list r r) (list -r (1+ r)) (list r (1+ r)) c)
        (list 512
            (list -p -p) (list  p -p) (list -p  p) (list p p) (list -q -q) (list  q -q)
            (list  q -q) (list -q  q) (list -q  q) (list q q) (list  q  q) (list -q -q)
        )
        (list 2048
            (list   -p     -p) (list    p      p) (list   -p      p) (list    p     -p)
            (list (+ p 05) -p) (list (+ p 06) -p) (list (+ p 05) -q) (list (+ p 06) -q)
            (list (+ p 09) -p) (list (+ p 10) -p) (list (+ p 09) -q) (list (+ p 10) -q)
            (list (+ p 13) -p) (list (+ p 14) -p) (list (+ p 13) -q) (list (+ p 14) -q)
            (list -p -p) (list p -p) (list p -p) (list p p) (list p p) (list -p p) (list -p p) (list -p -p)
            (list -q -q) (list q -q) (list q -q) (list q q) (list q q) (list -q q) (list -q q) (list -q -q)
        )
        (list 8192 (list r 1) (list -r -q) (list r 0) (list -r -r) (list r q) (list -r -1) (list r r) (list -r 0))
    )
)

;; Object Snap for grread: Parse Point  -  Lee Mac
;; bpt - [lst] Basepoint for relative point input, e.g. @5,5
;; str - [str] String representing point input
;; Returns: [lst] Point represented by the given string, else nil

(defun LM:grsnap:parsepoint ( bpt str / str->lst lst )
 
    (defun str->lst ( str / pos )
        (if (setq pos (vl-string-position 44 str))
            (cons (substr str 1 pos) (str->lst (substr str (+ pos 2))))
            (list str)
        )
    )

    (if (wcmatch str "`@*")
        (setq str (substr str 2))
        (setq bpt '(0.0 0.0 0.0))
    )           

    (if
        (and
            (setq lst (mapcar 'distof (str->lst str)))
            (vl-every 'numberp lst)
            (< 1 (length lst) 4)
        )
        (mapcar '+ bpt lst)
    )
)

;; Object Snap for grread: Snap Mode  -  Lee Mac
;; str - [str] Object Snap modifier
;; Returns: [int] Object Snap bit code for the given modifier, else nil

(defun LM:grsnap:snapmode ( str )
    (vl-some
        (function
            (lambda ( x )
                (if (wcmatch (car x) (strcat (strcase str t) "*"))
                    (progn
                        (princ (cadr x)) (caddr x)
                    )
                )
            )
        )
       '(
            ("endpoint"      " of " 00001)
            ("midpoint"      " of " 00002)
            ("center"        " of " 00004)
            ("node"          " of " 00008)
            ("quadrant"      " of " 00016)
            ("intersection"  " of " 00032)
            ("insert"        " of " 00064)
            ("perpendicular" " to " 00128)
            ("tangent"       " to " 00256)
            ("nearest"       " to " 00512)
            ("appint"        " of " 02048)
            ("parallel"      " to " 08192)
            ("none"          ""     16384)
        )
    )
)

;; OLE -> ACI  -  Lee Mac
;; Args: c - [int] OLE Colour

(defun LM:OLE->ACI ( c )
    (apply 'LM:RGB->ACI (LM:OLE->RGB c))
)

;; OLE -> RGB  -  Lee Mac
;; Args: c - [int] OLE Colour

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

;; RGB -> ACI  -  Lee Mac
;; Args: r,g,b - [int] Red, Green, Blue values

(defun LM:RGB->ACI ( r g b / c o )
    (if (setq o (vla-getinterfaceobject (LM: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
            )
        )
    )
)

;; Application Object  -  Lee Mac
;; Returns the VLA Application Object

(defun LM:acapp nil
    (eval (list 'defun 'LM:acapp 'nil (vlax-get-acad-object)))
    (LM:acapp)
)
 
;; 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)
)
 
(vl-load-com) (princ)

For your example, you would call the above function in the following way:

(defun c:test ( / pnt )
    (if
        (setq pnt
            (LM:getpointwithcustomcursor "\nSpecify point: "
               '(   1 ;; cursor colour
                    (-50 -50) ( 50 -50)
                    ( 50 -50) ( 50  50)
                    ( 50  50) (-50  50)
                    (-50  50) (-50 -50)
                )
            )
        )
        (entmake (list '(0 . "POINT") (cons 10 (trans pnt 1 0))))
    )
    (princ)
)

Here is a quick demo:

Furthermore, since the function will accept an arbitrary vector list, it is possible to use AutoLISP to convert a bitmap image into a list of ACI colour values, and display each colour at the appropriate pixel using the grvecs vector list.

In this way, the cursor can become any image...

Lee Mac Programming • Twitter • Exchange App Store

Anonymous · ‎11-03-2014

Mr. Kent1Cooper,

That fix that you gave me, (meaning the first one), was exactly the right thing to program. I really appreciate the help that you have

given me. If you ever need any help from me on some issue of Autocad that I might be able to help you with, feel free to contact me.

L. Gojer

Kent1Cooper · ‎11-03-2014

@Anonymous wrote:

....

That fix that you gave me, (meaning the first one), was exactly the right thing to program. I really appreciate the help that you have

given me. If you ever need any help from me on some issue of Autocad that I might be able to help you with, feel free to contact me.

....

You're welcome. Now if I can find a way to have, say, a Guinness Stout qualify as an "issue of AutoCAD"....

Kent Cooper, AIA

Script to create a temporary cursor

Script to create a temporary cursor

Forums Links

Post to forums