Bearing Orientation and distance to table

November 23, 2013

Hi i am searching for a bearing and distase lisp but with orientation.

for example

pick the first point (S1), then pick the orientation point (S2) then pick all the other point (1,2,3,4........S3,K3,T3......anything......)

at last pick the table point .....

look at the attach drawing

Thanks

BEARING.dwg

November 24, 2013

any ideas?

November 25, 2013

You need to combine about 4 lisps together, do a search good task to start learning lisp. Search here for as below

1 make a list of points

2 draw lines

3 draw dims

4 draw a table

will post some code when at work

November 25, 2013

Does the program to include placement of Dims and blocks besides inserting the table?

November 25, 2013

only the table (with a text size command if it possible)

November 25, 2013

so create a table from an existing diagram? or the program will start with creating the diagram? or just as you said, only the TABLE?

November 25, 2013

Look the braw bearing.dwg

First of all the lisp route will ask

1) Specify the first point (for our example is S1)

2) Specify the orientation point (for our example is S2)

3)then pick the export points (for our example is 1,2,3,4)

4)Pick a point to insert the table

November 25, 2013

any ideas ?

November 26, 2013

This is not exactly what you want but a quick hack will meet your needs, instead of getting layout details just make a list of selected points saving the angle into list1 and the distance into list2. I need to find some time.

Ps Distance ?

