申请编一个LISP程序

wcf · 发表于 2004-6-21 06:56:00

图中每个方向每个字符是单个的，相当于已经炸开的文本，编一个LISP程序能把如图中每个方向字符串中的相挨着的两个以上数字连起来，其它字符仍为炸开的情况，在屏幕上代换原文本，且能批量处理。最好R14及以上版本都能通用。这个题目有一定的难度，请高手解决。

want · 发表于 2004-6-21 09:34:00

比较简单

petty · 发表于 2004-6-21 19:11:00

下载文字修改大师

wcf · 发表于 2004-6-21 21:46:00

文字修改大师无此功能。

meworld · 发表于 2004-6-24 12:46:00

给我两百块，我帮你做好．

meflying · 发表于 2004-6-24 14:27:00

(defun c:test (/ ss i j ent ents ang item lst str intlst xl-sort xl-isort To)
;(xl-sort lst fun) = 以取代vl-sort函数，用法相同(lsp)---------------by 无痕
(defun xl-sort (lst fun / nlst)
(foreach n lst (setq nlst (xl-isort n nlst fun)))
)
(defun xl-isort (item lst fun / k nlst)
(setq k T
nlst (apply 'append
(mapcar '(lambda (x)
(if (and K ((eval fun) item x))
(progn (setq k nil) (list item x))
(list x)
)
)
lst
)
)
)
(if k
(append lst (list item))
nlst
)
)
(defun To (entlst / str ents)
(setq str (apply 'strcat
(mapcar '(lambda (e) (cdr (assoc 1 e))) entlst)
)
)
(setq ents (subst (cons 1 str) (assoc 1 (car intlst)) (car entlst)))
(entmod ents)
(mapcar 'entdel
(mapcar '(lambda (e) (cdr (assoc -1 e))) (cdr entlst))
)
)
(setq ss (ssget '((0 . "TEXT"))))
(setq i 0)
(setq lst nil
intlst nil
)
(repeat (sslength ss)
(setq ent (ssname ss i))
(setq ents (entget ent))
(setq ang (cdr (assoc 50 ents)))
(if (setq item (assoc ang lst))
(setq lst (subst (append item (list ents)) item lst))
(setq lst (append lst (list (list ang ents))))
)
(setq i (1+ i))
)
(setq i 0)
(setq lst
(mapcar
'(lambda (e)
(cons
(car e)
(vl-sort (cdr e)
'(lambda (e1 e2)
(< (cadr (assoc 10 e1)) (cadr (assoc 10 e2)))
)
)
)
)
lst
)
)
(repeat (length lst)
(setq item (nth i lst))
(setq j 1)
(repeat (1- (length item))
(setq ents (nth j item))
(setq str (cdr (assoc 1 ents)))
(if (= (type (read str)) 'INT)
(setq intlst (append intlst (list ents)))
(if intlst
(progn
(To intlst)
(setq intlst nil)
)
)
)
(setq j (1+ j))
)
(if intlst
(To intlst)
)
(setq i (1+ i))
)
(princ)
)

(defun c:test (/ ss i j ent ents ang item lst str intlst xl-sort xl-isort To)
   ;(xl-sort lst fun) = 以取代vl-sort函数，用法相同(lsp)---------------by 无痕
   (defun xl-sort (lst fun / nlst)
       (foreach n lst (setq nlst (xl-isort n nlst fun)))
   )
   (defun xl-isort (item lst fun / k nlst)
       (setq k       T
     nlst (apply 'append
               (mapcar '(lambda (x)
         (if (and K ((eval fun) item x))
             (progn (setq k nil) (list item x))
             (list x)
         )
                   )
                 lst
               )
               )
       )
       (if k
           (append lst (list item))
           nlst
       )
   )
   (defun To (entlst / str ents)
       (setq str (apply 'strcat
             (mapcar '(lambda (e) (cdr (assoc 1 e))) entlst)
             )
       )
       (setq ents (subst (cons 1 str) (assoc 1 (car intlst)) (car entlst)))
       (entmod ents)
       (mapcar 'entdel
         (mapcar '(lambda (e) (cdr (assoc -1 e))) (cdr entlst))
       )
   )
   (setq ss (ssget '((0 . "TEXT"))))
   (setq i 0)
   (setq lst nil
  intlst nil
   )
   (repeat (sslength ss)
       (setq ent (ssname ss i))
       (setq ents (entget ent))
       (setq ang (cdr (assoc 50 ents)))
       (if (setq item (assoc ang lst))
           (setq lst (subst (append item (list ents)) item lst))
           (setq lst (append lst (list (list ang ents))))
       )
       (setq i (1+ i))
   )
   (setq i 0)
   (setq lst
   (mapcar
       '(lambda (e)
             (cons
   (car e)
   (vl-sort (cdr e)
       '(lambda (e1 e2)
             (< (cadr (assoc 10 e1)) (cadr (assoc 10 e2)))
         )
   )
             )
         )
       lst
   )
   )
   (repeat (length lst)
       (setq item (nth i lst))
       (setq j 1)
       (repeat (1- (length item))
           (setq ents (nth j item))
           (setq str (cdr (assoc 1 ents)))
           (if (= (type (read str)) 'INT)
  (setq intlst (append intlst (list ents)))
  (if intlst
     (progn
         (To intlst)
         (setq intlst nil)
     )
  )
           )
           (setq j (1+ j))
       )
       (if intlst
           (To intlst)
       )
       (setq i (1+ i))
   )
   (princ)
)

wcf · 发表于 2004-6-30 12:35:00

谢谢meflying的热心帮助，我测试了一下，在R14版本上不能用，在R2002上能用，单行处理没问题，一次多行处理出现文字乱串现象。

meflying · 发表于 2004-6-30 15:00:00

你能给个有问题的DWG 文件吗,我好测试一下

wcf · 发表于 2004-7-6 15:56:00

希版主抽时间修改一下，让R14的老用户能用，谢谢！

meflying · 发表于 2004-7-6 15:58:00

这是DWG文件吗？？？

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

申请编一个LISP程序

本帖子中包含更多资源

本帖子中包含更多资源