超级SuperMeasure(更新到2014年2月12日)

自贡黄明儒 · 发表于 2013-5-7 11:32:56

本帖最后由自贡黄明儒于 2015-3-24 13:08 编辑

Me是我工作中常用的一个工具，但使用起来很麻烦，于是动手.....自贡黄明儒 2013年5月7日
以前写过这个程序，经不断实战，现在觉得完善了，所以重发

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;超级SuperMeasure
(defun C:SM (/ 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)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;超级SuperMeasure 
(defun C:SM (/ 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*)
  )
)

由于点这个的比较多，故更新到文件2014年2月

594826903 · 发表于 2019-12-26 13:29:08

命令: ARR 反向跟踪:
[0.51] (VL-BT)
[1.47] (*ERROR* "no function definition: _STARTUNDO")
[2.42] (_call-err-hook #<SUBR @00000000422d17c8 *ERROR*> "no function definition: _STARTUNDO")
[3.36] (sys-error "no function definition: _STARTUNDO")
:ERROR-BREAK.31 nil
[4.28] (#<SUBR @00000000360d8bb0 null-fun-hk> #<VLA-OBJECT IAcadDocument 000000002c780fc8>)
[5.24] (_STARTUNDO #<VLA-OBJECT IAcadDocument 000000002c780fc8>)
[6.19] (C:ARR)
[7.15] (#<SUBR @00000000422d1cc8 -rts_top->)
[8.12] (#<SUBR @00000000360d8700 veval-str-body> "(C:ARR)" T #<FILE internal>)
:CALLBACK-ENTRY.6 (:CALLBACK-ENTRY)
:ARQ-SUBR-CALLBACK.3 (nil 0)
无函数定义: _ENDUNDO

moranyuyan · 发表于 2024-5-27 16:05:03

命令: sm
反向跟踪:
[0.51] (VL-BT)
[1.47] (*ERROR* "no function definition: _STARTUNDO")
[2.42] (_call-err-hook #<SUBR @00000142eb2e58b8 *ERROR*> "no function definition: _STARTUNDO")
[3.36] (sys-error "no function definition: _STARTUNDO")
:ERROR-BREAK.31 nil
[4.28] (#<SUBR @00000142e8b38b88 null-fun-hk> #<VLA-OBJECT IAcadDocument 00000142bfc724d8>)
[5.24] (_STARTUNDO #<VLA-OBJECT IAcadDocument 00000142bfc724d8>)
[6.19] (C:SM)
[7.15] (#<SUBR @00000142eaeb2818 -rts_top->)
[8.12] (#<SUBR @00000142e8b38700 veval-str-body> "(C:SM)" T #<FILE internal>)
:CALLBACK-ENTRY.6 (:CALLBACK-ENTRY)
:ARQ-SUBR-CALLBACK.3 (nil 0)
无函数定义: _ENDUNDO

999999 · 发表于 2024-7-31 06:52:13

大神您好，请问这个可以加一个记忆功能吗，记忆块名，和间距的数值

dwg001 · 发表于 2013-5-7 11:49:06

不错，顶一个。

USER2128 · 发表于 2013-5-7 13:47:55

黄大侠的又一力作，我顶黄大侠

zhuquanmao · 发表于 2013-5-7 15:26:47

no function definition: MC:ENTSEL1

cuyongping · 发表于 2013-5-7 15:41:49

呵呵！用用试试看！

cuyongping · 发表于 2013-5-7 15:46:41

no function definition: MC:ENTSEL1

fan_zh · 发表于 2013-7-23 16:24:41

mj0000 · 发表于 2013-9-11 17:38:35

不错，收藏了

yzr2002626 · 发表于 2013-9-12 10:00:09

不错，顶一个

yoyoho · 发表于 2013-9-12 17:03:04

让我学习一下!

账号		自动登录	找回密码
密码			注册

[源码] 超级SuperMeasure(更新到2014年2月12日)

本帖子中包含更多资源

点评

本帖被以下淘专辑推荐:

点评

点评