大师们帮我看看这个代码问题在哪里？

lucas3

原贴在：http://bbs.mjtd.com/forum.php?mod=viewthread&tid=91590&extra=page%3D1%26filter%3Dtypeid%26typeid%3D114

(defun c:DTM(/ os olderr scl obj ename edata ename0 edata0 ename1 edata1 ename2 edata2)
  (vl-load-com)
  
  (defun dtmerr(msg)
    (command "undo" "e")
    (setvar "osmode" os)
    (if ename0 (entdel ename0))
    (if ename1 (entdel ename1))
    (if ename2 (entdel ename2))
    (setq *error* olderr)
  )
  (defun createdatum(/ blk)
    (setq ename0 nil)
    (setq ename1 nil)
    (setq ename2 nil)
    (if (setq obj (nentsel))
      (progn
        (setq spnt (cadr obj))
        (setq obj (vlax-ename->vla-object (car obj)))
        (entmake (list '(0 . "BLOCK")(cons 2 "*U")'(70 . 1)'(10 0.0 0.0 0.0)))
        (entmake (list '(0 . "TEXT")'(10 0.0 0.0 0.0)'(11 0.0 0.0 0.0)'(8 . "DIM")'(40 . 3.5)'(62 . 3)'(72 . 4)'(1 . "")))
        (entmake (list '(0 . "CIRCLE")'(8 . "DIM")'(10 0.0 0.0 0.0)'(40 . 3.5)))
        (setq blk (entmake '((0 . "ENDBLK"))))
        (entmake (list '(0 . "INSERT")'(10 0.0 0.0 0.0)(cons 41 scl)(cons 42 scl)(cons 2 blk)))
        (setq ename0 (entlast))
        (setq edata0 (entget ename0))
        (setq ename (entnext (tblobjname "BLOCK" blk)))
        (setq edata (entget ename))
        (entmake (list '(0 . "LINE")'(8 . "DIM")'(10 0.0 1.6 0.0)'(11 0.0 6.5 0.0)))
        (setq ename1 (entlast))
        (setq edata1 (entget ename1))
        (entmake (list '(0 . "LWPOLYLINE")'(8 . "DIM")'(100 . "AcDbEntity")'(100 . "AcDbPolyline")'(90 . 2)'(43 . 0.4)'(10 3.5 1.6 0.0)'(10 -3.5 1.6 0.0)))
        (setq ename2 (entlast))
        (setq edata2 (entget ename2))
      )
    )
  )
  
  (defun do_move(/ mpos npnt ang spnt epnt pnt0 pnt1)
    (setq mpos (cadr code))
    (setq npnt (vlax-curve-getClosestPointTo obj mpos T))
    
    (setq ang (angle npnt mpos))
    (if (< (distance mpos npnt) (* scl 10.0)) (setq mpos (polar npnt (angle npnt mpos) (* scl 10.0))))
    (setq edata0 (subst (cons 10 mpos) (assoc 10 edata0) edata0))
    (setq spnt (polar npnt ang (* scl 1.6)))
    (setq epnt (polar npnt ang (- (distance mpos npnt)(* scl 3.5))))
    (setq edata1 (subst (cons 10 spnt) (assoc 10 edata1) edata1))
    (setq edata1 (subst (cons 11 epnt) (assoc 11 edata1) edata1))
    (setq pnt0 (polar spnt (+ ang (/ pi 2.0)) (* scl 3.5)))
    (setq pnt1 (polar spnt (- ang (/ pi 2.0)) (* scl 3.5)))
    (setq edata2 (subst (cons 10 pnt0) (assoc 10 edata2) edata2))
    (setq edata2 (subst (cons 10 pnt1) (nth 4 (member (assoc 10 edata2) edata2)) edata2))
    (entmod edata0)
    (entmod edata1)
    (entmod edata2)
    (entupd ename0)
    (entupd ename1)
    (entupd ename2)
  )
  (defun do_datum (/ ref string)
    (setq ref (cadr code))
    (if (or (<= 65 ref 90) (<= 97 ref 122))
      (progn
        (setq string (strcase (chr ref)))
        (setq edata (subst (cons 1 string)(assoc 1 edata) edata))
        (entmod edata)
        (entupd ename)
      )
    )
  )
  (setvar "cmdecho" 0)
  (setq os (getvar "osmode"))
  (setvar "osmode" 0)
  (command "undo" "be")
  (setq olderr *error*)
  (setq *error* dtmerr)
  (setq scl (getvar "dimscale"))
  
  (prompt "Please select object:\n")
  (createdatum)
  (setq loop T)
  (while (and obj loop)
    (setq code (grread T 8))
    (cond
      ((= (car code) 5)(do_move))                                ;;;move
      ((= (car code) 3)(createdatum))                            ;;;left-right
      ((or (= (car code) 11)(= (car code) 25))(setq loop nil))   ;;;button-right
      ((= (car code) 2)(do_datum))                               ;;;datum
    )
  )
  
  (command "undo" "e")
  (setvar "osmode" os)
  (setq *error* olderr)
  (princ)
)

可不知道为什么，有时候标出来是这样的
原帖楼层中也有反映这个问题

newer

代码呢？

lucas3

newer 发表于 2016-11-5 15:52

N版，已经放上，手机发帖不方便

newer

lucas3 发表于 2016-11-5 15:56

我用的时候，没出现你说的问题，请问下你使用的时候，是什么条件下会出现？ 不能重现问题，就不好找到代码的问题。

lucas3

N版，问题解决了！我之前用也没发现问题，我现在用的新版本cad2014才出现，刚才请教了明经的edata大师，解决了此问题，是nth4的问题，替换成(setq edata2(reverse edata2))     (setq edata2 (subst (cons 10 pnt1) (assoc 10 edata2) edata2))     (setq edata2(reverse edata2)) 改成这样就可以了。。。

cable2004

确实是难得好帖啊，顶先