Help with Lisp routine that doesn't work

#1
Hello everyone.
I'm trying to switch to an alternative to Autocad and so far Intellicad seems like one of the best options available.
The fact is that for my work I use a series of lisp routines. Almost all of them work for me but there is one that makes my job a lot easier and I can't get it to work.
What the routine in question does is number all the vertices of a polyline, assign them a number and then generate a table with the coordinates of each vertex.
Can someone tell me what needs to be modified for it to work? Or do you know another similar alternative that works in Intellicad?

Thanks.

P.S. I use Autocad 2008

This is the code:

Code: Select all

(defun c:tabord2(/ aCen cAng cCen cPl cRad cReg
	fDr it lCnt lLst mSp pCen pT1
	pT2 ptLst R tHt tLst vlaPl vlaTab
	vLst cTxt oldCol nPl clFlg actDoc
	tPt1 tPt2 cAng tiPt oSnp *error*)

 (vl-load-com)

 (defun Extract_DXF_Values(Ent Code)
   (mapcar 'cdr
    (vl-remove-if-not
     '(lambda(a)(=(car a)Code))
 (entget Ent)))
   ); end of


   (defun *error*(msg)
     (setvar "CMDECHO" 1)
     (if oSnp(setvar "OSMODE" oSnp))
     (if mSp(vla-EndUndoMark actDoc))
   (princ)
   ); end of *error*

 (if
   (and
     (setq cPl(entsel "\nSelect LwPoliline > "))
     (= "LWPOLYLINE"(car(Extract_DXF_Values(car cPl)0)))
     ); end and
(progn
  (princ "\nPlease Wait... \n")
  (setq vlaPl(vlax-ename->vla-object(car cPl))
	ptLst(mapcar 'append
		       (setq vLst(Extract_DXF_Values(car cPl)10))
		       (mapcar 'list(Extract_DXF_Values(car cPl)42)))
	r 2 lCnt 0
	tLst '((1 0 "Point")(1 1 "X")(1 2 "Y")(1 3 "Radius"))
	actDoc(vla-get-ActiveDocument
	       (vlax-get-acad-object))
	mSp(vla-get-ModelSpace actDoc)
	tHt(getvar "TEXTSIZE")
	    ); end setq
    (vla-StartUndoMark actDoc)
    (setvar "CMDECHO" 0)
    (setq oSnp(getvar "OSMODE"))
    (foreach vert ptLst
      (setq vert(trans vert 0 1)
	    tLst(append tLst
		  (list(list r 0(itoa(1+ lCnt)))
		  (list r 1(rtos(car vert)2 4))
		  (list r 2(rtos(cadr vert)2 4))
		  (list r 3 ""))))
      (if(and
	   (/= 0.0(last vert))
	    (setq pt1(vlax-curve-GetPointAtParam vlaPl lCnt))
	    (setq pt2(vlax-curve-GetPointAtParam vlaPl(1+ lCnt)))
	   ); end and
	(setq r(1+ r)
	      cRad(abs(/(distance pt1 pt2)
		  2(sin(/(* 4(atan(abs(last vert))))2))))
	      aCen(vlax-curve-GetPointAtParam vlaPl(+ 0.5 lCnt))
	      fDr(vlax-curve-getFirstDeriv vlaPl
		   (vlax-curve-getParamAtPoint vlaPl aCen))
	      pCen(trans
		    (polar aCen(-(if(minusp(last vert)) pi(* 2 pi))
		      (atan(/(car fDr)(cadr fDr))))cRad)0 1)
	      tLst(append tLst(list
		    (list r 0 "center")
		    (list r 1(rtos(car pCen)2 4))
		    (list r 2(rtos(cadr pCen)2 4))
		    (list r 3(rtos cRad 2 4))))
	      ); end setq
	); end if
      (setq r(1+ r) lCnt(1+ lCnt))
      ); end foreach
  (setq vlaTab(vla-AddTable mSp (vlax-3D-point '(0 0 0))
		(+ 1(/(length tLst)4)) 4 (* 3 tHt)(* 20 tHt)))
  (foreach i tLst
    (vl-catch-all-apply 'vla-SetText(cons vlaTab i))  
    (vla-SetCellTextHeight vlaTab(car i)(cadr i)tHt)
    (vla-SetCellAlignment vlaTab(car i)(cadr i)acMiddleCenter)
    ); end foreach
  (vla-put-VertCellMargin vlaTab (* 0.75 tHt))
  (vla-put-Height vlaTab(* 1.75(/(length tLst)4)))
  (vla-SetColumnWidth vlaTab 0 (* 10 tHt))
  (vla-SetColumnWidth vlaTab 3 (* 12 tHt))
  (vla-put-RepeatTopLabels vlaTab :vlax-true)
  (vla-put-BreakSpacing vlaTab (* 3 tHt))
  (vla-DeleteRows  vlaTab 0 1)
  (princ "\n<<< Place Table >>> ")
  (command "_.copybase" (trans '(0 0 0)0 1)(entlast) "")
  (command "_.erase" (entlast) "")
  (command "_.pasteclip" pause)
  (if(= :vlax-true(vla-get-Closed vlaPl))
    (progn
     (setq nPl(vla-Copy vlaPl))
     (command "_.region" (entlast) "")
     (setq cCen(vlax-get(setq cReg
	 (vlax-ename->vla-object(entlast)))'Centroid))
      (vla-Delete cReg)
      (setq clFlg T)
     ); end progn
    ); end if
  (setq lCnt 0)
  (foreach v vLst
    (if clFlg
      (setq cAng(angle cCen(trans v 0 1))
            iPt(polar v cAng (* 2 tHt)))
      (setq tPt1(vlax-curve-GetPointAtParam vlaPl
		  (- lCnt 0.0000001))
	    tPt2(vlax-curve-GetPointAtParam vlaPl
		  (+ lCnt 0.0000001))
	    iPt(polar v(+(* pi 0.5)(if(minusp
		(setq cAng(angle tPt1(if tPt2 tPt2
		   (polar tPt1(* 0.5 pi)0.0000001)))))
		cAng(- cAng)))(* 2 tHt))
	    ); end setq
      ); end if
    (setvar "OSMODE" 0)
    (setq cTxt(vla-AddText mSp(itoa(1+ lCnt))
	       (vlax-3d-point iPt) tHt)
	  tiPt(vla-get-InsertionPoint cTxt)
	  lCnt(1+ lCnt)
	  ); end setq
    (vla-put-Alignment cTxt 10)
    (vla-put-TextAlignmentPoint cTxt tiPt)
    (setq oldCol(getvar "CECOLOR"))
    (setvar "CECOLOR" "1")
    (command "_.circle" v (/ tHt 3))
    (setvar "CECOLOR" oldCol)
    ); end foreach
  (setvar "OSMODE" oSnp)
  (setvar "CMDECHO" 1)
  (vla-EndUndoMark actDoc)
  ); end progn
    (princ "\n<!> It isn't LwPolyline! Quit. <!> ")
   ); end if
   (gc)
   (princ)
   ); end of c:tabord2

Re: Help with Lisp routine that doesn't work

#2
Hi,
I'm not sure but it seems the IntelliCAD doesn't fully support Lisp functions for the TABLE object.
Some of the properties need setting in table style command.
Please have a try.

Code: Select all

(defun c:tabord2(/ aCen cAng cCen cPl cRad cReg
	fDr it lCnt lLst mSp pCen pT1
	pT2 ptLst R tHt tLst vlaPl vlaTab ptLst
	vLst cTxt oldCol nPl clFlg actDoc
	tPt1 tPt2 cAng tiPt oSnp *error*)

 (vl-load-com)

 (defun Extract_DXF_Values(Ent Code)
   (mapcar 'cdr
    (vl-remove-if-not
     '(lambda(a)(=(car a)Code))
     (entget Ent)))
   ); end of


 (defun Add_Text(pt size val) 
  (entmake (list '(0 . "TEXT")
                 (cons 10 pt)(cons 40 size) (cons 1 val)
                 (cons 7 (getvar "TEXTSTYLE"))
                 '(71 . 0) '(72 . 1) '(73 . 1) (cons 11 pt))))
  
  (defun *error*(msg)
     (setvar "CMDECHO" 1)
     (if oSnp(setvar "OSMODE" oSnp))
     (if mSp(vla-EndUndoMark actDoc))
    (princ)
   ); end of *error*

 (if
   (and
     (setq cPl(entsel "\nSelect LwPoliline > "))
     (= "LWPOLYLINE"(car(Extract_DXF_Values(car cPl)0)))
     ); end and
(progn
  (princ "\nPlease Wait... \n")
  (setq vlaPl(vlax-ename->vla-object(car cPl))
;;;	ptLst(mapcar 'append
;;;		       (setq vLst(Extract_DXF_Values(car cPl)10))
;;;		       (mapcar 'list(Extract_DXF_Values(car cPl)42)))
	r 2 lCnt 0
	tLst '((1 0 "Point")(1 1 "X")(1 2 "Y")(1 3 "Radius"))
	actDoc(vla-get-ActiveDocument
	       (vlax-get-acad-object))
	mSp(vla-get-ModelSpace actDoc)
	tHt(getvar "TEXTSIZE")
	    ); end setq

  (setq i 0 ptLst (list) vLst (list))
  (while (< i (vlax-curve-getEndParam vlaPl))
      (setq
        pt (vlax-curve-GetPointAtParam vlaPl i)
        bulge (vla-GetBulge vlaPl i)
	row (list (car pt) (cadr pt) bulge)
	vLst (append vLst (list (list (car pt) (cadr pt))))
	ptLst (append ptLst (list row))
	i(1+ i)
	)
    )
  (if (=(vla-Get-Closed vlaPl) :vlax-false)
    (setq
        pt (vlax-curve-GetendPoint vlaPl)
	row (list (car pt) (cadr pt) 0)
	vLst (append vLst (list (list (car pt) (cadr pt))))
	ptLst (append ptLst (list row))
	))
  
    (vla-StartUndoMark actDoc)
    (setvar "CMDECHO" 0)
    (setq oSnp(getvar "OSMODE"))
    (foreach vert ptLst
      (setq vert(trans vert 0 1)
	    tLst(append tLst
		  (list(list r 0(itoa(1+ lCnt)))
		  (list r 1(rtos(car vert)2 4))
		  (list r 2(rtos(cadr vert)2 4))
		  (list r 3 ""))))
      (if(and
	   (/= 0.0(last vert))
	    (setq pt1(vlax-curve-GetPointAtParam vlaPl lCnt))
	    (setq pt2(vlax-curve-GetPointAtParam vlaPl(1+ lCnt)))
	   ); end and
	(setq r(1+ r)
	      cRad(abs(/(distance pt1 pt2)
		  2(sin(/(* 4(atan(abs(last vert))))2))))
	      aCen(vlax-curve-GetPointAtParam vlaPl(+ 0.5 lCnt))
	      fDr(vlax-curve-getFirstDeriv vlaPl
		   (vlax-curve-getParamAtPoint vlaPl aCen))
	      pCen(trans
		    (polar aCen(-(if(minusp(last vert)) pi(* 2 pi))
		      (atan(/(car fDr)(cadr fDr))))cRad)0 1)
	      tLst(append tLst(list
		    (list r 0 "center")
		    (list r 1(rtos(car pCen)2 4))
		    (list r 2(rtos(cadr pCen)2 4))
		    (list r 3(rtos cRad 2 4))))
	      ); end setq
	); end if
      (setq r(1+ r) lCnt(1+ lCnt))
      ); end foreach
  (setq vlaTab(vla-AddTable mSp (vlax-3D-point '(0 0 0))
		(+ 1(/(length tLst)4)) 4 (* 3 tHt)(* 20 tHt)))
  (foreach i tLst
    (vl-catch-all-apply 'vla-SetText(cons vlaTab i))
    ;(vla-SetCellTextHeight vlaTab(car i)(cadr i)tHt)
    ;(vla-SetCellAlignment vlaTab(car i)(cadr i)acMiddleCenter)
    ); end foreach
;;;  (vla-put-VertCellMargin vlaTab (* 0.75 tHt))
;;;  (vla-put-Height vlaTab(* 1.75(/(length tLst)4)))
;;;  (vla-SetColumnWidth vlaTab 0 (* 10 tHt))
;;;  (vla-SetColumnWidth vlaTab 3 (* 12 tHt))
;;;  (vla-put-RepeatTopLabels vlaTab :vlax-true)
;;;  (vla-put-BreakSpacing vlaTab (* 3 tHt))
;;;  (vla-DeleteRows  vlaTab 0 1)
  (princ "\n<<< Place Table >>> ")
  (command "_.copybase" (trans '(0 0 0)0 1)(entlast) "")
  (command "_.erase" (entlast) "")
  (command "_.pasteclip" pause)
  (if(= :vlax-true(vla-get-Closed vlaPl))
    (progn
     (setq nPl(vla-Copy vlaPl))
     (command "_.region" (entlast) "")
     (setq cCen(vlax-get(setq cReg
	 (vlax-ename->vla-object(entlast)))'Centroid))
      (vla-Delete cReg)
      (setq clFlg T)
     ); end progn
    ); end if
  (setq lCnt 0)
  (setvar "OSMODE" 0)
  (setq oldCol(getvar "CECOLOR"))
  (foreach v vLst
    (if clFlg
      (setq cAng(angle cCen(trans v 0 1))
            iPt(polar v cAng (* 2 tHt)))
      (setq tPt1(vlax-curve-GetPointAtParam vlaPl
		  (- lCnt 0.0000001))
	    tPt2(vlax-curve-GetPointAtParam vlaPl
		  (+ lCnt 0.0000001))
	    iPt(polar v(+(* pi 0.5)(if(minusp
		(setq cAng(angle tPt1(if tPt2 tPt2
		   (polar tPt1(* 0.5 pi)0.0000001)))))
		cAng(- cAng)))(* 2 tHt))
	    ); end setq
      ); end if
    
    (Add_Text (list (car ipt) (cadr ipt) 0) tHt (itoa(1+ lCnt)))
    (setq lCnt(1+ lCnt)
	  ); end setq
    (setvar "CECOLOR" "1")
    ;(command "_.circle" v (/ tHt 3))
    (entmake (list (cons 0 "CIRCLE") (cons 10 (list (car v) (cadr v) 0)) (cons 40 (/ tHt 3))))
    (setvar "CECOLOR" oldCol)
    ); end foreach
  (setvar "OSMODE" oSnp)
  (setvar "CMDECHO" 1)
  (vla-EndUndoMark actDoc)
  ); end progn
    (princ "\n<!> It isn't LwPolyline! Quit. <!> ")
   ); end if
   (gc)
   (princ)
   ); end of c:tabord2
Tabord.png
Tabord.png (11.16 KiB) Viewed 521 times