Create Perpendicular Line at every intersection point

[MaxwellEdison]

padding your stats...you should be ashamed...

[CAB]

Who me?

[Lee Mac]

Blimey CAB, no wonder you're so good at LISP - you've had enough practice...

[Lee Mac]

(I like the new sig by the way)

 

Haha thought you might

[priyanka_mehta]

Hi all,

 

Thank you sooooo much.. @Lee,, Yes, Priyanka is very much thankful:D to all of you

 

This was the best forum and probably the best thread i've come across. I do not know lisp at all, VBA i can still manage fairly well but before Seant, I am definetly nothing more than an embryo

 

I dont know i m gettin a lil greedy,, but is there a way to find (ID)coordinates at base point of a block through VBA.Basically in both the projects i m sending everything to Excel sheet for which i m using:

 

Open "C:\\" & "Coordinate_Table" & ".xls" For Output As #1

Print #1, "ID"

Close #1

 

Open "C:\\" & "Coordinate_Table" & ".xls" For Append As #2

 

Print #2, "IDarray"

Close #2

 

For the last project it was fine, since i could find the coordinates b/w intersecting line.. but here its a block which i dont want to explode and still wanna find coordinates at the intersection for a kind of block i had shown in drawing2.dwg.

 

Thank you soooo much once again!!

 

 

Thanks a lot and Best Regards,

Priyanka

[Lee Mac]

This will write Coords to Excel File:

 