; dwg index to a table
; by Alan H NOV 2013
(defun AH:dwgindex (/ doc objtable ss1 lay ans ans2 plotabs ss1 tag2 tag3 list1 list2 curlayout colwidth numcolumns numrows INC rowheight )
(vl-load-com)
(setq curlayout (getvar "ctab"))
(if (= curlayout "Model")
(progn
(Alert "You need to be in a layout for this option")
(exit)
) ; end progn
) ; end if model
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(setq curspace (vla-get-paperspace doc))
(setq pt1 (vlax-3d-point (getpoint "\nPick point for top left hand of table:  "))) 
;(setq pt1 (vlax-3d-point '(0 0 0))) 
; for testing
; read values from title blocks
;(setq bname "DA1DRTXT")
(setq bname "COGG_TITLE")
(setq tag2 "DRG_NO") ;attribute tag name
(setq tag3 "WORKS_DESCRIPTION") ;attribute tag name
(setq ss1 (ssget "x"  (list (cons 0 "INSERT") (cons 2 bname))))
(setq INC (sslength ss1))  
(repeat INC
(foreach att (vlax-invoke (vlax-ename->vla-object (ssname SS1 (SETQ INC (- INC 1)) )) 'getattributes) 
       (if (= tag2 (strcase (vla-get-tagstring att)))
           (progn
           (setq ans (vla-get-textstring att))
           (if (/= ans NIL)
           (setq list1 (cons ans list1))
           ) ; if 
           ); end progn
         ) ; end if
       (if (= tag3 (strcase (vla-get-tagstring att)))
         (progn
         (setq ans2 (vla-get-textstring att))
         (if (/= ans2 NIL)
             (setq list2 (cons ans2 list2)) 
          ) ; end if
          ) ; end progn
 ) ; end if tag3 

) ; end foreach
) ; end repeat
(setvar 'ctab curlayout)
(command "Zoom" "E")
(command "regen")

(reverse list1)
;(reverse list2)
; now do table 
(setq numrows (+ 2 (sslength ss1)))
(setq numcolumns 2)
(setq rowheight 0.2)
(setq colwidth 130)
(setq objtable (vla-addtable curspace pt1 numrows numcolumns rowheight colwidth))
(vla-settext objtable 0 0 "DRAWING REGISTER")
(vla-settext objtable 1 0 "DRAWING NUMBER") 
(vla-settext objtable 1 1 "DRAWING TITLE") 
(SETQ X 0)
(SETQ Y 2)
(REPEAT (sslength ss1)
 (vla-settext objtable Y 0 (NTH X LIST1))
 (vla-settext objtable Y 1 (NTH X LIST2))
 (vla-setrowheight objtable y 10)
 (SETQ X (+ X 1))
 (SETQ Y (+ Y 1))
)
(vla-setcolumnwidth objtable 0 55)
(vla-setcolumnwidth objtable 1 130)
(command "_zoom" "e")
); end AH defun
(AH:dwgindex)
(princ)

November 26, 2013

Hi BIGAL. Thank you for the reply. This lisp work only on the Layout and makes only a square. I work only in Model space ..........

November 27, 2013

Ok you want the opposite of these code bits as below

(setq curlayout (getvar "ctab"))
(if (= curlayout "Model")
(progn
(princ) ; dummy for else
(Alert "You need to be in model space for this option")
(exit)

; same with this
(setq curspace (vla-get-modelspace doc))

November 27, 2013

I do the changes but is not working ?

; dwg index to a table
; by Alan H NOV 2013
(defun AH:dwgindex (/ doc objtable ss1 lay ans ans2 plotabs ss1 tag2 tag3 list1 list2 curlayout colwidth numcolumns numrows INC rowheight )
(vl-load-com)
(setq curlayout (getvar "ctab"))
(if (= curlayout "Model")
(progn
(princ) ; dummy for else
(Alert "You need to be in model space for this option")
(exit)
) ; end progn
) ; end if model
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
; same with this
(setq curspace (vla-get-modelspace doc))
(setq pt1 (vlax-3d-point (getpoint "\nPick point for top left hand of table:  "))) 
;(setq pt1 (vlax-3d-point '(0 0 0))) 
; for testing
; read values from title blocks
;(setq bname "DA1DRTXT")
(setq bname "COGG_TITLE")
(setq tag2 "DRG_NO") ;attribute tag name
(setq tag3 "WORKS_DESCRIPTION") ;attribute tag name
(setq ss1 (ssget "x"  (list (cons 0 "INSERT") (cons 2 bname))))
(setq INC (sslength ss1))  
(repeat INC
(foreach att (vlax-invoke (vlax-ename->vla-object (ssname SS1 (SETQ INC (- INC 1)) )) 'getattributes) 
       (if (= tag2 (strcase (vla-get-tagstring att)))
           (progn
           (setq ans (vla-get-textstring att))
           (if (/= ans NIL)
           (setq list1 (cons ans list1))
           ) ; if 
           ); end progn
         ) ; end if
       (if (= tag3 (strcase (vla-get-tagstring att)))
         (progn
         (setq ans2 (vla-get-textstring att))
         (if (/= ans2 NIL)
             (setq list2 (cons ans2 list2)) 
          ) ; end if
          ) ; end progn
 ) ; end if tag3 

) ; end foreach
) ; end repeat
(setvar 'ctab curlayout)
(command "Zoom" "E")
(command "regen")

(reverse list1)
;(reverse list2)
; now do table 
(setq numrows (+ 2 (sslength ss1)))
(setq numcolumns 2)
(setq rowheight 0.2)
(setq colwidth 130)
(setq objtable (vla-addtable curspace pt1 numrows numcolumns rowheight colwidth))
(vla-settext objtable 0 0 "DRAWING REGISTER")
(vla-settext objtable 1 0 "DRAWING NUMBER") 
(vla-settext objtable 1 1 "DRAWING TITLE") 
(SETQ X 0)
(SETQ Y 2)
(REPEAT (sslength ss1)
 (vla-settext objtable Y 0 (NTH X LIST1))
 (vla-settext objtable Y 1 (NTH X LIST2))
 (vla-setrowheight objtable y 10)
 (SETQ X (+ X 1))
 (SETQ Y (+ Y 1))
)
(vla-setcolumnwidth objtable 0 55)
(vla-setcolumnwidth objtable 1 130)
(command "_zoom" "e")
); end AH defun
(AH:dwgindex)
(princ)

November 28, 2013

The example I posted was to just show the method of how to do something like what you want not actually an exact solution to your request the code has to be changed.

CADTUTOR is not a freebie site for anybody to go to and get a purpose written soloution. If I can find time I will change the code.

You have posted multiple times so its probably time you started to have a go at writing some lisps there are heaps of people here who can help and are more than willing to help those who help themselves.

November 29, 2013

For fun

(Defun c:DiaTabs ;|<--- haha |; ( / _Insert _AttFunc cnt data  p1 p2 p1l p2l p3 ip data num)
 (vl-load-com)
(defun _insert (sp bname p)(vlax-invoke space 'InsertBlock p bname 1 1 1 0))
 
(defun _AttFunc  (en lst / vals v)
(mapcar (function (lambda (at)
(setq vals (list (vla-get-tagstring at)(vla-get-textstring at)))
         	(if (and lst (setq v (assoc (car vals) lst)))
                 	(vla-put-textstring at (cadr v))) vals))
                     (vlax-invoke (if (eq (type en) 'VLA-OBJECT)
                                 en (vlax-ename->vla-object en)) 'Getattributes)
 	)
 )  
(if (not (member "geomcal.arx" (arx)))
   (arxload "geomcal")
   )
(setq ADoc (vla-get-activedocument (vlax-get-acad-object))
   Space (if (= (getvar "CVPORT") 1)
             (vla-get-PaperSpace ADoc)
             (vla-get-ModelSpace ADoc)
         ))

                                 
      
(setq cnt -1 num 0)  
(if (and (vl-every '(lambda (b)
     (setq cnt (1+ cnt))		 
     (tblsearch "BLOCK" b)) (setq blks '("STATION" "POINT" "TITLE" "DATA")))
(setq p1 (getpoint "\nPick Base Referene point: "))
(setq p2 (getpoint p1 "\nPick Second point: "))
(setq p1l (getstring "\nEnter Label of BP: "))
(setq p2l (getstring "\nEnter Label of SP: "))
 )
 	(progn
  (setq angs (If (> (car p1)(car p2))
		    "ang(p1,p3,p2)" "ang(p1,p2,p3)"))
     (setq  data nil)
  	(vlax-invoke space 'AddLine p1 p2)
  	(_AttFunc (_Insert space "STATION" p1 ) (list (list "POINT" (strcase p1l))));<-- Optional
  	(_AttFunc (_Insert space "STATION" p2 ) (list (list "POINT" (strcase p2l))));<-- Optional
	(while (setq p3 (getpoint p1 (strcat "\nPick point " (itoa (setq num (1+ num)))":")))
;;;		Place here DimeAng line <Optional>		;;;
;;;								;;;
	(entmakex (list (cons 0 "LINE")'(6 . "HIDDEN2")'(8 . "Distance")
                 (cons 10 p1) (cons 11 p3)))
	  (_AttFunc (_Insert space "POINT" p3 ) (list (list "POINT" (itoa num))))
	(setq data (cons (list
			   (itoa num)
			   (Strcat
			     (rtos
			       (cvunit (c:cal angs)
				       "degree" "grad") 2 4)
			     "g"
			   )
			   (rtos (distance p1 p3) 2 2)
			 ) data))
	  )
  	(setq ip (getpoint  "\nPick Base point for Table: "))
  	(_AttFunc (_Insert space "TITLE" ip )
		  (list (list "TITLE" (strcat "FROM " (strcase p1l) " -> " (strcase p2l)))))
  (foreach itm (reverse data)
	(_AttFunc (_Insert space "DATA" ip )
		  (list (list "NUM" (car itm))
			(list "BEARING" (cadr itm))
			(list "DISTANCE" (last itm))))
    	(setq ip (polar ip (* pi 1.5) 1.0)))
 )
  (princ (strcat "\n<<<Block " (nth cnt blks) " Not Found>>>"))
 )
(princ)
)

BEARING.dwg

November 29, 2013

Thank you pBe for the code.

Can you make a little change. I don't want to insert again the blocks. If it possible to read automatically the name of each block i pick or to give manually the name of the pick point every time. And the table block to be attached with the lisp , if it's possible

November 30, 2013

Thank you pBe for the code.
Can you make a little change. I don't want to insert again the blocks.

Sure i can make changes, but not so little really,

I don't want to insert again the blocks. If it possible to read automatically the name of each block i pick or to give manually the name of the pick point every time.

Its one or the other prodromosm, i prefer the latter

And the table block to be attached with the lisp , if it's possible

You mean use a ACAD Table instead of a attribute block? i would stick with attribute blocks.

(Defun c:DiaTabs ;|<--- haha |; ( / _Insert _AttFunc _getprop cnt data space ob1 ob2 ob3  p1 p2 p3 ip  num)
(vl-load-com)
(defun _insert (sp bname p)(vlax-invoke space 'InsertBlock p bname 1 1 1 0))
(defun _AttFunc  (en lst / vals v)
(mapcar (function (lambda (at)
(setq vals (list (vla-get-tagstring at)(vla-get-textstring at)))
         	(if (and lst (setq v (assoc (car vals) lst)))
                 	(vla-put-textstring at (cadr v))) vals))
                     (vlax-invoke (if (eq (type en) 'VLA-OBJECT)
                                 en (vlax-ename->vla-object en)) 'Getattributes)
 	)
 )
(defun _getprop	(msg bn tg )
 (prompt msg)
 (if (setq
s (ssget "_:S:L" (list '(0 . "INSERT") '(66 . 1) (cons 2 bn)))
     )
   (setq att (_AttFunc (ssname s 0) nil)
  ip (cdr (assoc 10 (entget (ssname s 0)))))
  (progn (princ "\n<<Invlaid Seletion>>") (_getprop msg bn tg))
   )
 (list ip (assoc tg att) )
)  (if (not (member "geomcal.arx" (arx)))
   (arxload "geomcal")
   )
(setq ADoc (vla-get-activedocument (vlax-get-acad-object))
   Space (if (= (getvar "CVPORT") 1)
             (vla-get-PaperSpace ADoc)
             (vla-get-ModelSpace ADoc)
         ))
(setq cnt -1 num 1)  
(if (vl-every '(lambda (b)
     (setq cnt (1+ cnt))		 
     (tblsearch "BLOCK" b)) (setq blks '("STATION" "POINT" "TITLE" "DATA")))
(progn
 	(setq ob1 (_GETPROP "\nPick Base Referene point: " "STATION" "POINT" ))
(setq ob2 (_GETPROP "\nPick Second point: " "STATION" "POINT" ))
  (setq p1 (Car ob1) p2 (car ob2))
  (setq angs (If (> (car p1)(car p2))
		    "ang(p1,p3,p2)" "ang(p1,p2,p3)"))
     (setq  data nil)
	(while  (setq p3 (getpoint p1 (strcat "\nPick point " (itoa num)":")))
	  	(if (and (cadr (sssetfirst nil  (ssget  "_C" p3 p3 '((2 . "POINT")))))
		         (setq ob3 (_GETPROP (strcat "\nPick point " (itoa num)":")
				    "POINT" "POINT" )))
		  (progn (setq p3 (car ob3))
			(setq data (cons (list
			   (itoa num)
			   (Strcat
			     (rtos
			       (cvunit (c:cal angs)
				       "degree" "grad") 2 4)
			     "g"
			   )
			   (rtos (distance p1 p3) 2 2)
			 ) data))
	  		(setq num (1+ num))
	  		)
		  (princ "\nBlock \"POINT\" Not found"))
	  )
  
  	(setq ip (getpoint  "\nPick Base point for Table: "))
  	(_AttFunc (_Insert space "TITLE" ip )
		  (list (list "TITLE" (strcat "FROM " (strcase (cadadr ob1)) " -> " (strcase (cadadr ob2))))))
  (foreach itm (reverse data)
	(_AttFunc (_Insert space "DATA" ip )
		  (list (list "NUM" (car itm))
			(list "BEARING" (cadr itm))
			(list "DISTANCE" (last itm))))
    	(setq ip (polar ip (* pi 1.5) 1.0)))
 )
  (princ (strcat "\n<<<Block " (nth cnt blks) " Not Found>>>"))
 )
(princ)
)

November 30, 2013

Hi pBe thank you for the code but i still need a little changes , if you can

1) I want the DiaTabs.dwg to insert automatically when i "Pick Base point for Table:"

2) with the same way i "Pick Base Referene point: " and sellect the block and write the text of the block ,with the same way when i select the block of the text writes the name of the text. Because there are cases where the item numbers are not in the order (1, 2,3,4,5 ...... 100 etc) but random (50, 48,32,60,72,34,15. 22 ...... etc)

DiaTabs.dwg

Edited November 30, 2013 by prodromosm

December 2, 2013

I try this but i have a litle bug ....

and i still have this problem

2) with the same way i "Pick Base Referene point: " and sellect the block and write the text of the block ,with the same way when i select the block of the text writes the name of the text. Because there are cases where the item numbers are not in the order (1, 2,3,4,5 ...... 100 etc) but random (50, 48,32,60,72,34,15. 22 ...... etc)

(Defun c:DiaTabs ;|<--- haha |; ( / _Insert _AttFunc _getprop cnt data space ob1 ob2 ob3  p1 p2 p3 ip  num scl)
(vl-load-com)
(defun _insert (sp bname p)(vlax-invoke space 'InsertBlock p bname 1 1 1 0))
(defun _AttFunc  (en lst / vals v)
(mapcar (function (lambda (at)
(setq vals (list (vla-get-tagstring at)(vla-get-textstring at)))
         	(if (and lst (setq v (assoc (car vals) lst)))
                 	(vla-put-textstring at (cadr v))) vals))
                     (vlax-invoke (if (eq (type en) 'VLA-OBJECT)
                                 en (vlax-ename->vla-object en)) 'Getattributes)
 	)
 )
(defun _getprop	(msg bn tg )
 (prompt msg)
 (if (setq
s (ssget "_:S:L" (list '(0 . "INSERT") '(66 . 1) (cons 2 bn)))
     )
   (setq att (_AttFunc (ssname s 0) nil)
  ip (cdr (assoc 10 (entget (ssname s 0)))))
  (progn (princ "\n<<Invlaid Seletion>>") (_getprop msg bn tg))
   )
 (list ip (assoc tg att) )
)  (if (not (member "geomcal.arx" (arx)))
   (arxload "geomcal")
   )
(setq ADoc (vla-get-activedocument (vlax-get-acad-object))
   Space (if (= (getvar "CVPORT") 1)
             (vla-get-PaperSpace ADoc)
             (vla-get-ModelSpace ADoc)
         ))
(setq cnt -1 num 1)  
(if (vl-every '(lambda (b)
     (setq cnt (1+ cnt))		 
     (tblsearch "BLOCK" b)) (setq blks '("STATION" "POINT")))
(progn
 	(setq ob1 (_GETPROP "\nPick Base Referene point: " "STATION" "POINT" ))
(setq ob2 (_GETPROP "\nPick Second point: " "STATION" "POINT" ))
  (setq p1 (Car ob1) p2 (car ob2))
  (setq angs (If (> (car p1)(car p2))
		    "ang(p1,p3,p2)" "ang(p1,p2,p3)"))
     (setq  data nil)
	(while  (setq p3 (getpoint p1 (strcat "\nPick point " (itoa num)":")))
	  	(if (and (cadr (sssetfirst nil  (ssget  "_C" p3 p3 '((2 . "POINT")))))
		         (setq ob3 (_GETPROP (strcat "\nPick point " (itoa num)":")
				    "POINT" "POINT" )))
		  (progn (setq p3 (car ob3))
			(setq data (cons (list
			   (itoa num)
			   (Strcat
			     (rtos
			       (cvunit (c:cal angs)
				       "degree" "grad") 2 4)
			     "g"
			   )
			   (rtos (distance p1 p3) 2 2)
			 ) data))
	  		(setq num (1+ num))
	  		)
		  (princ "\nBlock \"POINT\" Not found"))
	  )
  
  	(setq ip (getpoint  "\nPick Base point for Table: "))
	(setq scl (getvar "dimscale"))
	(command"insert"  "DiaTabs" ip scl scl pause val)
  	(_AttFunc (_Insert space "TITLE" ip )
		  (list (list "TITLE" (strcat "FROM " (strcase (cadadr ob1)) " -> " (strcase (cadadr ob2))))))
  (foreach itm (reverse data)
	(_AttFunc (_Insert space "DATA" ip )
		  (list (list "NUM" (car itm))
			(list "BEARING" (cadr itm))
			(list "DISTANCE" (last itm))))
    	(setq ip (polar ip (* pi 1.5) 1.0)))
 )
  (princ (strcat "\n<<<Block " (nth cnt blks) " Not Found>>>"))
 )
(princ)
)

DiaTabs.dwg

December 2, 2013

any ideas?

December 3, 2013

any ideas?

Ideas, a lot!!

Time, not so much.

Patience [rapidly running out...]

[Refer to post # 13]

Sign In

Bearing Orientation and distance to table

Recommended Posts

Guest

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Guest

BIGAL

pBe

Guest

pBe

Guest

Guest

BIGAL

Guest

BIGAL

Guest

BIGAL

pBe

Guest

pBe

Guest

Guest

Guest

pBe

Join the conversation

Tutorials

Forums

Activity