表中的可选列
这段聪明的代码是由ASMI编写的，它在选取一条pline后生成一个坐标表打开或关闭。我想稍微修改一下，所以有一个选项
显示或不显示显示“Radius”的最后一列
因此，用户将有3列或4列。有人能看一下吗？
谢谢
(defun c:tabord(/ 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 *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)
(princ)
); end of *error*
(if
(and
(setq cPl(entsel "\nSelect LwPoliline > "))
(= "LWPOLYLINE"(car(Extract_DXF_Values(car cPl)0)))
); end and
(progn
(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)))
lLst '("A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M"
"N" "O" "P" "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z")
r 2 lCnt 0
tLst '((1 0 "Point")(1 1 "X")(1 2 "Y")(1 3 "Radius"))
mSp(vla-get-ModelSpace
(vla-get-ActiveDocument
(vlax-get-acad-object)))
tHt(getvar "TEXTSIZE")
); end setq
(setvar "CMDECHO" 0)
(foreach vert ptLst
(setq vert(trans vert 0 1)
tLst(append tLst
(list(list r 0 (nth lCnt lLst))
(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)(* 18 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-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 fDr(vlax-curve-getFirstDeriv vlaPl
(vlax-curve-getParamAtPoint vlaPl v))
iPt(trans
(polar v(-(* 2 pi)(atan(/(car fDr)(cadr fDr))))
(* 2 tHt))0 1)
); end if
); end if
(setq cTxt(vla-AddText mSp(nth lCnt lLst)
(vlax-3d-point iPt) tHt)
lCnt(1+ lCnt)
); end setq
(setq oldCol(getvar "CECOLOR"))
(setvar "CECOLOR" "1")
(command "_.circle" v (/ tHt 3))
(setvar "CECOLOR" oldCol)
); end foreach
(setvar "CMDECHO" 1)
); end progn
(princ "\n<!> It isn't LwPolyline! Quit. <!> ")
); end if
(princ)
); end of c:tabord 别介意，伙计们，我自己已经解决了。。。。 你能给我们展示一下你的“调整过的”lisp程序吗？
页:
[1]