Insert Blocks at line intersections

[Shablab]

I currently have a lisp routine to place a block at intersection points with one main line (RED) and then all other lines (WHITE) that cross it. I have a problem and cant seem to figure out how to adjust the code to make it work more fluid. 

• I would like the main line to be able to be crossed more than once by a different line and still work. Currently if a RED line is crossed twice by any single white line it will not work and the lisp will bottom out and end

(vl-load-com)
(defun c:sbx ( / )
  (progn
    (setq ent (car (entsel "\nSelect main line: ")))
    (if ent
      (progn
 (princ "\nSelect crossing line(s): ")
 (if (setq ss (ssget))
   (progn
     (setq count 0
    obj (vlax-ename->vla-object ent)
    pointlist nil
    )
     (repeat (sslength ss)
       (setq xent (ssname ss count)
      xobj (vlax-ename->vla-object xent)
      )
       (if (setq int (vla-IntersectWith obj xobj acExtendNone))
  (progn
    (setq int (vlax-safearray->list (vlax-variant-value int))
   pointlist (append pointlist (list int))
   )
    )
  )
       (setq count (1+ count))
       )
     (if (null (tblobjname "BLOCK" "SBblock"))
       (progn
  (entmake (list (cons 0 "BLOCK") (cons 2 "SBblock") (cons 70 0) (list 10 0.0 0.0 0.0)))
  (entmake '((0 . "LWPOLYLINE") (100 . "AcDbEntity") (8 . "0") (100 . "AcDbPolyline") (90 . 2) (70 . 1) (43 . 1.0) (38 . 0.0) (39 . 0.0)
      (10 2.5 0.0) (40 . 1.0) (41 . 1.0) (42 . 1.0) (91 . 0)
      (10 -2.5 0.0) (40 . 1.0) (41 . 1.0) (42 . 1.0) (91 . 0)
      (210 0.0 0.0 1.0)
      )
    )
  (setq blockname (entmake '((0 . "ENDBLK"))))
  )
       )
     (foreach pt_nth pointlist
       (entmake (append
    '((0 . "INSERT") (100 . "AcDbEntity") (8 . "0") (100 . "AcDbBlockReference") (2 . "SBblock"))
    (list (cons 10 pt_nth))
    '((41 . 1.0) (42 . 1.0) (43 . 1.0) (50 . 0.0) (70 . 0) (71 . 0) (44 . 0.0) (45 . 0.0) (210 0.0 0.0 1.0))
    )
         )
       )
     )
   )
 )
      )
    )
  (princ)
  )

 

[BIGAL]

If you have say an arc and a line it has 2 crossing points same with a pline may have many. Checked pline.

 

If you had google a little bit would have found this solution.  https://knowledge.autodesk.com/search-result/caas/CloudHelp/cloudhelp/2016/ENU/AutoCAD-ActiveX/files/GUID-1243A593-5DAE-4DC3-B539-59FDA990E687-htm.html

 

When you get intersection with it does not reveal openly that it has a list of multiple points.

4 crossing pline

: (setq tempPoint (vlax-safearray->list (vlax-variant-value int)))
(-45.7897023657555 -68.0 0.0 -21.4420330485725 -68.0 0.0 14.5912162493923 -68.0 0.0 30.2655976536329 -68.0 0.0)

 

Note this (vlax-safearray-get-u-bound (vlax-variant-value intPoints) 1) will give a number of items in the list less 1 as it starts at 0. 

[dlanorh]

This works but lightly tested

 

(vl-load-com)
(defun makeblock ()
  (entmake (list (cons 0 "BLOCK") (cons 2 "SBblock") (cons 70 0) (list 10 0.0 0.0 0.0)))
  (entmake '((0 . "LWPOLYLINE") (100 . "AcDbEntity") (8 . "0") (100 . "AcDbPolyline") (90 . 2) (70 . 1) (43 . 1.0) (38 . 0.0) (39 . 0.0)
      (10 2.5 0.0) (40 . 1.0) (41 . 1.0) (42 . 1.0) (91 . 0)
      (10 -2.5 0.0) (40 . 1.0) (41 . 1.0) (42 . 1.0) (91 . 0)
      (210 0.0 0.0 1.0)
      )
    )
  (entmake '((0 . "ENDBLK")))
)

(defun rh:sammlung_n (o_lst grp / tmp n_lst)
  (setq n_lst nil)
  (if (= (rem (length o_lst) grp) 0)
	(while o_lst
	  (repeat grp (setq tmp (cons (car o_lst) tmp) o_lst (cdr o_lst)))
	  (setq n_lst (cons (reverse tmp) n_lst) tmp nil)
	);end_while
	(princ "\nModulus Error : The passed list length is not exactly divisible by the group size!!")
  );end_if
  (if n_lst (reverse n_lst))
);end_defun rh:sammlung_n

(defun c:sbx ( / ent ss obj cnt xobj pt_lst)
  (if (null (tblobjname "BLOCK" "SBblock")) (makeblock))

  (setq ent (car (entsel "\nSelect main line: ")))
  (cond (ent
          (prompt "\nSelect crossing line(s): ")
          (setq ss (ssget '((0 . "ARC,CRCLE,ELLIPSE,*LINE,RAY"))))
          (cond (ss
                  (setq obj (vlax-ename->vla-object ent))
                  (repeat (setq cnt (sslength ss))
                    (setq xobj (vlax-ename->vla-object (ssname ss (setq cnt (1- cnt))))
                          pt_lst nil
                          pt_lst (vlax-invoke obj 'intersectwith xobj acExtendNone)      
                    )
                    (cond (pt_lst
                            (setq pt_lst (rh:sammlung_n pt_lst 3))
                            (foreach pt pt_lst
                              (entmake  (append
                                          '((0 . "INSERT") (100 . "AcDbEntity") (8 . "0") (100 . "AcDbBlockReference") (2 . "SBblock"))
                                          (list (cons 10 pt))
                                          '((41 . 1.0) (42 . 1.0) (43 . 1.0) (50 . 0.0) (70 . 0) (71 . 0) (44 . 0.0) (45 . 0.0) (210 0.0 0.0 1.0))
                                        );end_append
                              );end_entmake
                            );end_foreach  
                          )
                    );end_cond
                  )
                )
          );end_cond
        )
  );end_cond        
  (princ)
)

 

The list returned by the intersectwith needed converting into a list of lists

 

(1.0 1.0 0.0 2.0 2.0 0.0) => ((1.0 1.0 0.0) (2.0 2.0 0.0))

[BIGAL]

Dlanorh just a suggestion as you pick the line or pline can use ssget "F" to automatically select the other objects no need to pick them.

 

Please Note Briscad users "F" option will select the "Main" line have reported to Brisys.

 

(setq ent (car (entsel "\nSelect main line: ")))
(setq entnex (entget ent))
(setq lst '())
(setq name (cdr (assoc 0 entnex)))
(cond 
( (= name "LINE") (setq lst (cons (list (cadr (assoc 10 entnex)) (caddr (assoc 10 entnex))) lst))
                  (setq lst (cons (list (cadr (assoc 11 entnex)) (caddr (assoc 11 entnex))) lst))
)
( (= name "LWPOLYLINE") (setq lst (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) entnex))))
)

(setq ss (ssget "F" lst '((0 . "ARC,CRCLE,ELLIPSE,*LINE,RAY"))))
 

[dlanorh]

1 hour ago, BIGAL said:

(setq lst '())

 

 

@BIGAL 

 

one of my pet peeves. What does (listp nil) return.

 

Have a good weekend.

[David Bethel]

 

nil is evaluated as an empty list.

 

This keeps (while) type loops from crashing when encountering an empty list

 

(setq l '(1 2 3 4))

(while l 

  (princ (strcat "\n" (itoa (car l)))

  (setq l (cdr l))

 

 

Some languages define nil as simply not T

 

-David

[BIGAL]

I use the (setq lst '()) to reset it in routines where repeat/while etc are involved probably not needed in code example above. I have not had problems using, if setting to nil is better happy to take that advice.