求为这个好程序加个对话框，急~~

fire9527

以下程序是开心版主的大作--批量查找替换文字，希望有热心朋友为这个程序加个对话框，谢谢！
(DEFUN C:th()
    (setvar "cmdecho" 0)
(setq ss  (SSGET":s" '((0 . "*TEXT"))) )
;以下4行内容希望能用对话框的形式出现，程序让临时指定被查找和被替换的内容更方便使用
(KX-reptext SS "1" "A")  ;“1“是将要被查找的内容，”A“是用来替换”1“的内容
(KX-reptext SS "2" "B")
(KX-reptext SS "3" "C")
(KX-reptext SS "4" "D")  

(PRINC)
)
(defun KX-reptext (SS oldch newch / ss ssl ct0 edata etext txtln subln ct1 ct2 schct newtext)
  (if ss
    (progn
      (setq ssl (sslength ss)
            ct0 0
            ct1 0
            ct2 0
            subln (strlen oldch)
      )
      (while (< ct0 ssl)
        (setq edata (entget (ssname ss ct0))
              etext (cdr (assoc 1 edata))
              txtln (strlen etext)
              schct 1
              newtext ""
        )
        (while (<= schct txtln)
          (setq newtext
            (strcat newtext
              (if (= (setq readch (substr etext schct subln)) oldch)
                (setq ct1 (1+ ct1)
                  schct (+ schct subln)
                  newch newch
                )
                (progn
                  (setq schct (1+ schct))
                  (substr readch 1 1)
                )
              )
            )
          )
        )
        (if (/= etext newtext)
   (progn
            (entmod (subst (cons 1 newtext) (assoc 1 edata) edata))
            (setq ct2 (1+ ct2))
          )
        )
        (setq ct0 (1+ ct0))
      )
    )
  )
)

langjs

(defun c:th (/ bb dcl_pt dcl_re dclname filen ss x)
  (defun get ()
    (setq lst001bak (list (list (get_tile "e01") (get_tile "e02")) (list (get_tile "e03") (get_tile "e04")) (list (get_tile "e05")
                                                                                                                  (get_tile "e06")
                                                                                                            ) (list
                                                                                                                    (get_tile "e07")
                                                                                                                    (get_tile "e08")
                                                                                                              )
                    )
    )
  )
  (setvar "cmdecho" 0)
  (setq dclname (vl-filename-mktemp "th.dcl"))
  (setq filen (open dclname "w"))
  (princ "th1:dialog    { label = \"批量替换\" ;\n " filen)
  (princ ":boxed_column { label = \"查找              替换\" ; " filen)
  (princ ":row { :edit_box  { key = \"e01\" ;  edit_width = 15 ;}\n" filen)
  (princ "       :edit_box  { key = \"e02\" ;  edit_width = 15 ;}}\n" filen)
  (princ ":row { :edit_box  { key = \"e03\" ;  edit_width = 15 ;}\n" filen)
  (princ "       :edit_box  { key = \"e04\" ;  edit_width = 15 ;}}\n" filen)
  (princ ":row { :edit_box  { key = \"e05\" ;  edit_width = 15 ;}\n" filen)
  (princ "       :edit_box  { key = \"e06\" ;  edit_width = 15 ;}}\n" filen)
  (princ ":row { :edit_box  { key = \"e07\" ;  edit_width = 15 ;}\n" filen)
  (princ "       :edit_box  { key = \"e08\" ;  edit_width = 15 ;}}\n" filen)
  (princ " }  ok_cancel; }" filen)
  (close filen)
  (setq dcl_re (load_dialog dclname))
  (new_dialog "th1" dcl_re "" dcl_pt)
  (if (null lst001bak)
    (setq lst001bak (list '("" "") '("" "") '("" "") '("" "")))
  )
  (set_tile "e01" (caar lst001bak))
  (set_tile "e02" (cadar lst001bak))
  (set_tile "e03" (caadr lst001bak))
  (set_tile "e04" (cadadr lst001bak))
  (set_tile "e05" (caaddr lst001bak))
  (set_tile "e06" (cadr (caddr lst001bak)))
  (set_tile "e07" (car (cadddr lst001bak)))
  (set_tile "e08" (cadr (cadddr lst001bak)))
  (action_tile "accept" "( get )(setq dcl_pt (done_dialog 1))")
  (setq bb (start_dialog))
  (unload_dialog dcl_re)
  (vl-file-delete dclname)
  (if (= bb 1)
    (while (setq ss (ssget ":s" '((0 . "*TEXT"))))
      (foreach x lst001bak
        (if (/= (car x) "" (cadr x))
          (kx-reptext ss (car x) (cadr x))
        )
      )
    )
  )
  (princ)
)

theisland

同求同求，希望有高手来设计一个

香田里浪人

批量查找替换文字除了开心版主的大作以外，还有人编过，论坛里很多。楼主要在开心版主的大作--批量查找替换文字加个对话框，可参考“风之影”的大作，链接如下
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=89647

fire9527

langjs 发表于 2014-9-22 22:35
(defun c:th (/ bb dcl_pt dcl_re dclname filen ss x)
  (defun get ()
    (setq lst001bak (list (lis ...

非常完美！多谢langjs！

香田里浪人

langjs 发表于 2014-9-20 20:41
(defun c:th (/ bb dcl_pt dcl_re dclname filen ss x)
  (defun get ()
    (setq lst001bak (list (lis ...

好像前面应该再添加 KX-reptext 函数定义
(defun KX-reptext (SS oldch newch / ss ssl ct0 edata etext txtln subln ct1 ct2 schct newtext)
  (if ss
    (progn
      (setq ssl (sslength ss)
            ct0 0
            ct1 0
            ct2 0
            subln (strlen oldch)
      )
      (while (< ct0 ssl)
        (setq edata (entget (ssname ss ct0))
              etext (cdr (assoc 1 edata))
              txtln (strlen etext)
              schct 1
              newtext ""
        )
        (while (<= schct txtln)
          (setq newtext
            (strcat newtext
              (if (= (setq readch (substr etext schct subln)) oldch)
                (setq ct1 (1+ ct1)
                  schct (+ schct subln)
                  newch newch
                )
                (progn
                  (setq schct (1+ schct))
                  (substr readch 1 1)
                )
              )
            )
          )
        )
        (if (/= etext newtext)
   (progn
            (entmod (subst (cons 1 newtext) (assoc 1 edata) edata))
            (setq ct2 (1+ ct2))
          )
        )
        (setq ct0 (1+ ct0))
      )
    )
  )
)

tianyi1230

找找严大师的文字批量查找替换！

fire9527

香田里浪人 发表于 2014-9-24 07:14
好像前面应该再添加 KX-reptext 函数定义
(defun KX-reptext (SS oldch newch / ss ssl ct0 edata etext ...

感谢提醒，当时还真没注意