Count by color

adaptacad · ‎05-15-2018

Hello folks this lisp works perfectly for counting blocks inside a polyline,
how would you tell the objects by color? and an exact Text "1: 8" "1: 4"?
Example
10 objects color green = green 10
50 objects color yellow = yellow 50
13 texts "1: 8" = 1: 8 13

(defun c:BCountIn ( / pl ss i T_BlockName T_Entity T_BlockList T_Item T_BlockCounter)

  (if (and (setq pl (car (entsel "\nPolyline: ")))
           (setq ss (ssget "_X" (list '(0 . "INSERT") (cons 410 (getvar 'CTAB)))))
           (setq T_BlockCounter 0))
    (progn
      (repeat (setq i (sslength ss))
        (if (LM:Inside-p (cdr (assoc 10 (entget (setq T_Entity (ssname ss (setq i (1- i))))))) pl)
          (setq T_BlockCounter (1+ T_BlockCounter)
                T_BlockList (if (not (assoc (setq T_BlockName (cdr (assoc 2 (entget T_Entity)))) T_BlockList))
                              (append T_BlockList (list (list T_BlockName 1)))
                              (subst  (list T_BlockName (1+ (cadr (assoc T_BlockName T_BlockList)))) (assoc T_BlockName T_BlockList) T_BlockList)))))
      (if T_BlockList
        (progn
          (princ (strcat "\n ** Total number of blocks found: " (itoa T_BlockCounter) "\n"))
          (foreach T_Item (vl-sort T_BlockList '(lambda (T_Block1 T_Block2) (< (car T_Block1) (car T_Block2))))
            (princ (strcat "\n" (car T_Item) ": " (itoa (cadr T_Item)))))))))
  (princ)
)
        



  ; Lee Mac Point Inside the Polyline
  (defun LM:Inside-p ( pt ent / _GroupByNum lst nrm obj tmp )

    (defun *error* (errmsg)
      (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
        (princ (strcat "\nError: " errmsg)))
      (vla-put-color obj acYellow)
      (princ))
    
    
    (defun _GroupByNum ( l n / r)
      (if l
        (cons (reverse (repeat n (setq r (cons (car l) r) l (cdr l)) r))
              (_GroupByNum l n))))
    
    (if (= (type ent) 'VLA-OBJECT)
      (setq obj ent
            ent (vlax-vla-object->ename ent))
      (setq obj (vlax-ename->vla-object ent)))
    
    (setq lst (_GroupByNum (vlax-invoke (setq tmp (vlax-ename->vla-object (entmakex (list
                                                                                      (cons 0 "RAY")
                                                                                      (cons 100 "AcDbEntity")
                                                                                      (cons 100 "AcDbRay")
                                                                                      (cons 10 pt)
                                                                                      (cons 11 (trans '(1. 0. 0.) ent 0))))))
                             'IntersectWith obj acextendnone) 3 ))
    (vla-delete tmp)
    (setq nrm (cdr (assoc 210 (entget ent))))
    
    ;; gile:
    (and lst (not (vlax-curve-getparamatpoint ent pt))
         (= 1 (rem (length (vl-remove-if (function (lambda ( p / pa p- p+ p0 s1 s2 )
                                                     (setq pa (vlax-curve-getparamatpoint ent p))
                                                     (or (and (equal (fix (+ pa (if (minusp pa) -0.5 0.5))) pa 1e-8)
                                                              (setq p- (cond ((setq p- (vlax-curve-getPointatParam ent (- pa 1e-8)))
                                                                              (trans p- 0 nrm))
                                                                             ((trans (vlax-curve-getPointatParam ent (- (vlax-curve-getEndParam ent) 1e-8)) 0 nrm))))
                                                              (setq p+ (cond ((setq p+ (vlax-curve-getPointatParam ent (+ pa 1e-8)))
                                                                              (trans p+ 0 nrm))
                                                                             ((trans (vlax-curve-getPointatParam ent (+ (vlax-curve-getStartParam ent) 1e-8)) 0 nrm))))
                                                              (setq p0 (trans pt 0 nrm))
                                                              (<= 0 (* (sin (angle p0 p-)) (sin (angle p0 p+)))) ;; LM Mod
                                                              )
                                                         (and (/= 0. (vla-getBulge obj (fix pa)))
                                                           (equal '(0. 0.)
                                                                  (cdr (trans (vlax-curve-getFirstDeriv ent pa) 0 nrm)) 1e-9)))))
                             lst
                             ))
                   2))))

DannyNL · ‎05-31-2018

@ВeekeeCZ brought this under my attention.

Not sure if it's still an issue or not, but here's a quick 'n dirty version.

I've maintained part of your code and didn't optimize or rewrite everything, but it should do the job.

As your example only speaks of blocks and text, these are the only two objecttypes that are counted but this could be easily expanded to more if needed.

I've only modified the c:BCountIn code, so the rest of the routines stay the same and I didn't include them in the code below.

(defun c:BCountIn (/ T_BLOCKLIST      T_BLOCKNAME      T_COLOR          T_COLORLIST      T_COLORNAMELIST  T_COLORNUMBERLIST
                     T_ENTITYLIST     T_FOUND          T_FOUNDLIST      T_POLYLINE       T_POS            T_SELECTION      T_TEXTLIST
                     T_TEXTVALUE      T_TYPE
                    )
   (if
      (and
         (setq T_Polyline (car (entsel "\nSelect Polyline: ")))
         (setq T_Selection (ssget "_X" (list '(0 . "INSERT,TEXT") (cons 410 (getvar 'CTAB)))))
      )
      (progn
         (foreach T_Entity (ssnamex T_Selection)
            (if
               (or
                  (and
                     (= (setq T_Type (cdr (assoc 0 (setq T_EntityList (entget (setq T_Entity (cadr T_Entity))))))) "TEXT")
                     (or
                        (and
                           (or
                              (/= (cdr (assoc 72 T_EntityList)) 0)
                              (/= (cdr (assoc 73 T_EntityList)) 0)
                           )
                           (LM:Inside-p (cdr (assoc 11 T_EntityList)) T_Polyline)
                        )
                        (and                                          
                           (= (cdr (assoc 72 T_EntityList)) 0)
                           (= (cdr (assoc 73 T_EntityList)) 0)
                           (LM:Inside-p (cdr (assoc 10 T_EntityList)) T_Polyline)
                        )
                     )                                          
                  )
                  (and
                     (/= T_Type "TEXT")
                     (LM:Inside-p (cdr (assoc 10 T_EntityList)) T_Polyline)
                  )
               )
               (if
                  (setq T_Found (assoc T_Type T_FoundList))
                  (setq T_FoundList (subst (append T_Found (list T_Entity)) T_Found T_FoundList))
                  (setq T_FoundList (append T_FoundList (list (list T_Type T_Entity))))
               )
            )
         )
         (if
            T_FoundList
            (progn
               (foreach T_Item T_FoundList
                  (setq T_Type (car T_Item))
                  (foreach T_Entity (cdr T_Item)
                     (setq T_EntityList (entget T_Entity))
                     (cond
                        (
                           (= T_Type "TEXT")
                           (setq T_TextList
                              (if
                                 (not (assoc (setq T_TextValue (cdr (assoc 1 T_EntityList))) T_TextList))                              
                                 (append T_TextList (list (list T_TextValue 1)))
                                 (subst (list T_TextValue (1+ (cadr (assoc T_TextValue T_TextList)))) (assoc T_TextValue T_TextList) T_TextList)
                              )
                           )
                        )
                        (
                           (= T_Type "INSERT")
                           (setq T_BlockList
                              (if
                                 (not (assoc (setq T_BlockName (cdr (assoc 2 T_EntityList))) T_BlockList))                              
                                 (append T_BlockList (list (list T_BlockName 1)))
                                 (subst (list T_BlockName (1+ (cadr (assoc T_BlockName T_BlockList)))) (assoc T_BlockName T_BlockList) T_BlockList)
                              )
                           )
                        )
                        (
                           T
                           nil
                        )
                     )
                     (setq T_ColorList
                        (if
                           (not (assoc (setq T_Color (if (setq T_Temp (cdr (assoc 62 T_EntityList))) T_Temp -1)) T_ColorList))                              
                           (append T_ColorList (list (list T_Color 1)))
                           (subst (list T_Color (1+ (cadr (assoc T_Color T_ColorList)))) (assoc T_Color T_ColorList) T_ColorList)
                        )
                     )
                  )
               )
               (foreach T_Item '(T_TextList T_BlockList T_ColorList)                  
                  (if
                     T_Item
                     (progn
                        (setq T_ColorNumberList '(-1        0         1     2        3       4      5      6         7       256))
                        (setq T_ColorNameList   '("ByLayer" "ByBlock" "Red" "Yellow" "Green" "Cyan" "Blue" "Magenta" "White" "ByLayer"))
                        (princ "\n")
                        (princ (strcat "\n" (substr (vl-princ-to-string T_Item) 3) ":"))
                        (setq T_Item (vl-sort (eval T_Item) '(lambda (T_Item1 T_Item2) (< (car T_Item1) (car T_Item2)))))
                        (mapcar
                           '(lambda (T_ListItem)
                               (princ (strcat "\n" (vl-princ-to-string (if (setq T_Pos (vl-position (car T_ListItem) T_ColorNumberList))(nth T_Pos T_ColorNameList) (car T_ListItem))) ": " (itoa (cadr T_ListItem))))
                            )
                           T_Item
                        )                        
                     )
                  )
               )
            )
         )                     
      )
   )
   (princ)
)

adaptacad · ‎06-01-2018

Sorry, @DannyNL but it does not work !!

marko_ribar · ‎06-02-2018

Use (LM:Inside-p) along with Danny's revision and remove '(0 . "INSERT,TEXT") from the beggining - creating selection set...

Marko Ribar, d.i.a. (graduated engineer of architecture)

marko_ribar · ‎06-02-2018

Actually, there is slightly more than that... This mod worked for me fine...

(defun c:BCountIn (/ T_BLOCKLIST      T_BLOCKNAME      T_COLOR          T_COLORLIST      T_COLORNAMELIST  T_COLORNUMBERLIST
                     T_ENTITYLIST     T_FOUND          T_FOUNDLIST      T_POLYLINE       T_POS            T_SELECTION      T_TEXTLIST
                     T_TEXTVALUE      T_TYPE           LM:Inside-p      minbb            maxbb
                    )

   (vl-load-com)

   ; Lee Mac Point Inside the Polyline
   (defun LM:Inside-p ( pt ent / _GroupByNum lst nrm obj tmp )

     (vl-load-com)

     (defun *error* ( errmsg )
       (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
         (princ (strcat "\nError: " errmsg))
       )
       (vla-put-color obj acYellow)
       (princ)
     )


     (defun _GroupByNum ( l n / r )
       (if l
         (cons (reverse (repeat n (setq r (cons (car l) r) l (cdr l)) r)) (_GroupByNum l n))
       )
     )

     (if (= (type ent) 'VLA-OBJECT)
       (setq obj ent
             ent (vlax-vla-object->ename ent))
       (setq obj (vlax-ename->vla-object ent))
     )

     (setq lst
       (_GroupByNum
         (vlax-invoke
           (setq tmp
             (vlax-ename->vla-object
               (entmakex
                 (list
                   (cons 0 "RAY")
                   (cons 100 "AcDbEntity")
                   (cons 100 "AcDbRay")
                   (cons 10 pt)
                   (cons 11 (trans '(1. 0. 0.) ent 0))
                 )
               )
             )
           )
           'IntersectWith obj acextendnone
         ) 3
       )
     )
     (vla-delete tmp)
     (setq nrm (cdr (assoc 210 (entget ent))))

     ;; gile:
     (and
       lst
       (not (vlax-curve-getparamatpoint ent pt))
       (= 1 (rem (length (vl-remove-if (function (lambda ( p / pa p- p+ p0 s1 s2 )
                                                   (setq pa (vlax-curve-getparamatpoint ent p))
                                                   (or (and (equal (fix (+ pa (if (minusp pa) -0.5 0.5))) pa 1e-8)
                                                            (setq p- (cond ((setq p- (vlax-curve-getPointatParam ent (- pa 1e-8)))
                                                                            (trans p- 0 nrm)
                                                                           )
                                                                           ((trans (vlax-curve-getPointatParam ent (- (vlax-curve-getEndParam ent) 1e-8)) 0 nrm)
                                                                           )
                                                                     )
                                                            )
                                                            (setq p+ (cond ((setq p+ (vlax-curve-getPointatParam ent (+ pa 1e-8)))
                                                                            (trans p+ 0 nrm)
                                                                           )
                                                                           ((trans (vlax-curve-getPointatParam ent (+ (vlax-curve-getStartParam ent) 1e-8)) 0 nrm)
                                                                           )
                                                                     )
                                                            )
                                                            (setq p0 (trans pt 0 nrm))
                                                            (<= 0 (* (sin (angle p0 p-)) (sin (angle p0 p+)))) ;; LM Mod
                                                       )
                                                       (and (/= 0. (vla-getBulge obj (fix pa)))
                                                            (equal '(0. 0.) (cdr (trans (vlax-curve-getFirstDeriv ent pa) 0 nrm)) 1e-9)
                                                       )
                                                   )
                                                 )
                                       ) lst
                         )
                 ) 2
            )
       )
     )
   ); end defun

   (if
      (and
         (setq T_Polyline (car (entsel "\nSelect Polyline: ")))
         (setq T_Selection (ssget "_A" (list (cons 410 (if (= 1 (getvar 'CVPORT)) (getvar 'CTAB) "Model")))))
      )
      (progn
         (foreach T_Entity (ssnamex T_Selection)
            (if
               (or
                  (and
                     (= (setq T_Type (cdr (assoc 0 (setq T_EntityList (entget (setq T_Entity (cadr T_Entity))))))) "TEXT")
                     (or
                        (and
                           (or
                              (/= (cdr (assoc 72 T_EntityList)) 0)
                              (/= (cdr (assoc 73 T_EntityList)) 0)
                           )
                           (LM:Inside-p (trans (cdr (assoc 11 T_EntityList)) T_Entity 0) T_Polyline)
                        )
                        (and                                          
                           (= (cdr (assoc 72 T_EntityList)) 0)
                           (= (cdr (assoc 73 T_EntityList)) 0)
                           (LM:Inside-p (trans (cdr (assoc 10 T_EntityList)) T_Entity 0) T_Polyline)
                        )
                     )                                          
                  )
                  (and
                     (= T_Type "INSERT")
                     (LM:Inside-p (trans (cdr (assoc 10 T_EntityList)) T_Entity 0) T_Polyline)
                  )
                  (and
                     (and (/= T_Type "TEXT") (/= T_Type "INSERT"))
                     (progn
                         (vla-getboundingbox (vlax-ename->vla-object T_Entity) 'minbb 'maxbb)
                         (mapcar 'set '(minbb maxbb) (mapcar 'safearray-value (list minbb maxbb)))
                         (LM:Inside-p (mapcar '(lambda (p1 p2) (/ (+ p1 p2) 2.0)) minbb maxbb) T_Polyline)
                     )
                  )
               )
               (if
                  (setq T_Found (assoc T_Type T_FoundList))
                  (setq T_FoundList (subst (append T_Found (list T_Entity)) T_Found T_FoundList))
                  (setq T_FoundList (append T_FoundList (list (list T_Type T_Entity))))
               )
            )
         )
         (if
            T_FoundList
            (progn
               (foreach T_Item T_FoundList
                  (setq T_Type (car T_Item))
                  (foreach T_Entity (cdr T_Item)
                     (setq T_EntityList (entget T_Entity))
                     (cond
                        (
                           (= T_Type "TEXT")
                           (setq T_TextList
                              (if
                                 (not (assoc (setq T_TextValue (cdr (assoc 1 T_EntityList))) T_TextList))                              
                                 (append T_TextList (list (list T_TextValue 1)))
                                 (subst (list T_TextValue (1+ (cadr (assoc T_TextValue T_TextList)))) (assoc T_TextValue T_TextList) T_TextList)
                              )
                           )
                        )
                        (
                           (= T_Type "INSERT")
                           (setq T_BlockList
                              (if
                                 (not (assoc (setq T_BlockName (cdr (assoc 2 T_EntityList))) T_BlockList))                              
                                 (append T_BlockList (list (list T_BlockName 1)))
                                 (subst (list T_BlockName (1+ (cadr (assoc T_BlockName T_BlockList)))) (assoc T_BlockName T_BlockList) T_BlockList)
                              )
                           )
                        )
                        (
                           T
                           nil
                        )
                     )
                     (setq T_ColorList
                        (if
                           (not (assoc (setq T_Color (if (setq T_Temp (cdr (assoc 62 T_EntityList))) T_Temp -1)) T_ColorList))                              
                           (append T_ColorList (list (list T_Color 1)))
                           (subst (list T_Color (1+ (cadr (assoc T_Color T_ColorList)))) (assoc T_Color T_ColorList) T_ColorList)
                        )
                     )
                  )
               )
               (foreach T_Item '(T_TextList T_BlockList T_ColorList)                  
                  (if
                     T_Item
                     (progn
                        (setq T_ColorNumberList '(-1        0         1     2        3       4      5      6         7       256))
                        (setq T_ColorNameList   '("ByLayer" "ByBlock" "Red" "Yellow" "Green" "Cyan" "Blue" "Magenta" "White" "ByLayer"))
                        (princ "\n")
                        (princ (strcat "\n" (substr (vl-princ-to-string T_Item) 3) ":"))
                        (setq T_Item (vl-sort (eval T_Item) '(lambda (T_Item1 T_Item2) (< (car T_Item1) (car T_Item2)))))
                        (mapcar
                           '(lambda (T_ListItem)
                               (princ (strcat "\n" (vl-princ-to-string (if (setq T_Pos (vl-position (car T_ListItem) T_ColorNumberList))(nth T_Pos T_ColorNameList) (car T_ListItem))) ": " (itoa (cadr T_ListItem))))
                            )
                           T_Item
                        )
                     )
                  )
               )
            )
         )
      )
   )
   (princ)
)

HTH., M.R.

Marko Ribar, d.i.a. (graduated engineer of architecture)

marko_ribar · ‎06-03-2018

When I think more over, I did noticed that Lee has over programmed his sub posted in this topic... My revisions would be :

- for 2d polyline or lwpolyline

; Lee Mac Point Inside the Polyline
(defun LM:Inside-p ( pt ent / _GroupByNum lst nrm obj tmp )

  (vl-load-com)

  (defun *error* ( errmsg )
    (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
      (princ (strcat "\nError: " errmsg))
    )
    (vla-put-color obj acYellow)
    (princ)
  )

  (defun _GroupByNum ( l n / r )
    (if l
      (cons (reverse (repeat n (setq r (cons (car l) r) l (cdr l)) r)) (_GroupByNum l n))
    )
  )

  (if (= (type ent) 'VLA-OBJECT)
    (setq obj ent
          ent (vlax-vla-object->ename ent))
    (setq obj (vlax-ename->vla-object ent))
  )

  (if (vlax-curve-isplanar ent)
    (progn
      (setq lst
        (_GroupByNum
          (vlax-invoke
            (setq tmp
              (vlax-ename->vla-object
                (entmakex
                  (list
                    (cons 0 "RAY")
                    (cons 100 "AcDbEntity")
                    (cons 100 "AcDbRay")
                    (cons 10 pt)
                    (cons 11 (trans '(1. 0. 0.) ent 0))
                  )
                )
              )
            )
            'IntersectWith obj acextendnone
          ) 3
        )
      )
      (vla-delete tmp)
      (setq nrm (cdr (assoc 210 (entget ent))))
      ;; gile:
      (and
        lst
        (not (vlax-curve-getparamatpoint ent pt))
        (= 1 (rem (length (vl-remove-if (function (lambda ( p / pa p- p+ p0 )
                                                    (setq pa (vlax-curve-getparamatpoint ent p))
                                                    (and (setq p- (cond ((setq p- (vlax-curve-getPointatParam ent (- pa 1e-8)))
                                                                         (trans p- 0 nrm)
                                                                        )
                                                                        ((trans (vlax-curve-getPointatParam ent (- (vlax-curve-getEndParam ent) 1e-8)) 0 nrm)
                                                                        )
                                                                  )
                                                         )
                                                         (setq p+ (cond ((setq p+ (vlax-curve-getPointatParam ent (+ pa 1e-8)))
                                                                         (trans p+ 0 nrm)
                                                                        )
                                                                        ((trans (vlax-curve-getPointatParam ent (+ (vlax-curve-getStartParam ent) 1e-8)) 0 nrm)
                                                                        )
                                                                  )
                                                         )
                                                         (setq p0 (trans pt 0 nrm))
                                                         (<= 0 (* (sin (angle p0 p-)) (sin (angle p0 p+)))) ;; LM Mod
                                                    )
                                                  )
                                        ) lst
                          )
                  ) 2
             )
        )
      )
    )
    (prompt "\nReference curve isn't planar...")
  )
)

Though checking for planar property here wasn't really necessity, but I'll leave it like it is...

- for curve that is planar - general sub function :

; Lee Mac Point Inside Curve
(defun LM:Inside-p ( pt ent / unit v^v _GroupByNum fd1 fd2 par lst nrm obj tmp )

  (vl-load-com)

  (defun *error* ( errmsg )
    (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
      (princ (strcat "\nError: " errmsg))
    )
    (vla-put-color obj acYellow)
    (princ)
  )

  (defun unit ( v / d )
    (if (not (equal (setq d (distance '(0.0 0.0 0.0) v)) 0.0 1e-8))
      (mapcar '(lambda ( x ) (/ x d)) v)
    )
  )

  (defun v^v ( u v )
    (list
      (- (* (cadr u) (caddr v)) (* (caddr u) (cadr v)))
      (- (* (caddr u) (car v)) (* (car u) (caddr v)))
      (- (* (car u) (cadr v)) (* (cadr u) (car v)))
    )
  )

  (defun _GroupByNum ( l n / r )
    (if l
      (cons (reverse (repeat n (setq r (cons (car l) r) l (cdr l)) r)) (_GroupByNum l n))
    )
  )

  (if (= (type ent) 'VLA-OBJECT)
    (setq obj ent
          ent (vlax-vla-object->ename ent))
    (setq obj (vlax-ename->vla-object ent))
  )

  (if (vlax-curve-isplanar ent)
    (progn
      (setq fd1 (vlax-curve-getfirstderiv ent (setq par (vlax-curve-getstartparam ent))))
      (while (equal fd1 (setq fd2 (vlax-curve-getfirstderiv ent (setq par (+ par 0.001)))) 1e-3))
      (setq nrm (unit (v^v fd1 fd2)))
      (setq lst
        (_GroupByNum
          (vlax-invoke
            (setq tmp
              (vlax-ename->vla-object
                (entmakex
                  (list
                    (cons 0 "RAY")
                    (cons 100 "AcDbEntity")
                    (cons 100 "AcDbRay")
                    (cons 10 pt)
                    (cons 11 (trans '(1. 0. 0.) nrm 0))
                  )
                )
              )
            )
            'IntersectWith obj acextendnone
          ) 3
        )
      )
      (vla-delete tmp)
      ;; gile:
      (and
        lst
        (not (vlax-curve-getparamatpoint ent pt))
        (= 1 (rem (length (vl-remove-if (function (lambda ( p / pa p- p+ p0 )
                                                    (setq pa (vlax-curve-getparamatpoint ent p))
                                                    (and (setq p- (cond ((setq p- (vlax-curve-getPointatParam ent (- pa 1e-8)))
                                                                         (trans p- 0 nrm)
                                                                        )
                                                                        ((trans (vlax-curve-getPointatParam ent (- (vlax-curve-getEndParam ent) 1e-8)) 0 nrm)
                                                                        )
                                                                  )
                                                         )
                                                         (setq p+ (cond ((setq p+ (vlax-curve-getPointatParam ent (+ pa 1e-8)))
                                                                         (trans p+ 0 nrm)
                                                                        )
                                                                        ((trans (vlax-curve-getPointatParam ent (+ (vlax-curve-getStartParam ent) 1e-8)) 0 nrm)
                                                                        )
                                                                  )
                                                         )
                                                         (setq p0 (trans pt 0 nrm))
                                                         (<= 0 (* (sin (angle p0 p-)) (sin (angle p0 p+)))) ;; LM Mod
                                                    )
                                                  )
                                        ) lst
                          )
                  ) 2
             )
        )
      )
    )
    (prompt "\nReference curve isn't planar...")
  )
)

Here check for planar property is necessity...

Regards, M.R.

P.S. Update previously posted routine if you want to use my revision which is slightly truncated, but it works the same... For curve in general truncation is a must...

Marko Ribar, d.i.a. (graduated engineer of architecture)

marko_ribar · ‎06-03-2018

So here is my final revision I hope... This is general case of closed planar curve instead of just polyline as reference curve... It worked for me, so here is the code :

(defun c:ACICountIn (/ T_BLOCKLIST      T_BLOCKNAME      T_COLOR          T_COLORLIST      T_COLORNAMELIST  T_COLORNUMBERLIST
                       T_ENTITYLIST     T_FOUND          T_FOUNDLIST      T_CURVE          T_POS            T_SELECTION      T_TEXTLIST       T_TEXTVALUE      T_TYPE           LM:Inside-p      minbb            maxbb
                    )

  (vl-load-com)

  ; Lee Mac Point Inside Curve
  (defun LM:Inside-p ( pt ent / unit v^v _GroupByNum fd1 fd2 par lst nrm obj tmp )

    (vl-load-com)

    (defun *error* ( errmsg )
      (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
        (princ (strcat "\nError: " errmsg))
      )
      (vla-put-color obj acYellow)
      (princ)
    )

    (defun unit ( v / d )
      (if (not (equal (setq d (distance '(0.0 0.0 0.0) v)) 0.0 1e-8))
        (mapcar '(lambda ( x ) (/ x d)) v)
      )
    )

    (defun v^v ( u v )
      (list
        (- (* (cadr u) (caddr v)) (* (caddr u) (cadr v)))
        (- (* (caddr u) (car v)) (* (car u) (caddr v)))
        (- (* (car u) (cadr v)) (* (cadr u) (car v)))
      )
    )

    (defun _GroupByNum ( l n / r )
      (if l
        (cons (reverse (repeat n (setq r (cons (car l) r) l (cdr l)) r)) (_GroupByNum l n))
      )
    )

    (if (= (type ent) 'VLA-OBJECT)
      (setq obj ent
            ent (vlax-vla-object->ename ent))
      (setq obj (vlax-ename->vla-object ent))
    )

    (if (vlax-curve-isplanar ent)
      (progn
        (setq fd1 (vlax-curve-getfirstderiv ent (setq par (vlax-curve-getstartparam ent))))
        (while (equal fd1 (setq fd2 (vlax-curve-getfirstderiv ent (setq par (+ par 0.001)))) 1e-3))
        (setq nrm (unit (v^v fd1 fd2)))
        (setq lst
          (_GroupByNum
            (vlax-invoke
              (setq tmp
                (vlax-ename->vla-object
                  (entmakex
                    (list
                      (cons 0 "RAY")
                      (cons 100 "AcDbEntity")
                      (cons 100 "AcDbRay")
                      (cons 10 pt)
                      (cons 11 (trans '(1. 0. 0.) nrm 0))
                    )
                  )
                )
              )
              'IntersectWith obj acextendnone
            ) 3
          )
        )
        (vla-delete tmp)
        ;; gile:
        (and
          lst
          (not (vlax-curve-getparamatpoint ent pt))
          (= 1 (rem (length (vl-remove-if (function (lambda ( p / pa p- p+ p0 )
                                                      (setq pa (vlax-curve-getparamatpoint ent p))
                                                      (and (setq p- (cond ((setq p- (vlax-curve-getPointatParam ent (- pa 1e-8)))
                                                                           (trans p- 0 nrm)
                                                                          )
                                                                          ((trans (vlax-curve-getPointatParam ent (- (vlax-curve-getEndParam ent) 1e-8)) 0 nrm)
                                                                          )
                                                                    )
                                                           )
                                                           (setq p+ (cond ((setq p+ (vlax-curve-getPointatParam ent (+ pa 1e-8)))
                                                                           (trans p+ 0 nrm)
                                                                          )
                                                                          ((trans (vlax-curve-getPointatParam ent (+ (vlax-curve-getStartParam ent) 1e-8)) 0 nrm)
                                                                          )
                                                                    )
                                                           )
                                                           (setq p0 (trans pt 0 nrm))
                                                           (<= 0 (* (sin (angle p0 p-)) (sin (angle p0 p+)))) ;; LM Mod
                                                      )
                                                    )
                                          ) lst
                            )
                    ) 2
               )
          )
        )
      )
      (prompt "\nReference curve isn't planar...")
    )
  )

  (while (or (not (setq T_Curve (car (entsel "\nSelect closed planar curve to count entities by color inside it...")))) (if T_Curve (or (vl-catch-all-error-p (vl-catch-all-apply 'vlax-curve-getendparam (list T_Curve))) (not (vlax-curve-isclosed T_Curve)) (not (vlax-curve-isplanar T_Curve)))))
    (prompt "\nMissed or picked wrong entity type or picked curve is open or picked curve is not planar...")
  )
  (setq T_Selection (ssget "_A" (list (cons 410 (if (= 1 (getvar 'CVPORT)) (getvar 'CTAB) "Model")))))
  (if (ssmemb T_Curve T_Selection)
    (ssdel T_Curve T_Selection)
  )
  (if
    (and
      T_Curve
      T_Selection
    )
    (progn
      (foreach T_Entity (ssnamex T_Selection)
        (if
          (or
            (and
              (= (setq T_Type (cdr (assoc 0 (setq T_EntityList (entget (setq T_Entity (cadr T_Entity))))))) "TEXT")
              (or
                (and
                  (or
                    (/= (cdr (assoc 72 T_EntityList)) 0)
                    (/= (cdr (assoc 73 T_EntityList)) 0)
                  )
                  (LM:Inside-p (trans (cdr (assoc 11 T_EntityList)) T_Entity 0) T_Curve)
                )
                (and                                          
                  (= (cdr (assoc 72 T_EntityList)) 0)
                  (= (cdr (assoc 73 T_EntityList)) 0)
                  (LM:Inside-p (trans (cdr (assoc 10 T_EntityList)) T_Entity 0) T_Curve)
                )
              )                                          
            )
            (and
              (= T_Type "INSERT")
              (LM:Inside-p (trans (cdr (assoc 10 T_EntityList)) T_Entity 0) T_Curve)
            )
            (and
              (and (/= T_Type "TEXT") (/= T_Type "INSERT"))
              (progn
                (vla-getboundingbox (vlax-ename->vla-object T_Entity) 'minbb 'maxbb)
                (mapcar 'set '(minbb maxbb) (mapcar 'safearray-value (list minbb maxbb)))
                (LM:Inside-p (mapcar '(lambda (p1 p2) (/ (+ p1 p2) 2.0)) minbb maxbb) T_Curve)
              )
            )
          )
          (if
            (setq T_Found (assoc T_Type T_FoundList))
            (setq T_FoundList (subst (append T_Found (list T_Entity)) T_Found T_FoundList))
            (setq T_FoundList (append T_FoundList (list (list T_Type T_Entity))))
          )
        )
      )
      (if
        T_FoundList
        (progn
          (foreach T_Item T_FoundList
            (setq T_Type (car T_Item))
            (foreach T_Entity (cdr T_Item)
              (setq T_EntityList (entget T_Entity))
              (cond
                (
                  (= T_Type "TEXT")
                  (setq T_TextList
                    (if
                      (not (assoc (setq T_TextValue (cdr (assoc 1 T_EntityList))) T_TextList))                              
                      (append T_TextList (list (list T_TextValue 1)))
                      (subst (list T_TextValue (1+ (cadr (assoc T_TextValue T_TextList)))) (assoc T_TextValue T_TextList) T_TextList)
                    )
                  )
                )
                (
                  (= T_Type "INSERT")
                  (setq T_BlockList
                    (if
                      (not (assoc (setq T_BlockName (cdr (assoc 2 T_EntityList))) T_BlockList))                              
                      (append T_BlockList (list (list T_BlockName 1)))
                      (subst (list T_BlockName (1+ (cadr (assoc T_BlockName T_BlockList)))) (assoc T_BlockName T_BlockList) T_BlockList)
                    )
                  )
                )
              )
              (setq T_ColorList
                (if
                  (not (assoc (setq T_Color (if (setq T_Temp (cdr (assoc 62 T_EntityList))) T_Temp -1)) T_ColorList)) 
                  (append T_ColorList (list (list T_Color 1)))
                  (subst (list T_Color (1+ (cadr (assoc T_Color T_ColorList)))) (assoc T_Color T_ColorList) T_ColorList)
                )
              )
            )
          )
          (foreach T_Item '(T_TextList T_BlockList T_ColorList)                  
            (if
              T_Item
              (progn
                (setq T_ColorNumberList '(-1        0         1     2        3       4      5      6         7       256))
                (setq T_ColorNameList   '("ByLayer" "ByBlock" "Red" "Yellow" "Green" "Cyan" "Blue" "Magenta" "White" "ByLayer"))
                (princ "\n")
                (princ (strcat "\n" (substr (vl-princ-to-string T_Item) 3) ":"))
                (setq T_Item (vl-sort (eval T_Item) '(lambda (T_Item1 T_Item2) (< (car T_Item1) (car T_Item2)))))
                (mapcar
                  '(lambda (T_ListItem)
                     (princ (strcat "\n" (vl-princ-to-string (if (setq T_Pos (vl-position (car T_ListItem) T_ColorNumberList))(nth T_Pos T_ColorNameList) (car T_ListItem))) ": " (itoa (cadr T_ListItem))))
                   )
                   T_Item
                )
              )
            )
          )
        )
      )
    )
  )
  (princ)
)

Regards, M.R.

Marko Ribar, d.i.a. (graduated engineer of architecture)

DannyNL · ‎06-03-2018

Hopefully Marko's modifications can already help you, but just stating 'it doesn't work' doesn't really help in solving the problem.

What doesn't work? Do you get an error message? Doesn't it count everything you want?

Because testing on a self-made example drawing does everything you've asked for and still does.

Please detail what doesn't work and provide an (stripped down) example drawing for us to test on if still necessary.

maratovich · ‎06-03-2018

adaptacad
What is your final goal?

---------------------------------------------------------------------
Software development
Automatic creation layouts and viewport. Batch printing drawings from model.
www.kdmsoft.net

adaptacad · ‎06-05-2018

thank you !!! you are the best
all work perfectly for my purpose ..

JustoAg · ‎07-05-2018

Hi,

I have this for a month here. Sorry for the delay.

Hope to bring another approach and help.

Regards.

;;;
;;; Get info on all objs Inside a Polyline
;;;
(defun C:GIP (/ objSel PolyName)
	(setq objSel nil)
	(while (= objSel nil)
		(setq objSel (vlax-ename->vla-object
						 (car (nentsel "\nSelect Polyline: "))
					 )
		)
	)

	;; Check it is closed.
	(if	(not (vlax-curve-isClosed objSel))
		(progn
			(princ "\nIt must be a closed Polyline. Exiting.")
			(exit)
		)
	)


	(setq PolyName (vla-get-ObjectName objSel))
	(if	(wcmatch PolyName "AcDb*Polyline")
		(FindCount objSel)
	)

)

(defun FindCount (obj / plist ss i)
	(setq plist (agroup (vlax-get obj "Coordinates")))
	(setq ss nil)
	(setq blks	   (ssadd)
		  txts	   (ssadd)
		  anyOther (ssadd)

	)

	;; Acad gently selects all objs inside the polyline by us!!
	(setq ss (ssget "_WP" plist))

	(setq i (sslength ss))

	(while (not (minusp (setq i (1- i))))
		(setq ename (ssname ss i))
		(setq entList (entget ename))

		(cond ((= (cdr (assoc 0 entList)) "INSERT")
			   (setq blks (ssadd ename blks))
			  )
			  ((= (cdr (assoc 0 entList)) "TEXT")
			   (setq txts (ssadd ename txts))
			  )
			  ((= (cdr (assoc 0 entList)) "MTEXT")
			   (setq txts (ssadd ename txts))
			  )
			  (T (setq anyOther (ssadd ename anyOther)))
		)

	)

	;; Process by group of entities
	(setq blkRes (fun1 blks 2)) ; blk, names
	(setq txtRes (fun1 txts 1)) ; text, texts
	(setq anyRes (fun1 anyOther 62)) ; any, color.

	;; Take this list for any further extension of this program
	(setq resList (list	(cons 1 blkRes) ; blks
						(cons 2 txtRes) ; txts
						(cons 3 anyRes) ; anys
				  )
	)

	(foreach n resList
		(fun2 n (car n))
	)

	(princ)

) ;_ defun


(defun fun1	(ss assocKey / i T_Entity propList propName)
	(setq propList nil)
	(setq i (sslength ss))

	(while (not (minusp (setq i (1- i))))
		(setq T_Entity (ssname ss i))

		(setq propList (if (not	(assoc (setq propName
												(cdr (assoc
														 assocKey
														 (entget
															 T_Entity
														 )
													 )
												)
									   )
									   proplist
								)
						   )
						   (append
							   proplist
							   (list (list propName 1))
						   )
						   (subst
							   (list
								   propName
								   (1+ (cadr (assoc
												 propName
												 proplist
											 )
									   )
								   )
							   )
							   (assoc propName
									  proplist
							   )
							   proplist
						   )
					   )
		)
	)
)

(defun fun2	(l key)

	(cond ((= key 1) (setq ent "Blocks"))
		  ((= key 2) (setq ent "Texts"))
		  ((= key 3) (setq ent "Other Objects"))
		  (T "Unknown")
	)

	(princ (strcat "\n ** Total number of "
				   ent
				   " found: "
				   (itoa (SumAll (cdr l)))
		   )
	)

	(PrintThem (cdr l))
)

;;;;;; helpers ;;;;;;;;

(defun PrintThem (l)
	(foreach n
			   (vl-sort
				   l
				   '(lambda	(e1 e2)
						(< (car e1) (car e2))
					)
			   )
		(princ
			(strcat
				"\n"
				(cond ((not (car n)) "Bylayer")
					  ((= (car n) 0) "Byblock")
					  ((= (type (car n)) 'INT) (getColorName (car n)))
					  (T (car n))
				)
				": "
				(itoa (cadr n))
			) ;_ strcat
		)
	)
)

(defun getColorName	(i)
	(cond ((= i 1) "Red")
		  ((= i 2) "Yellow")
		  ((= i 3) "Green")
		  ((= i 4) "Cyan")
		  ((= i 5) "Blue")
		  ((= i 6) "Magenta")
		  ((= i 7) "White")
		  (T (itoa i))
	)
)

(defun SumAll (l)
	(apply '+
		   (mapcar
			   '(lambda	(x)
					(cadr x)
				)
			   l
		   )
	)
)

(defun agroup (l)
	(if	l
		(cons (list (car l) (cadr l)) (agroup (cddr l)))
	)
)

 ;|«Visual LISP© Format Options»
(72 4 12 2 nil "_" 60 12 0 0 0 T T nil T)
;*** DO NOT add text below the comment! ***|;

Community

Count by color

Count by color

Count by color