flyfox1047 发表于 2014-2-19 09:59
答案是肯定的
顶一个，楼主
楼主的技术与胸怀都是
向你致敬
不错不错，支持一下
(defun c:zn (/ 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* prefix)
(vl-load-com)
(defun Extract_DXF_Values (Ent Code)
(mapcar 'cdr (vl-remove-if-not '(lambda (a) (= (car a) Code)) (entget Ent))))
(defun *error* (msg)
(setvar "CMDECHO" 1)
(if oSnp (setvar "OSMODE" oSnp))
(if mSp (vla-EndUndoMark actDoc))
(princ))
(if (and (setq cPl (entsel)) (= "LWPOLYLINE" (car (Extract_DXF_Values (car cPl) 0))))
(progn
(setq tHt (getreal "\n请输入文字高度: "))
(if (not tHt) (setq tHt (getvar "TEXTSIZE")))
(setq prefix (getstring T "\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 "点号") (1 1 "X") (1 2 "Y"))
actDoc (vla-get-ActiveDocument (vlax-get-acad-object))
mSp (vla-get-ModelSpace actDoc))
(vla-StartUndoMark actDoc)
(setvar "CMDECHO" 0)
(setq oSnp (getvar "OSMODE"))
(foreach vert ptLst
(setq vert (trans vert 1 0)
tLst (append tLst (list (list r 0 (strcat prefix (itoa (1+ lCnt)))) (list r 1 (rtos (cadr vert) 2 3)) (list r 2 (rtos (car vert) 2 3)))))
(if (and (/= 0.0 (last vert)) (setq pt1 (vlax-curve-GetPointAtParam vlaPl lCnt)) (setq pt2 (vlax-curve-GetPointAtParam vlaPl (1+ lCnt))))
(progn
(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) 1 0)
tLst (append tLst (list (list r 0 "center") (list r 1 (rtos (cadr pCen) 2 3)) (list r 2 (rtos (car pCen) 2 3)) (list r 3 (rtos cRad 2 3)))))
)
)
(setq r (1+ r) lCnt (1+ lCnt))
)
(setq vlaTab (vla-AddTable mSp (vlax-3D-point '(0 0 0)) (+ 1 (/ (length tLst) 3)) 3 (* 1.6 tHt) (* 13 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)
)
(vla-put-VertCellMargin vlaTab (* 0.35 tHt))
(vla-put-Height vlaTab (* 1.2 (/ (length tLst) 3)))
(vla-SetColumnWidth vlaTab 0 (* 5 tHt))
(vla-DeleteRows vlaTab 0 1)
(princ "\n<<< 请在绘图区选择表格放置位置 >>> ")
(command "_.copybase" (trans '(0 0 0) 1 0) (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)
)
)
(setq lCnt 0)
(foreach v vLst
(if clFlg
(setq cAng (angle cCen (trans v 1 0)) iPt (polar v cAng (* 0.6 tHt)))
(progn
(setq tPt1 (vlax-curve-GetPointAtParam vlaPl (- lCnt 0.0000001)) tPt2 (vlax-curve-GetPointAtParam vlaPl (+ lCnt 0.0000001)) cAng (angle tPt1 (if tPt2 tPt2 (polar tPt1 (* 0.5 pi) 0.0000001))) iPt (polar v (+ (* pi 0.5) (if (minusp cAng) cAng (- cAng))) (* 0.6 tHt)))
)
)
(setvar "OSMODE" 0)
(setq cTxt (vla-AddText mSp (strcat prefix (itoa (1+ lCnt))) (vlax-3d-point iPt) tHt) tiPt (vla-get-InsertionPoint cTxt) lCnt (1+ lCnt))
(vla-put-Alignment cTxt 10)
(vla-put-TextAlignmentPoint cTxt tiPt)
(setq oldCol (getvar "CECOLOR"))
(setvar "CECOLOR" "1")
(command "_.circle" v (/ tHt 15))
(setvar "CECOLOR" oldCol)
)
(setvar "OSMODE" oSnp)
(setvar "CMDECHO" 1)
(vla-EndUndoMark actDoc)
)
(princ "\n<!> 选择的对象不是多段线！程序退出。 <!> ")
)
(gc)
(princ)
)
自己参照大神代码调整一下
好东西学习一下
flyfox1047 发表于 2014-2-19 09:59
答案是肯定的
如果只想要要二维多段线的XY坐标呢，这个是三维的，点选二维多段线提示错误。
感谢大神分享