gzxl 发表于 2011-1-3 15:11:22

独立地物及文字重复检查结果有问题?

;独立地物及文字重复检查
(defun c:tt ()
(setq del-lst nil)
(command "zoom" "e")
(setq all-pline (ssget "C" (getvar "extmin") (getvar "extmax")
                           '((-4 . "<or")
                               (0 . "insert")
                               (0 . "point")
                               (0 . "text")
                               (-4 . "or>")
                              )
                  )
)
(if (not all-pline)
      (progn (alert "\n没有任何独立地物点或文字") (exit))
)
(setq flag (getint "\n(1)对属性相同的自动删除 (2)全部聚焦地物 <2>:"))
(if (not flag) (setq flag 2))
(setq i 0)
(setq error-len 0.5);最小读物间隔
(repeat (sslength all-pline)
      (setq one-name (ssname all-pline i))
      (setq one-dat (entget one-name '("south")))
      (if one-dat
         (progn
            (setq source-xdat (assoc -3 one-dat))
            (if source-xdat (setq source-xdat (cdr (assoc 1000 (cdadr source-xdat)))));地码编码
            (setq one-type (cdr (assoc 0 one-dat)));地物类型,是独立地物还是文字
            (setq id-1 (cdr (assoc 5 one-dat)));实体句柄
            (setq ptt (cdr (assoc 10 one-dat)))
            (setq p1 (list (+ (car ptt) 5) (+ (cadr ptt) 5)) p2 (list (- (car ptt) 5) (- (cadr ptt) 5)))
            (command "zoom" p1 p2)
            (setq p1 (list (+ (car ptt) error-len) (+ (cadr ptt) error-len))
                  p2 (list (- (car ptt) error-len) (- (cadr ptt) error-len))
            )
            (setq one-lst (ssget "C" p1 p2 '((-4 . "<or")
                                             (0 . "insert")
                                             (0 . "text")
                                             (-4 . "or>")
                                          )
                        )
            )
            (setq j 0)
            (if (and one-lst (> (sslength one-lst) 1))
                (repeat (sslength one-lst)
                   (progn
                      (setq one-name-1 (ssname one-lst j))
                      (if (not (assoc one-name del-lst));如果不在删除列表里
                        (progn
                               (setq one-dat-1 (entget one-name-1 '("south")))
                               (setq id-2 (cdr (assoc 5 one-dat-1)));实体句柄
                               (setq source-xdat-1 (assoc -3 one-dat-1))
                               (if source-xdat-1
                                 (setq source-xdat-1 (cdr (assoc 1000 (cdadr source-xdat-1))))
                               )
                               (setq one-type-1 (cdr (assoc 0 one-dat-1)))
                               (setq ptt-1 (cdr (assoc 10 one-dat-1)))
                               (if (and (= one-type "INSERT")
                                        (= one-type one-type-1)
                                        (= source-xdat source-xdat-1)
                                        (/= id-1 id-2)
                                        (= flag 1)
                                        (< (- (caddr ptt) (caddr ptt-1)) 0.01)
                                 )
                                 (setq del-lst (cons (cons one-name-1 j) del-lst))
                               )
                               (if (and (= one-type "INSERT")
                                        (= one-type one-type-1)
                                        (= source-xdat source-xdat-1)
                                        (/= id-1 id-2)
                                        (= flag 2)
                                        (< (- (caddr ptt) (caddr ptt-1)) 0.01)
                                 )
                                 (progn
                                        (alert (strcat "\n存在代码相同重复的独立地物点\n地物代码为:" source-xdat))
                                        (exit)
                                 )
                               )
                               (if (and (= one-type "TEXT")
                                        (= one-type one-type-1)
                                        (= source-xdat source-xdat-1)
                                        (/= id-1 id-2)
                                        (= flag 1)
                                        (= (cdr (assoc 1 one-dat-1)) (cdr (assoc 1 one-dat)))
                                        (< (- (caddr ptt) (caddr ptt-1)) 0.01)
                                 )
                                 (setq del-lst (cons (cons one-name-1 j) del-lst))
                               )
                               (if (and (= one-type "TEXT")
                                        (= one-type one-type-1)
                                        (= source-xdat source-xdat-1)
                                        (/= id-1 id-2)
                                        (= flag 2)
                                        (= (cdr (assoc 1 one-dat-1)) (cdr (assoc 1 one-dat)))
                                        (< (- (caddr ptt) (caddr ptt-1)) 0.01)
                                 )
                                 (progn
                                        (alert "\n存在文字相同重复的文字注记")
                                        (exit)
                                 )
                               )
                        )
                      );end (if (not (assoc one-name-1 del-lst)))
                      (setq j (1+ j))
                   )
                );end (repeat (sslength one-lst))
            )
         )
         (setq i (1+ i))
      )
      (setq i 0)
      (repeat (length del-lst)
            (entdel (car (nth i del-lst)))
            (setq i (1+ i))
      )
)
(command "zoom" "e")
(alert "\n独立地物点及文字重复检查及改正成功!!!")
)

gzxl 发表于 2011-1-3 15:13:32

俺菜!!调试不出来,高手帮看看,先谢谢了
页: [1]
查看完整版本: 独立地物及文字重复检查结果有问题?