[LISP程序]：给ACAD实体追加扩展数据

tsindong

(defun AddXdata()
(if (/= sa nil)(setq DwgX (rtos sa 2 7))(setq DwgX "z"))
(if (/= sb nil)(setq DwgY (rtos sb 2 7))(setq DwgY "z"))
(setq OrivX (car Oriv))
(setq OrivY (cadr Oriv))
(if (/= OrivX nil)(setq ProX (rtos OrivX 2 3))(setq ProX "z"))
(if (/= OrivY nil)(setq ProY (rtos OrivY 2 3))(setq ProY "z"))



(setq Selection (ssget))

(setq ExtData (getstring "请输入扩展信息："))
(setq Info ExtData)
(setq IndexB 0)
(if (and (/= Selection nil) (/= ExtData ""))(progn
      (setq NumSelected (sslength Selection))
  (repeat NumSelected
(setq ExtData (strcat "*" DwgX "*" DwgY "*" ProX "*" ProY "*" Info "*"))
      (setq ET (ssname Selection IndexB))
      (setq IndexB (+ IndexB 1))
      (setq lastent (entget ET))
      (setq EntType (cdr (assoc '0 lastent)))
      (if (= EntType "LINE")(progn
            (setq StartPx (cadr (assoc '10 lastent)))
            (setq StartPy (caddr (assoc '10 lastent)))
            (setq EndPx (cadr (assoc '11 lastent)))
            (setq EndPy (caddr (assoc '11 lastent)))
(setq ExtData (strcat ExtData  (rtos StartPx 2 7) "*" (rtos StartPy 2 7) "*" (rtos EndPx 2 7) "*" (rtos EndPy 2 7)))
                            );end progn
      );end if
  
      (setq Lst (list -3 (list "NEWDATA" (cons 1000 ExtData))))
      (regapp "NEWDATA")
      (setq exdata lst)
      (setq newent
      (list (car lastent) exdata))
      (entmod newent)
(setq ExtData "")
  );end repeat
                                                );end progn
);end if


(princ)
)



以上代码是测量断面绘图工具中存贮断面数据的函数,扩展数据以一个字符串形式存贮在实体上,数据分隔符是“*”，也就是这种形式：

坐标X*坐标Y*备注*......（只是说明，实际存贮顺序不是这样）

(setq ExtData (strcat "*" DwgX "*" DwgY "*" ProX "*" ProY "*" Info "*"))

上面这句就搞干这事的！

myrooms

谢谢，收下了

Qlin

贴一组对Xdata进行操作的函数：
[PHP]
;;; ***********************XDATA函数集*******************************
;-------------------------------------------------------------------
;把扩展信息表添加到选择集里的每个实体.
;-------------------------------------------------------------------
(defun XD_SSADD (ss_in xdLst app_name / ENAME N XD)
  (setq n 0)
  ;reg application name
  (regapp app_name)
  ;remove old Xdata
  (XD_Remove ss_in app_name nil)

  (repeat (sslength ss_in)
    (setq ename (ssname ss_in n))
    (setq
      xd (reverse (XD_WriteX@ xdLst))
      xd (list -3 (cons app_name xd))
      ename (append (entget ename) (list xd))
    )
    (entmod ename)
    (setq n (1+ n))
  );repeat
);end

;----------------------------------------------------
;删除选择集指定程序的扩展数据.
;----------------------------------------------------
(defun XD_Remove (ss AppName Verbose /  xd ssl cnt
                 ename tmp NumProc NumNotProc RemSS)
  (setq
    NumProc 0
    NumNotProc 0
    RemSS (ssadd))

  (if (= (type ss) 'ENAME)
    (progn
      (setq tmp (ssadd))
      (ssadd ss tmp)
      (setq ss tmp)
    )
  )

  (if ss
    (progn
      (setq
        cnt 0
        ssl (sslength ss)
        tmp (strcat " of " (itoa ssl))
      )
      (if Verbose
        (princ "\n")
      )
      (repeat ssl
        (setq
          ename (ssname ss cnt)
          xd    (assoc -3 (entget ename (list AppName)))
          cnt   (1+ cnt)
        )
        (if xd
          (progn
            (entmod (list (cons -1 ename) (list -3 (list AppName))))
            (setq NumProc (1+ NumProc))
            (ssadd ename RemSS)
          )
          (setq NumNotProc (1+ NumNotProc))
        )

        (if Verbose
          (princ
            (strcat
              "\rRemoving extended entity data belonging to application "
              AppName
              "..."
              (itoa cnt)
              tmp
            )
          )
        )
      )
    )
  )
  (list (if (> (sslength RemSS) 0)
          RemSS
          nil
        )
        NumProc
        NumNotProc
  )
);end


;-------------------------------------------------------------
; 根据数据表中不同数据的类型生成扩展数据表.
;-------------------------------------------------------------
(defun XD_WriteX@ (xdLst / xd xd1 itm)
  (setq xd '())
  (foreach itm xdLst
    (cond
      ((and (= (type itm) 'LIST) (= (car itm) "{}"))
        (setq
          xd1 (cons (cons 1002 "}") (XD_WriteX@ (cdr itm)))
          xd1 (append xd1 (list (cons 1002 "{")))
          xd (append xd1 xd)
        )
      )
      ((and (= (type itm) 'LIST) (= (length itm) 3))
        (setq xd (cons (cons 1010 itm) xd))
      )
      ((and (= (type itm) 'STR) (= (substr itm 1 1) "#"))
        (setq xd (cons (cons 1005 (substr itm 2)) xd))
      )
      ((= (type itm) 'STR)
        (setq xd (cons (cons 1000 itm) xd))
      )
      ((= (type itm) 'INT)
        (setq xd (cons (cons 1070 itm) xd))
      )
      ((= (type itm) 'REAL)
        (setq xd (cons (cons 1040 itm) xd))
      )
    )
  )
  xd
)

;----------------------------------------------------
;返回已经注册扩展数据的应用名列表.
;app_face为过滤应用名的前缀.
;----------------------------------------------------
(defun XD_APPLIST(app_face / RegAppList CurrentApp Rewind appstr pattern1)
  (setq Rewind T
        pattern1 (strcat app_face "*"))
  (while (setq CurrentApp (tblnext "APPID" Rewind))
    (setq
      Rewind nil
      appstr (cdr (assoc 2 CurrentApp)))
    (if (wcmatch appstr pattern1)
      (setq RegAppList (cons appstr RegAppList))
    );if
  )
  RegAppList
)

;----------------------------------------------------
;获取与样板物体有相同指定程序的选择集.
;----------------------------------------------------
(defun XD_SSGET<-APP<-ENT (ename app_face / lst1 entl xd)
  (setq entl (entget ename (list (strcat app_face "*"))))
  (if (setq lst1 (assoc -3 entl))
    (progn
      (setq xd (car (car (cdr lst1))))
      (ssget "X" (list (list -3 (list xd))))
    );progn
    nil
  );if
);end

;----------------------------------------------------
;返回指定程序相关的选择集.
;----------------------------------------------------
(defun XD_SSGET<-APP (app_name)
    (ssget "X" (list (list -3 (list app_name))))
);end


;----------------------------------------------------
;获取指定程序的扩展数据表.
;----------------------------------------------------
(defun XD_Read (ename AppName / entl xd)
  (setq
    entl (entget ename (list AppName))
    xd (cdr (car (cdr (assoc -3 entl))))
    xd (mapcar 'cdr xd)
    xd (Li_GroupLst xd "{" "}")
  )
)

;----------------------------------------------------
;Li_GroupLst.
;----------------------------------------------------
(defun Li_GroupLst ( Lst LstBeg LstEnd / nested_list Lst1 itm n)
  (setq Lst1 '() n 0)
  (while Lst
    (setq itm (car Lst))
    (cond
      ((= itm LstBeg)
        (setq nested_list (Li_FindNested Lst LstBeg LstEnd))
        (if nested_list
          (setq
            Lst1 (cons nested_list Lst1)
            Lst  (Li_SubList Lst (+ n 1 (length nested_list)) -1)
          )
          (setq
            Lst1 (append Lst Lst1)
            Lst '()
          )
        )
       (setq n 0)
      )
      ((= itm LstEnd)
       (setq Lst (cdr Lst))
      )
      (T
        (setq
          Lst1 (cons itm Lst1)
          Lst (cdr Lst)
          n (1+ n)
        )
      )
    )
  )
  (reverse Lst1)
)

;----------------------------------------------------
;; ! Li_SubList截取部分表
;----------------------------------------------------
(defun Li_SubList ( Lst Start len / _len n m _Lst)
(if (minusp len)
  (setq len 999999999)
)

(setq
  _len (length Lst)
  n (min (- Start 1) _len)  ; Starting Index
  m (min (+ n len) _len)    ; Ending Index
  _Lst '()
)

(while (< n m)
  (setq
    _Lst (cons (nth n Lst) _Lst)
    n (1+ n)
  )
)
(reverse _Lst)
)

;----------------------------------------------------
;; ! Li_FindNested 返回表内的复合表
;----------------------------------------------------
(defun Li_FindNested (Lst LstBeg LstEnd / len itm cnt Lst1 More Found )
(setq
  cnt   0
  Lst1 '()
  More  T
  Found nil
  len  (length Lst)
)
(while More
  (setq
    itm (nth cnt Lst)
    cnt (1+ cnt)
  )
  (cond
    ((= itm LstBeg)
      (setq Lst1 (cons itm Lst1))
     (setq Lst1 Lst1)
    )
    ((= itm LstEnd)
      (if Lst1
        (setq
          Lst1 (cons itm Lst1)
          More nil
          Found T
        )
      )
    )
    (T
      (if Lst1
        (setq Lst1 (cons itm Lst1))
      )
    )
  )
  (if (= cnt len)
    (setq More nil)
  )
)

;(if Found (reverse Lst1) nil)
  (if Found
    (progn
      (setq lst1 (cdr lst1)
            lst1 (reverse Lst1)
            lst1 (cdr lst1))
    );progn
    nil
  );if
)
;;; ******************XDATA函数集*******************************
[/PHP]

陌生人

不错不错，谢谢qlin版主。
以后有关xdata的问题就请教你了，：）
又大致看了一眼，有些地方用vl会不会简洁些？

Qlin

最初由 陌生人 发布
[B]不错不错，谢谢qlin版主。
以后有关xdata的问题就请教你了，：）
又大致看了一眼，有些地方用vl会不会简洁些？ [/B]

不要客气 :)
其实里面的大部分代码取自www.4d-technologies.com
我只是整理了一下用在自己的函数库里。

这些代码成形的时间较早，基本适用于早期的R14版，用vlisp改写应该还有较大的简化和优化余地，若有什么心得，还请发上来分享一下哦。

netbee

不知用"词典"与"扩展数据"，哪一个更好呢？

gufengyin

词典