Routine to see Blocks with XY Scale = +N/-N

[braudpat]

Hello Friends

I am looking for a routine to find / see (by drawing colored circle on the current layer) Blocks with the Same XY Scale

and others Scales ...

And I don't find it !

Green Circle if the Blocks has the same positive X & Y Scale, for example: X = N  &  Y = N

Blue Circle if  X = N  &  Y = -N

Magenta Circle if  X = -N  &  Y = N

Red Circle if  X = -N  &  Y = -N

Cyan when X & Y are differents (in Absolute value)

Please look at the joined DWG ... 

I see the following routine :

- Check that we are into the WCS

- Ask for the circle radius

- Ask for the selection (Standard ACAD selection) & Retains ONLY Blocks (INSERT) - No XREF please

- Draw Circle with the right color at each XYZ block insert point

I hope my wish is CLEAR !?

It's to detect usage of MIRROR on Blocks and Updates on the XY Scale ...

Thanks in advance, Regards, Patrice

[Ranjit_Singh · Accepted solution]

One example. Minimal testing.

;;Ranjit Singh
;;8/3/17
(defun c:somefunc  (/ ss1 rad)
 (and (setq ss1 (ssget '((0 . "insert")))
            rad (getdist "\nSpecify circle radius: "))
      (mapcar '(lambda (x)
                (cond ((apply '/= (mapcar 'abs (cdr x)))
                       (somefunc2 4 (cdr (assoc 10 (entget (car x)))) rad))
                      ((apply 'and (mapcar 'minusp (cdr x)))
                       (somefunc2 1 (cdr (assoc 10 (entget (car x)))) rad))
                      ((apply 'and (mapcar 'null (mapcar 'minusp (cdr x))))
                       (somefunc2 3 (cdr (assoc 10 (entget (car x)))) rad))
                      ((minusp (cadr x)) (somefunc2 6 (cdr (assoc 10 (entget (car x)))) rad))
                      (t (somefunc2 5 (cdr (assoc 10 (entget (car x)))) rad))))
              (mapcar '(lambda (x) (cons (cdr (assoc -1 x)) (cons (cdr (assoc 41 x)) (list (cdr (assoc 42 x))))))
                      (mapcar 'entget (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss1)))))))
 (princ))
(defun somefunc2 (col pt r) (entmake (list '(0 . "CIRCLE") (cons 62 col) (cons 10 pt) (cons 40 r))))

[Kent1Cooper · Accepted solution]

My take on it, since I had it well along by the time @Ranjit_Singh posted his:

How about Circling the entire Block?  It spares you the need to answer a prompt about the size of the Circle.  Lightly tested:

(defun C:BMSR ; = Block Mark Scale Relationship
  (/ ss n bobj bname Xsc Ysc)
  (if (setq ss (ssget '((0 . "INSERT"))))
    (repeat (setq n (sslength ss))
      (setq
        bobj (vlax-ename->vla-object (ssname ss (setq n (1- n))))
        bname
          (if (vlax-property-available-p bobj 'effectivename); dynamic?
            (vla-get-EffectiveName bobj)
            (vla-get-Name bobj)
          ); if & bname
      ); setq
      (if (not (assoc 1 (tblsearch "block" bname))); not an Xref [no path]
        (progn ; then
          (vla-getboundingbox bobj 'minpt 'maxpt)
          (setq
            LL (vlax-safearray->list minpt)
            UR (vlax-safearray->list maxpt)
            Xsc (vla-get-XScaleFactor bobj)
            Ysc (vla-get-YScaleFactor bobj)
          ); setq
          (command "_.circle"
            "_none" (mapcar '/ (mapcar '+ LL UR) '(2 2 2))
            (/ (distance LL UR) 2)
            "_.chprop" "_last" "" "_color"
              (cond
                ((and (equal Xsc Ysc 1e-4) (> Xsc 0)) "green"); same positive values
                ((equal Xsc Ysc 1e-4) "red"); same negative values
                ((and (equal Xsc (- Ysc) 1e-4) (> Xsc 0)) "blue"); same abs. value, X + Y -
                ((equal Xsc (- Ysc) 1e-4) "magenta"); same abs. value, X - Y +
                ("cyan"); different absolute values
              ); cond
            "" ; [end chprop]
          ); command
        ); progn
      ); if
    ); repeat
  ); if
  (princ)
); defun

[phanaem · Accepted solution]

I guess your problem is already solved. I just want to show you my variant

(defun c:test ( / acdoc blocks round ss r i bl o x y c)
  (setq acdoc (vla-get-activedocument (vlax-get-acad-object))
        blocks (vla-get-blocks acdoc)
  )
  (defun round (x) (atoi (rtos x 2 0)))
  (if
    (and
      (setq ss (ssget '((0 . "INSERT"))))
      (progn
        (initget 6)
        (setq r (getdist "\nSpecify circle radius: "))
      )
    )
    (repeat (setq i (sslength ss))
      (setq bl (vlax-ename->vla-object (ssname ss (setq i (1- i)))))
      (if
        (and
          (eq (vla-get-isxref (vla-item blocks (vla-get-name bl))) :vlax-false)
          (equal (vlax-get bl 'normal) '(0 0 1) 1e-8)
          (equal (caddr (setq o (vlax-get bl 'InsertionPoint))) 0.0 1e-8)
        )
        (progn
          (setq x (vla-get-XScaleFactor bl)
                y (vla-get-YScaleFactor bl)
                c (if
                    (equal (abs x) (abs y) 1e-8)
                    (cdr (assoc (round (/ (+ x y y) (abs x))) '((3 . 3) (-1 . 5) (1 . 6) (-3 . 1))))
                    4
                  )
          )
          (entmake (list '(0 . "CIRCLE") (cons 10 o) (cons 62 c) (cons 40 r)))
        )
      )
    )
  )
  (princ)
)

[braudpat]

Hello Virtual Friends

Thanks to @phanaem , @Kent1Cooper , @Ranjit_Singh

So Kudos for everybody !

French Humour: In fact ONLY 0.99 Kudo for Kent

because I had to do a Micro-Micro-Correction ...

red  -->  _red  ,  green  -->  _green , cyan -->  _cyan , blue  -->  _blue  ,  magenta  -->  _magenta

Regards, Patrice

[Kent1Cooper]

---

braudpat wrote: ....

because I had to do a Micro-Micro-Correction ...

red  -->  _red  ,  green  -->  _green , cyan -->  _cyan , blue  -->  _blue  ,  magenta  -->  _magenta

.... 

---

Or, language-independently,  red --> "1" , green --> "3" , etc.  But note that they need to be strings, not integers, since there are also ByLayer and ByBlock options.

[pbejse]

---

@braudpat wrote:

 ... 

- Draw Circle with the right color at each XYZ block insert point

.... 

It's to detect usage of MIRROR on Blocks and Updates on the XY Scale ...

---

 Use POINT entity instead of CIRCLE, but that's just me. 

[braudpat]

Hello @pbejse

YES I agree with you !

It depends "how" what I want to see !?

But with my Lisp 0.2 Level, I can modify these routines and get a Point instead of a Circle !

Happy WE, Regards, Patrice