如何用lisp做一个类似measure命令的程序?

hxfhyn

请指教：如何用lisp做一个类似measure命令的程序呢?如果选择子项B(插入块)，块的插入角度如何计算？

wandong

entget函数返回的表里面有角度，只不过是弧度罢了。

k1nger

(defun C:SPM (/ A AN AN0 BASEPT BETWEEN BOOL CURVEBLOCK CURVELENGTH DISTANC EN FIRSTPOINT LASTB LASTBLIST LASTBLOCK N PP PT PT0 SSADD1 STRIN TRIN VT)
  ;;0 错误处理
  (defun *error* (msg)
    (vl-bt)
    (if *DOC*
      (_EndUndo *DOC*)      ;块内图元增减
    )
    (while (not (equal (getvar "cmdnames") "")) (command nil))
    (princ "\n 出错啦!")
    (princ)
  )
  ;;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 块中有属性，增加值为n
  (defun MyAttAdd (en n / ELIST N1 N3 NEND QIANZ STREND TEXT)
    (setq elist (entget (entnext en)))
    (setq text (cdr (assoc 1 elist)))
    (setq n3 (strlen text))     ;字符串总长
    (setq strEND (getNumberS text))    ;最后的数字
    (setq Nend (nth (1- (length strEND)) strEND))
    (setq n1 (strlen Nend))     ;最后一位数字符串总长
    (setq qianZ (substr text 1 (- n3 n1)))   ;前缀
    (setq strEND (+ (atof (car strEND)) n))   ;未尾数字加n
    (setq strEND (strcat qianZ (rtos strEND 2 3)))
    (entmod (subst (cons 1 strEND) (assoc 1 elist) elist))
    (entupd en)
    ;;(BURST-ONE1 en);爆破属性块
  )
  ;;6 Text，增加值为n
  (defun MyTextAdd (en n / ELIST N1 N3 NEND QIANZ STREND TEXT)
    (setq elist (entget en))
    (setq text (cdr (assoc 1 elist)))
    (setq n3 (strlen text))     ;字符串总长
    (setq strEND (getNumberS text))    ;最后的数字
    (setq Nend (nth (1- (length strEND)) strEND))
    (setq n1 (strlen Nend))     ;最后一位数字符串总长
    (setq qianZ (substr text 1 (- n3 n1)))   ;前缀
    (setq strEND (+ (atof (car strEND)) n))   ;未尾数字加n
    (setq strEND (strcat qianZ (rtos strEND 2 3)))
    (entmod (subst (cons 1 strEND) (assoc 1 elist) elist))
  )
  ;;7  主程序
  (vl-load-com)
  (or *DOC*
      (setq *DOC* (vla-get-ActiveDocument (vlax-get-acad-object)))
  )
  (_StartUndo *DOC*)
  (setvar "nomutt" 1)
  (princ "\n >拾取曲线")
  (while (not
    (and (setq en (ssget ":E:S" '((0 . "*LINE,ARC,ELLIPSE"))))
  (setq en (ssname en 0))
    )
  )
    (princ "\n >重新拾取曲线")
  )
  (setvar "nomutt" 0)
  (setq pt0 (vlax-curve-getClosestPointTo en (cadr (grread T 8))))
  ;;曲线长度
  (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 an0 (entget curveBlock))   ;转角
  (setq basePt (cdr (assoc 10 an0)))
  (setq an0 (cdr (assoc 50 an0)))   ;转角
  ;; 输入块间距  
  (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 (setq n (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))
    (cond ((assoc 66 LastBList) (MyAttAdd LastB (setq n (1- n))))
   ((equal (cdr (assoc 0 LastBList)) "TEXT")
    (MyTextAdd LastB (setq n (1- n)))
   )
    )
    ;;(entmod (subst (cons 50 an) (assoc 50 LastBList) LastBList))
    (command "_.rotate" LastB "" "non" pt (/ (* 180 (- an an0)) pi))
    (setq ssadd1 (ssadd LastB ssadd1))
    (setq firstPoint (+ firstPoint between))
  )
  (if lastblock
    (command "._erase" lastblock "")
    (progn (initget "R  ")
    (setq trin
    (getstring "\n要使块旋转180度,输入R<回车>")
    )
    (if (or (equal trin "R") (equal trin "r"))
      (repeat (setq n (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))
      )
    )
    )
  )
  (_EndUndo *DOC*)
  (princ)
)
(command "_.undo" "be")
(defun _StartUndo (*DOC*)
  (_EndUndo *DOC*)
  (vla-StartUndoMark *DOC*)
)
;;结束编组;
(if (= 8 (logand (getvar "undoctl") 8)) (command "_.undo" "_e"))
(defun _EndUndo (*DOC*)
  (if (= 8 (logand 8 (getvar 'UNDOCTL)))
    (vla-EndUndoMark *DOC*)
  )
)

自贡黄明儒的代码