[LISP函数]：扩展数据删除，请帮忙测试？

guohq

(defun GetAPP(ent / obj vtype xdata lst nn rtn)
  ;;功能:获取对象的应用名
  (setq obj (vlax-ename->vla-object ent))
  (vla-getxdata obj "" 'vtype 'xdata)
  (if vtype
    (progn
      (setq vtype (vlax-safearray->list vtype)
            xdata (vlax-safearray->list xdata))
      (setq lst (allsyminlst 1001 vtype))
      (setq rtn '() nn 0)
      (repeat (length lst)
        (setq ent (nth (nth nn lst) xdata) nn (1+ nn))
        (setq rtn (cons (vlax-variant-value ent) rtn))
        )
      (setq rtn (reverse rtn))
      )
    )
  rtn
  )

(defun ALLSymInLst ( Sym  Lst / nn rtn ent)
  ;;功能:返回所有sym在lst中的位置,从0开始,如果没有则返回nil
  (setq rtn '() nn 0)
  (repeat (length lst)
    (setq ent (nth nn lst))
    (if (= sym ent)
      (setq rtn (cons nn rtn))
      )
    (setq nn (1+ nn))
    )
  (reverse rtn)
  )

(defun Delapp(ent app / obj appstr Vtype Xdata Ntype Ndata);;待测试
  ;;功能:删除某个对象的应用名
  ;;说明：多个app 以(list app1 app2)的形式存在
  (if (or (= app "*") (= app ""))
    (setq app (getapp ent))
    )
  (if (= (type app) 'STR)
    (setq app (list  app))
    )
  (if (= (type ent) 'ENAME)
    (setq obj (vlax-ename->vla-object ent) nn 0  rtn '())
    (setq obj ent nn 0  rtn '())
    )
  (repeat (length app)
    (setq appstr (nth nn app) nn (1+ nn))
    (vla-getxdata obj appstr 'vtype 'xdata)
    (if vtype
      (progn
        (setq ntype (vlax-make-safearray vlax-vbinteger '(0 . 0)))
        (vlax-safearray-put-element ntype 0 (vlax-make-variant  1001 2))
        (setq ndata (vlax-make-safearray 12 '(0 . 0)))
        (vlax-safearray-put-element ndata 0 (vlax-make-variant appstr 8))
        (vla-setxdata obj  ntype ndata)
        (setq rtn (cons (list appstr T) rtn))
        )
      (setq rtn (cons (list appstr nil) rtn))
      )
    (setq vtype nil xdata nil ntype nil ndata nil)
    )
  (reverse rtn)
  )

(defun c:tt();;test
  (setq ss (ssget) nn 0 )
  (repeat (sslength ss)
    (setq ent (ssname ss nn) nn (1+ nn))
    (print (delapp ent ""))
    )
  )

帮忙测试一下，为何选择一个对象，运行没有问题，如果一次选择了多个对象，就会出现错误？

zml84

http://zml84.blog.sohu.com/85405899.html

guohq

通用函数 扩展数据的修改.lsp

--------------------------------------------------------------------------------

;;;=========================================
;;;      通用函数   扩展数据的修改         
;;;参数：ent  ----组码表                    
;;;      name ----扩展应用名               
;;;      v1   ----被替换值                  
;;;      v2   ----替换为的新值              
(defun EDITINFO        (ENT NAME V1 V2 / TMP1 TMP2)
    (if        (and (setq TMP1 (cdr (assoc -3 ENT)))
             (setq TMP2 (cdr (assoc NAME TMP1)))
             (member V1 TMP2)
        )
        (progn
            ;;
            (setq TMP2 (subst V2 V1 TMP2))
            (setq TMP1 (subst (cons NAME TMP2) (assoc NAME TMP1) TMP1))
            (setq ENT (subst (cons -3 TMP1) (assoc -3 ENT) ENT))
            ;;
            (entmod ENT)
        )
    )
)
;;;=========================================
;;;测试
(defun C:TT (/ SS ENT TMP1 TMP2)
    (if        (setq SS (entsel))
        (if (EDITINFO (entget (car SS) '("*"))
                      "DJINFO"
                      (cons 1000 "253")
                      (cons 1000 "072")
            )
            (princ "\n===更新成功")
            (princ "\n===没有信息")
        )
        (princ "\n===没有选择到对象")
    )
    (princ)
)
;;;=========================================
;;;测试2   支持多个对象
(defun C:TT2 (/ SS I EN ENT TMP1 TMP2)
    (if        (setq SS (ssget '((0 . "LINE"))))
        (progn
            (setq I 0)
            (repeat (sslength SS)
                (setq EN  (ssname SS I)
                      ENT (entget EN '("*"))
                )
                (princ "\n===")
                (princ EN)
                (if (EDITINFO ENT
                              "DJINFO"
                              (cons 1000 "253")
                              (cons 1000 "072")
                    )
                    (princ "===更新成功")
                    (princ "===没有信息")
                )
                (setq I (1+ I))
            )
        )
        (princ "\n===没有选择到对象")
    )
    (princ)
)
;;;=========================================

84,你好，看了你的代码，觉得这一句考虑不够全面，  (setq TMP2 (cdr (assoc NAME TMP1)))
。
我贴这个代码的初衷也就是搞不清楚为什么我的代码选择一个对象运行正常，选择多个就出现问题。如有空，请帮忙测试一下，谢谢。