超级SuperMeasure

/db_自贡黄明儒_

Me是我工作中常用的一个工具,但使用起来不顺手,于是....

[pcode=lisp,true];;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;超级SuperMeasure
;;;示例：计算多段线en 距离起点20米处的坐标：(vlax-curve-getPointAtDist en 20)
;;;间距between,起始距离distanc,曲线图元en
(defun C:SM (/ AN BASEPT BETWEEN BOOL CURVEBLOCK CURVELENGTH DISTANC EN        ENT FIRSTPOINT
             LASTB LASTBLIST N PP PT PT0 SSADD1        STRIN TRIN VT A        LASTBLOCK
            )

  ;;1  程序开始标记
  (defun UndoBegin ()
    (vla-StartUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
  )
  ;;2  程序结束标记
  (defun UndoEnd ()
    (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
  )
  ;;3  pt0离起点近,返回T
  (defun stratpointT (en pt0 / CURVELENGTH L1)
    (setq CurveLength
           (vlax-curve-getDistAtParam
             en
             (vlax-curve-getEndParam en)
           )
    )
    (setq L1 (vlax-curve-getDistAtPoint en pt0))
    (< L1 (- CurveLength L1))
  )
  ;;4  产生块
  (defun NAME_BLK (CurveLength / A Y)
    (setq A (rtos (* (getvar "CDATE") 1E8)))
    (setq Y (/ CurveLength 5.0))
    (entmake (list '(0 . "LINE") (cons 10 (list 0 0 0)) (cons 11 (list 0 y 0))))
    (command "_.BLOCK" A "non" (list 0 (/ y 2.0) 0) (entlast) "")
    A
  )
  ;;5  主程序
  (vl-load-com)
  (UndoBegin)
  ;;如果图中没有块,不能使用
  (setq        ent
         (MC:ENTSEL1
           "\n .>拾取曲线: "
           '((0 . "*LINE,ARC,ELLIPSE"))
           (list "对象必须是曲线。")
         )
  )

  (setq en (car ent))
  (setq pt0 (vlax-curve-getClosestPointTo en (cadr ent)))
  ;;曲线长度
  (setq        CurveLength
         (vlax-curve-getDistAtParam
           en
           (vlax-curve-getEndParam en)
         )
  )

  (setq        curveBlock
         (car (ENTSEL "\n ..>>拾取沿线的块:"))
  )
  (if curveBlock
    nil
    (progn (setq A (NAME_BLK CurveLength))
           (command "_.INSERT" A "@" "" "" "")
           (setq lastblock (entlast))
           (setq curveBlock lastblock)
    )
  )
  (setq basePt (cdr (assoc 10 (entget curveBlock))))
  ;; 输入块间距  
  (setq bool T)
  (setq strin (strcat "\n ...>>>曲线长度为" (rtos CurveLength 2 3) ",输入块间距: "))
  (while bool
    (initget 7)
    (setq between (getreal strin))
    (if        (> between CurveLength)
      (progn (setq bool T) (alert "块间距必须小于曲线长度!!!"))
      (setq bool nil)
    )
  )
  (initget 4)
  (setq strin (rtos (/ (rem CurveLength between) 2.0) 2 3))
  (setq
    distanc (getreal (strcat "\n ....>>>>第一个块与曲线端点之距离<" strin ">:"))
  )
  (if distanc nil (setq distanc (/ (rem CurveLength between) 2.0)))
  ;;插入块的数量
  (setq n (fix (/ (- CurveLength distanc) between)))
  (if (stratpointT en pt0)
    (setq firstPoint distanc)
    (setq firstPoint (rem (- CurveLength distanc) between))
  )
  (setq ssadd1 (ssadd))

  (repeat (1+ n)
    (setq pt (vlax-curve-getPointAtDist en firstPoint)
          pp (vlax-curve-getParamAtPoint en Pt)                                        ;得到这点参数
          vt (vlax-curve-getFirstDeriv en pp)                                        ;得到切线
          an (angle '(0 0 0) vt)                                                ;切线角
    )
    (command "._copy" curveBlock "" "non" basePt "non" PT)
    (setq LastB (entlast))
    (setq LastBList (entget LastB))
    (entmod (subst (cons 50 an) (assoc 50 LastBList) LastBList))
    (setq ssadd1 (ssadd LastB ssadd1))
    (setq firstPoint (+ firstPoint between))
  )
  (if lastblock
    (command "._erase" lastblock "")
    (progn (setq trin
                  (getstring "\n要使块旋转180度,输入R<回车>")
           )
           (setq n -1)
           (if (or (equal trin "R") (equal trin "r"))
             (repeat (sslength ssadd1)
               (setq LastB (ssname ssadd1 (setq n (1+ n))))
               (setq LastBList (entget LastB))
               (setq an (cdr (assoc 50 LastBList)))
               (setq an (+ an pi))
               (entmod (subst (cons 50 an) (assoc 50 LastBList) LastBList))
             )
           )
    )
  )
  (UndoEnd)
  (princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;超级SuperMeasure[/pcode]

sicky111

超级给力，必须要顶。

非ing

MC:ENTSEL1,这个函数了？

Free-Lancer

更高级的写法就是矩阵了
http://bbs.xdcad.net/thread-667863-1-1.html

NET-JOB

直接改块内图元转角不错，我之前用ROTATE命令，图块多了慢的很，能看到到一个个图块换向

laibinwu

支持源码、

st788796

LZ是VLA，command用全了，从够用角度可以了，从lisper角度还可以优化提高