获取多段线顶点XY座标，并写入到表格

13763815647

flyfox1047 发表于 2014-2-19 09:59
答案是肯定的

顶一个，楼主

y854271613

楼主的技术与胸怀都是
向你致敬

如果当时0809

不错不错，支持一下

cjf160204

(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)
)

cjf160204

自己参照大神代码调整一下

zn1996

好东西  学习一下