[编程交流] 弧到弦

(defun c:CurvesToSegments(/ cSet sLen cLen sDis ptLst oOsn
                  eLst cAns vCnt lPt)
 
 (vl-load-com)
 (princ "<<< Select curves to transform >>>")
 (if
   (setq cSet
   (ssget
          '((0 . "*POLYLINE,SPLINE,ARC,CIRCLE,ELLIPSE"))))
   (if(setq sLen(getdist "\nSpecify segment lentgth: "))
     (progn
(setq oOsn(getvar "OSMODE"))
(setvar "CMDECHO" 0)(setvar "OSMODE" 0)
       (foreach itm(setq eLst(vl-remove-if 'listp
                        (mapcar 'cadr(ssnamex cSet))))
(setq sDis 0.0
      cLen(-(vlax-curve-getDistAtParam itm
              (vlax-curve-getEndParam itm))
            (vlax-curve-getDistAtParam itm
              (vlax-curve-getStartParam itm)))
            ); end setq
(if(= "LWPOLYLINE"(cdr(assoc 0(entget itm))))
(progn
  (setq vCnt 1
        ptLst(list(vlax-curve-GetPointAtDist itm sDis)))
   (while(and
           (<= sDis cLen)
           (vlax-curve-GetPointAtParam itm vCnt)
           (setq cPt(vlax-curve-GetPointAtDist itm sDis))
           ); end and
      (if(= 0.0(vla-GetBulge(vlax-ename->vla-object itm)(1- vCnt)))
        (setq ptLst(append ptLst
                  (list(vlax-curve-GetPointAtParam itm vCnt)))
              sDis(vlax-curve-GetDistAtParam itm vCnt)
              ); end setq
        (progn
          (while(<= sDis(vlax-curve-GetDistAtParam itm vCnt))
            (setq cPt(vlax-curve-GetPointAtDist itm sDis)
                  ptLst(append ptLst(list cPt))
                  sDis(+ sDis sLen))
            ); end while
          (setq ptLst(append ptLst
                  (list(vlax-curve-GetPointAtParam itm vCnt))))
          ); end progn
        ); end if
      (setq vCnt(1+ vCnt))
     ); end while
  ); end progn
   (while(and
           (<= sDis cLen)
           (setq cPt(vlax-curve-GetPointAtDist itm sDis))
           ); end and
     (setq ptLst(append ptLst(list cPt))
           sDis(+ sDis sLen))
   ); end while
  ); end if
  (if(not(equal(setq lPt(vlax-curve-getEndPoint itm))(last ptLst)))
    (setq ptLst(append ptLst(list lPt)))
   ); end if
(command "_.pline")(mapcar 'command ptLst)(command "")
(setq ptLst nil)
      ); end foreach
(initget "Yes No")
(setq cAns(getkword "\nRemove old curves [Yes/No] <Yes>: "))
(if(or(null cAns)(= cAns "Yes"))
  (mapcar 'entdel eLst)
  ); end foreach
      (setvar "CMDECHO" 1)(setvar "OSMODE" oOsn)
     ); end progn
    ); end if
   ); end if
 (princ)
 ); end of c:CurvesToSegments