fire9527 发表于 2014-9-20 20:41:20

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

以下程序是开心版主的大作--批量查找替换文字，希望有热心朋友为这个程序加个对话框，谢谢！
(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 发表于 2014-9-20 20:41:21

(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 发表于 2014-9-22 15:06:52

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

香田里浪人 发表于 2014-9-22 21:30:24

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

fire9527 发表于 2014-9-23 21:46:03

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

非常完美！多谢langjs！

香田里浪人 发表于 2014-9-24 07:14:43

langjs 发表于 2014-9-20 20:41 static/image/common/back.gif
(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 发表于 2014-9-26 15:24:21

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

fire9527 发表于 2014-10-1 14:33:57

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

感谢提醒，当时还真没注意
页: [1]
查看完整版本: 求为这个好程序加个对话框，急~~