place objects with lisp or vba

[Jack_O'neill]

Hey Guys.

 

Do any of you have a lisp or vba that will do the following:

 

Bear with me, this will take some description. Imagine if you will a rectangle that is 2 1/2 inches wide, and 50 inches tall. Now imagine that there are 10 of these in the same horizontal plain, but spaced irregularly (like fence posts). Now imagine a little diamond shaped symbol (rhombus, for those who prefer technical terms) that is 4 inches tall and 2 inches wide. What I need to do is to copy and place these little symbols next to the rectangles. What I imagine this lisp or vba doing is this. I have the rectangles in place already. Once I determine how far from the bottom of the rectangles I need these symbols, I draw a simple line across all of them. I then start this little program, pick the symbol, then pick the line and it places the diamonds on the outsides of the rectangles with the corner of the diamond touching the intersections of the line and the rectangles. In other words if you look at the attachment, I'd start with the first set, and end up with the second. And if it could erase the line too, that would be great, but not necessary.

 

The location of the vertical rectangles will vary horizontally, as will the vertical position of the rhombus.

 

Anybody got anything that will do this?

 

Thanks guys.

[Lee Mac]

Are the rhombusses/rectangles blocks or polylines?

 

It may be easier if you could post a sample drawing (in 2000 format) of the objects that we have to work with

[Jack_O'neill]

the rhombus is a block, and the rectangles are closed polylines. Well, most of the time. Sometimes they may be individual lines, but they are supposed to be closed polylines. We have some other software that extracts the length of these things for our cnc saw and it only looks for closed polylines on the "0" layer (I know, but I didn't write it). The rhombus is an indicator for the drill operator. His software picks up the location of this thing, and then the drilling machine puts in an assortment of holes or slots based on the location of that little block. When the rectangles are evenly spaced, I just array the blocks, but that's kinda hard to do when they are irregularly spaced.

 

Sample objects have been included.

 

Thanks.

Drawing1.dwg

[Lee Mac]

Give this a test drive:

 

; Diamond ~ by Lee McDonnel [25.01.2009]

; Places a Diamond Block at the Intersection of a LWPolyline

; [Assumes Diamond Block Definition is in Drawing]

(defun c:diamond (/ ss lEnt eLst sLin eLin pvert i int intLst)
 (vl-load-com)
 (if (and (setq ss (ssget '((0 . "LWPOLYLINE"))))
      (setq lEnt (car (entsel "\nSelect Intersecting Line > ")))
      (eq (cdr (assoc 0 (entget lEnt))) "LINE"))
   (progn
     (setq eLst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
       sLin (cdr (assoc 10 (entget lEnt)))
       eLin (cdr (assoc 11 (entget lEnt))))
     (foreach ent eLst
   (setq pVert (mapcar 'cdr (vl-remove-if '(lambda (x) (/= 10 (car x))) (entget ent))))
   (if (eq (setq i (length pVert)) 4)
     (progn
       (while (not (zerop (setq i (1- i))))
         (if (setq int (inters sLin eLin (nth i pVert) (nth (1- i) pVert)))
       (setq intLst (cons int intLst))))
       (setq intLst (vl-sort intLst '(lambda (x1 x2) (< (car x1) (car x2)))))
       (SetBlkTF "3ANSYMB")
       (entmake (list (cons 0 "INSERT") (cons 2 "3ANSYMB") (cons 10 (cadr intLst))))
       (entmake (list (cons 0 "INSERT") (cons 2 "3ANSYMB") (cons 10 (cons (- (caar intLst) 6.5515) (cdar intLst)))))))))
   (princ "\n<!> No Line Selected, or this isn't a Line! <!>"))
 (princ))

(defun SetBlkTF    (n)
   (cond ((not (snvalid n))
      (princ "\nInvalid Block Name - " n)
      (exit))
     ((tblsearch "BLOCK" n)) 
     ((findfile (strcat n ".DWG")) 
      (command "_.INSERT" n) 
      (command))
     (T ; If all else fails....
      (entmake (list (cons 0 "BLOCK") (cons 2 n) (cons 10 (list 0 0 0)) (cons 70 0)))
      (entmake (list (cons 0 "TEXT")
             (cons 1 (strcat "BLOCK PLACECARD - " n))
             (cons 7 (cdr (assoc 2 (tblnext "STYLE" T))))
             (cons 8 "0")
             (cons 10 (list 0 0 0))
             (cons 11 (list 0 0 0))
             (cons 40 (max 1 (getvar "TEXTSIZE")))
             (cons 72 4)))
      (entmake (list (cons 0 "ENDBLK") (cons 8 "0")))))n)

[Lee Mac]

The above should work as per the example drawing you posted.

 

But, as the base point of the diamond is on one side, the placement of the diamond had to be adjusted by a factor of the diamond's width (6.5515), therefore, the above code will not work for all generic "diamond" shapes.

[Jack_O'neill]

Lee, that is very impressive! Thank you very much!

 

I do have one question though. It may be that I'm not doing something correctly. Just for test purposes, I put 4 of the vertical rectangles in the drawing, and drew a line across them. Loaded the code and started it. Here is the command line history:

 

Command: DIAMOND

 

Select objects: Specify opposite corner: 4 found

 

Select objects:

 

Select Intersecting Line >

Command:

 

but it only put the diamonds on the first one on the left. They are in the right place, but it didn't do all four. Am I not picking them correctly? I used a crossing.

 

Again, thanks for your help.

[Lee Mac]

Hmmmm... not sure about that...

 

See video:

Diamond.zip

[Lee Mac]

An updated version to remove the Line:

 

; Diamond ~ by Lee McDonnel [25.01.2009]

; Places a Diamond Block at the Intersection of a LWPolyline

; [Assumes Diamond Block Definition is in Drawing]

; [updated to remove intersecting line]

(defun c:diamond (/ ss lEnt eLst sLin eLin pvert i int intLst)
 (vl-load-com)
 (if (and (setq ss (ssget '((0 . "LWPOLYLINE"))))
      (setq lEnt (car (entsel "\nSelect Intersecting Line > ")))
      (eq (cdr (assoc 0 (entget lEnt))) "LINE"))
   (progn
     (setq eLst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
       sLin (cdr (assoc 10 (entget lEnt)))
       eLin (cdr (assoc 11 (entget lEnt))))
     (foreach ent eLst
   (setq pVert (mapcar 'cdr (vl-remove-if '(lambda (x) (/= 10 (car x))) (entget ent))))
   (if (eq (setq i (length pVert)) 4)
     (progn
       (while (not (zerop (setq i (1- i))))
         (if (setq int (inters sLin eLin (nth i pVert) (nth (1- i) pVert)))
       (setq intLst (cons int intLst))))
       (setq intLst (vl-sort intLst '(lambda (x1 x2) (< (car x1) (car x2)))))
       (SetBlkTF "3ANSYMB")
       (entmake (list (cons 0 "INSERT") (cons 2 "3ANSYMB") (cons 10 (cadr intLst))))
       (entmake (list (cons 0 "INSERT") (cons 2 "3ANSYMB") (cons 10 (cons (- (caar intLst) 6.5515) (cdar intLst))))))))
     (entdel lEnt))
   (princ "\n<!> No Line Selected, or this isn't a Line! <!>"))
 (princ))

(defun SetBlkTF    (n)
   (cond ((not (snvalid n))
      (princ "\nInvalid Block Name - " n)
      (exit))
     ((tblsearch "BLOCK" n)) 
     ((findfile (strcat n ".DWG")) 
      (command "_.INSERT" n) 
      (command))
     (T ; If all else fails....
      (entmake (list (cons 0 "BLOCK") (cons 2 n) (cons 10 (list 0 0 0)) (cons 70 0)))
      (entmake (list (cons 0 "TEXT")
             (cons 1 (strcat "BLOCK PLACECARD - " n))
             (cons 7 (cdr (assoc 2 (tblnext "STYLE" T))))
             (cons 8 "0")
             (cons 10 (list 0 0 0))
             (cons 11 (list 0 0 0))
             (cons 40 (max 1 (getvar "TEXTSIZE")))
             (cons 72 4)))
      (entmake (list (cons 0 "ENDBLK") (cons 8 "0")))))n)

[Jack_O'neill]

that little movie is cool...how did you do that?

 

anyway, i see what might be some of it...you're using 2004, i'm on 2007 here and 2008 at work.

[Lee Mac]

There shouldn't be too much of a difference between the versions - is there an error occuring?

 

As for the video:

 

http://www.microsoft.com/windows/windowsmedia/forpros/encoder/default.mspx

[Jack_O'neill]

that's the problem. I had a 2002 on another machine and it works on it, but not on the 2007 version.

[fixo]

Try another one

First select all of the rectangles or vertical lines,

assumed that all of these objects lies

on layer "0"

Then select the horizontal line

Tested on A2008eng only

Hth

;;hm.lsp
(defun group-by-num (lst num / ls ret)
 (if (= (rem (length lst) num ) 0)
   (progn
     (setq ls nil)
     (repeat (/ (length lst) num)
(repeat num (setq ls 
	    (cons (car lst) ls)
      lst (cdr lst)))
(setq ret (append ret (list (reverse ls)))
      ls nil)))
   )
ret
 )
;;holes markers
(defun C:hm (/ acsp adoc axss bpt cnt en ipt obj oline points ss wid)
 (or adoc
     (setq adoc
     (vla-get-activedocument
       (vlax-get-acad-object)
     )
     )
 )

 (or acsp
     (setq acsp
     (vla-get-block
       (vla-get-activelayout adoc)
     )
     )
 )
 (setq wid 6.5515)
 (if (and (setq ss (ssget '((0 . "LWPOLYLINE,LINE")(8 . "0"))));;select objects on layer "0"
      (setq en (entsel "\nSelect Intersecting Line > ")))
   (progn
     (setq axss (vla-get-activeselectionset adoc)
    oline (vlax-ename->vla-object (car en))
    )
     (vlax-for obj axss
(if (not (vl-catch-all-error-p
	   (setq ipt (vl-catch-all-apply
	     (function (lambda()
		(vlax-invoke obj 'IntersectWith oline acextendnone))))))
	 )
  (if (= (length ipt) 3)
  (setq points (append (list ipt) points))
  (setq points (append (group-by-num ipt 3) points))  
    )))
     (setq points (vl-sort points (function (lambda(a b)(< (car a)(car b))))))
     (setq cnt 1)
     (while (setq ipt (car points))
     (if (= (rem cnt 2) 1)
       (setq ipt (list (- (car ipt) wid)(cadr ipt)(caddr ipt)))
       )
       (setq bpt (cons ipt bpt))
	     (setq points (cdr points))
	      (setq cnt (1+ cnt))
)
 (while (setq ipt (car bpt))
   (vlax-invoke acsp 'InsertBlock ipt "3ANSYMB" 1 1 1 0)
   (setq bpt (cdr bpt))
   )
     )
   )
 (princ)
 )
(vl-load-com)

 

~'J'~

[Lee Mac]

Ahh right - I'm not quite sure why it doesn't work on 07 or 08, but you say it inserts on the first rectangle OK?

[Jack_O'neill]

It doesn't give an error message, it just acts like it thinks it's done.

 

I tried it on another machine with 2002 on it, and it works there. Must be something different between the two versions.

 

Thanks for your help with it...on the right version, that's exactly what I was looking for.

 

I'm gonna try that movie stuff out too. That would be a great training tool.

[Lee Mac]

I'm puzzled now, because I didn't use any ACAD commands in the LISP - so it can't be a difference in the order of command prompts. But then I can't see what else it can be

 

Fixo, any ideas?

[Jack_O'neill]

fixo...your version works on 2007. Thanks!!

[Jack_O'neill]

Lee,

 

yes, your's puts it on the first rectangle on the left perfectly, then the routine ends just as if it finished normally. No error message, doesn't hesitate...it thinks its done. Your's does work correctly on an 2002 machine tho....got to be some difference in the version.

[Lee Mac]

Perhaps Fixo can offer some insight - anyway, glad your problem is sorted now - I bet that'll save you some time!

[fixo]

Perhaps Fixo can offer some insight - anyway, glad your problem is sorted now - I bet that'll save you some time!

Hi mate

Sorry I can't explain you about how

this code works because of my poor

English

I'm just a coder and nothing else

 

~'J'~

[Lee Mac]

Hi mate

Sorry I can't explain you about how

this code works because of my poor

English

I'm just a coder and nothing else

 

~'J'~

 

No Probs, nice code by the way