(defun c:blkdis    (/ fileo cCurve cBlock index ent dPt1 dPt2)
   (setvar "cmdecho" 0)
   (setq fileo (open (getfiled "Create an Excel File" "C:\\" "csv" 9) "w"))
   (vl-load-com)
   (if    (and (setq cCurve (car (entsel "\nSelect curve to measure > ")))
        (member (cdr (assoc 0 (entget cCurve)))
            '("LINE" "POLYLINE" "LWPOLYLINE" "SPLINE" "ARC" "CIRCLE" "ELLIPSE")))
   (progn
       (write-line "X-Coord,Y-Coord" fileo)
       (setq cBlock (ssget "X" (list (cons 0 "INSERT") (cons 2 "block2")))
         index     (sslength cBlock))
       (while (not (minusp (setq index (1- index))))
       (setq ent  (entget (ssname cBlock index))
             dPt1 (cdr (assoc 10 ent))
             dPt2 (vlax-curve-getClosestPointTo cCurve dPt1))
       (command "_line" dPt1 dPt2 "")
       (write-line (strcat (rtos (car dPt1)) "," (rtos (cadr dPt1))) fileo)))
   (princ "\n<!> Empty selection or this isn't a Curve (line, polyline, etc.) <!> "))
   (close fileo)
   (setvar "cmdecho" 1)
   (princ))

[SEANT]

I’d say 1000+ routines is a lot of coding by anyone’s standards – never mind several thousand. I guess I’ve written several hundred over the years and even with that it feels like I’ve worked my “hunt and peck” fingers to the bone.

 

Certainly the majority of all custom routines are very industry specific, perhaps even specific to a particular company. Presumably, much of it is written by the CAD operator themselves, thus the motivation to save even a couple of mouse clicks justifies another routine. The satisfaction at increasing efficiency via our own diligence is very addictive.

 

Would it be safe to say, however, that the pinnacle for all of us industrious young ACAD coders is a novel new routine with “ExpressTools” type of applicability?

 

Priyanka, the true beauty of this thread is how well it demonstrates the importance of the actual writing of routines while in the process of learning. I suspect there good points to all the routines presented here, but each with aspects that are not quite right. Do what you can to get a routine working like it needs to be. If you run into specific problems, I’m sure the board will do what it can to assist.

[CAB]

Well said Seant.

[Lee Mac]

I second that - nicely put Seant.

[flopo]

Hello Cab,

Can you modify this routine to work with points instead of crosses? Thanks!

 

 

 

 

Lisp is all i know.

This is version 2, still need refinement.

;;  CAB Rev2 01.15.16
;;  Create perp lines from selected crosses to centerline
;;  Crosses & centerline must be line or Lwpolyline objects
;; 
(defun c:CLX (/ ssx ssc lst obj intpts ssxl masterlist clEnt pt px)
 (vl-load-com)
 (prompt "\nSelect the crosses.")
 (setq ssx (ssget '((0 . "LINE,LWPOLYLINE"))))
 (prompt "\nSelect the centerline.")
 (setq ssc (ssget "_+.:E:S" '((0 . "LINE,LWPOLYLINE"))))
 (if (and ssx ssc)
   (progn
     ;;  get cross points
     (setq ssxl (ssget->vla-list ssx))
     (while (setq obj (car ssxl))  ; check each object in ss2brk
       (setq ssxl (cdr ssxl)
             lst  nil)
       ;; check for break pts with other objects in ss2brkwith
       (foreach intobj ssxl
         (if (and (not (equal obj intobj))
                  (setq intpts (get_interpts obj intobj))
                  (= (length intpts) 3) ; allow only one intersect 
             )
           (setq lst (append (list->3pair intpts) lst)) ; entity w/ break points
         )
       )
       (setq ssxl (vl-remove obj ssxl))
       (if (and lst (not (vl-position (car lst) masterlist)))
         (setq masterlist (append masterlist lst))
       )
     )

     (setq clEnts
       (mapcar
         'vlax-vla-object->ename
             (vlax-invoke (vlax-ename->vla-object (ssname ssc 0)) 'Explode))
     )
     
     (if masterlist ; make perp lines
       (progn
         (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
         (vla-StartUndoMark (vla-get-activedocument (vlax-get-acad-object)))
         (foreach pt masterlist
           (if (setq px (getClosestPointTo clEnts pt))
             (entmake (list (cons 0 "LINE")
                            (cons 6 "BYLAYER")
                            ;;(cons 8 "0") 
                            (cons 10 pt)
                            (cons 11 px)
                            ;;(cons 39 0.0) 
                            (cons 62 256)
                            (cons 210 (list 0.0 0.0 1.0))
                      )
             )
           )
         )
         (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
       )
     )
     (mapcar '(lambda (x) (vla-delete (vlax-ename->vla-object x))) clEnts) ; remove the segments
   )
 )

 (princ)
)

;;=====================================
;;  return a list of intersect points  
;;=====================================
(defun get_interpts (obj1 obj2 / iplist)
 (if (not (vl-catch-all-error-p
            (setq iplist (vl-catch-all-apply
                           'vlax-safearray->list
                           (list
                             (vlax-variant-value
                               (vla-intersectwith obj1 obj2 acextendnone)
                             )
                           )
                         )
            )
          )
     )
   iplist
 )
)

(defun ssget->vla-list (ss / i ename allobj) ; this is faster, changed in ver 1.7
 (setq i -1)
 (while (setq ename (ssname ss (setq i (1+ i))))
   (setq allobj (cons (vlax-ename->vla-object ename) allobj))
 )
 allobj
)

;;  return a list of lists grouped by 3 from a flat list
(defun list->3pair (old / new)
 (while (setq new (cons (list (car old) (cadr old) (caddr old)) new)
              old (cdddr old)
        )
 )
 (reverse new)
)


;;  return shortest perpendicular point else closest point to
(defun getClosestPointTo (Ents pt / ent clspt endpts perpts result dist)
 (foreach ent Ents
   (if (or (< (distance (setq clspt (vlax-curve-getclosestpointto ent pt))
                        (vlax-curve-getstartpoint ent)) 0.0001)
           (< (distance clspt (vlax-curve-getendpoint ent)) 0.0001)
       )
     (setq endpts (cons clspt endpts)) ; no perpendicular point
     (setq perpts (cons clspt perpts)) ; else got a perpendicular point
   )
 )
 (cond
   (perpts
    (mapcar '(lambda(x / tmp) (cond
                                ((null dist)(setq dist (distance pt x) result x))
                                ((< (setq tmp (distance pt x)) dist)
                                  (setq dist tmp result x))))
            perpts)
    )
   (endpts
    (mapcar '(lambda(x / tmp) (cond
                                ((null dist)(setq dist (distance pt x) result x))
                                ((< (setq tmp (distance pt x)) dist)
                                  (setq dist tmp result x))))
            endpts)
    )
 )
 result
)