仿word文本查找和替换源码(已上传)
本帖最后由 langjs 于 2012-1-6 21:40 编辑仿word文本查找和替换，用于单行文本和多行文本。
以前曾经做过一个，不过有重大BUG，替换效果不理想。这次参考、学习、并剽窃了风之影大侠的源码，弄了一个这个。风大侠的原版在这里
http://bbs.mjtd.com/thread-89647-1-1.html
略微更新一下，用了一个变通的办法支持了多行文本回车换行情况显示的小红框的位置问题，那种靠边界挤压多行文本换行时显示的小红框的位置不对，但不影响使用。
;;; =================================================================
;;; 文本查找和替换,核心代码来自风之影。程序显示多行文本换行位置不理想
;;; 作者：langjs 命令：ttf 日期2011年12月
;;; =================================================================
(defun c:czhth (/ bb bb_bak box dcl_pt en ennn ent ent1 f1 f2 h i j k lst01 n newchln newtxt np1 np2 np3 np4 oldchln p p1x p1y p2x p2y
px py r readch s schct snap ss ss1 txt txt00 txt00ln txt01 txtln ty w
)
(defun czth-01 (/ index_value) ; 显示对话框
(setq index_value (load_dialog "TTF.dcl"))
(new_dialog "TTF1" index_value "" dcl_pt)
(if oldch
(set_tile "e01" oldch)
(set_tile "e01" "")
)
(if newch
(set_tile "e02" newch)
(set_tile "e02" "")
)
(if (= bb_bak 4)
(set_tile "e03" "当前选择")
(set_tile "e03" "整个图形")
)
(mode_tile "e06" 1)
(action_tile "e04" "(czth-03) (setq dcl_pt (done_dialog 4))")
(action_tile "e05" "(czth-03) (setq dcl_pt (done_dialog 1))")
(action_tile "e06" "(czth-03) (setq dcl_pt (done_dialog 2))")
(action_tile "e07" "(czth-03) (setq dcl_pt (done_dialog 3))")
(setq bb (start_dialog))
)
(defun czth-02 (/ index_value) ; 显示对话框
(setq index_value (load_dialog "TTF.dcl"))
(new_dialog "TTF2" index_value "" dcl_pt)
(if oldch
(set_tile "e01" oldch)
(set_tile "e01" "")
)
(if newch
(set_tile "e02" newch)
(set_tile "e02" "")
)
(if (= bb_bak 4)
(set_tile "e03" "当前选择")
(set_tile "e03" "整个图形")
)
(action_tile "e04" "(czth-03) (setq dcl_pt (done_dialog 4))") ; 选择
(action_tile "e05" "(czth-03) (setq dcl_pt (done_dialog 1))") ; 查找
(action_tile "e06" "(czth-03) (setq dcl_pt (done_dialog 2))") ; 替换
(action_tile "e07" "(czth-03) (setq dcl_pt (done_dialog 3))") ; 全部替换
(action_tile "e08" "(czth-03) (setq dcl_pt (done_dialog 5))") ; 平移
(setq bb (start_dialog))
(if (= bb 5) ; 如按平移
(progn
(getpoint "\n中键平移，左键或右键平移结束:")
(princ "\n")
(czth-02)
)
)
)
(defun czth-03 ()
(setq oldch (get_tile "e01"))
(setq newch (get_tile "e02"))
)
(defun czth-04 (en / ss)
(if en
(progn
(setq ss (ssadd))
(while (setq en (entnext en))
(if (not (member (cdr (assoc 0 (entget en))) '("ATTRIB" "VERTEX"
"SEQEND"
)
)
)
(ssadd en ss)
)
)
(if (zerop (sslength ss))
(setq ss nil)
)
ss
)
(ssget "_x")
)
)
(setvar "cmdecho" 0) ; 关闭命令响应
(command ".UNDO" "BE") ; 设置undo起点
(setq snap (getvar "osmode"))
(setvar "osmode" 0) ; 关闭捕捉
(if (null dcl_pt)
(setq dcl_pt '(-1 -1))
)
(czth-01)
(if (= bb 4)
(progn
(setq bb_bak bb
ss (ssget '((0 . "TEXT,MTEXT")))
) ; 选择文字
(czth-02)
)
(setq ss (ssget "X" '((0 . "TEXT,MTEXT")))) ; 选择文字
)
(if ss
(progn
(setq i 0
j 0
k 0
oldchln (strlen oldch)
newchln (strlen newch)
)
(while (< i (sslength ss))
(setq ent (entget (ssname ss i))
ty (cdr (assoc 0 ent))
txt (cdr (assoc 1 ent))
txtln (strlen txt)
schct 1
newtxt ""
ss1 (ssadd)
i (1+ i)
)
(while (<= schct txtln)
(if (member bb '(1 2 3 4 5))
(princ)
(progn
(command ".erase" ss1 "")
(command ".UNDO" "E") ; 设置undo终点
(vl-exit-with-error "")
)
)
(if (= (setq readch (substr txt schct oldchln))
oldch
)
(progn
(if (= ty "MTEXT")
(progn
(command "copy" (cdr (assoc -1 ent)) "" '(0.0 0.0 0.0) '(0.0 0.0 0.0))
(setq ennn (entlast))
(command ".EXPLODE" ennn)
(setq ss1 (czth-04 ennn)
ent1 (entget (ssname ss1 0))
p (cdr (assoc 10 ent1)) ; 文本基点坐标
h (cdr (assoc 40 ent1)) ; 文本高度
w (cdr (assoc 41 ent1)) ; 文本宽高比
s (cdr (assoc 7 ent1)) ; 文本式样
r (cdr (assoc 50 ent1)) ; 文本旋转角度
)
(setq ty "")
)
)
(if (= ty "TEXT")
(setq p (cdr (assoc 10 ent)) ; 文本基点坐标
h (cdr (assoc 40 ent)) ; 文本高度
w (cdr (assoc 41 ent)) ; 文本宽高比
s (cdr (assoc 7 ent)) ; 文本式样
r (cdr (assoc 50 ent)) ; 文本旋转角度
)
)
(command ".erase" ss1 "")
(setq lst01 (czth-05 newtxt))
(setq n (car lst01))
(setq txt00 (cdr lst01))
(setq txt00ln (strlen txt00))
(setq box (textbox (list (cons 1 txt) (cons 40 h) (cons 41 w) (cons 7 s)))) ; 文本框坐标
(setq p1x (car (car box)) ; 文本左下角x坐标
p1y (cadr (car box))
p2x (car (cadr box)) ; 文本右上角x坐标
p2y (cadr (cadr box))
px (car p)
py (cadr p)
f1 (* txt00ln (/ (- p2x p1x) txtln))
f2 (* (+ (+ txt00ln 0.5) oldchln) (/ (- p2x p1x) txtln))
np1 (list (+ f1 px) (- (+ p1y py) (* n h 1.8424)))
np2 (list (+ f2 px) (- (+ p1y py) (* n h 1.8424)))
np3 (list (+ f2 px) (- (+ p2y py) (* n h 1.8424)))
np4 (list (+ f1 px) (- (+ p2y py) (* n h 1.8424)))
np1 (polar p (+ r (angle p np1)) (distance p np1))
np2 (polar p (+ r (angle p np2)) (distance p np2))
np3 (polar p (+ r (angle p np3)) (distance p np3))
np4 (polar p (+ r (angle p np4)) (distance p np4))
) ; 下面程序进行屏幕缩放计算
(command "PLINE" np1 "w" (* h 0.1) (* h 0.1) np2 np3 np4 "c")
(setq en (entlast))
(command "_.change" en "" "p" "c" 1 "")
(setq px (car np1)
py (cadr np1)
np1 (list (- px (* h 15)) (- py (* h 13)) 0.0) ; 缩放窗口计算与字体高度关联
np2 (list (+ px (* h 15)) (+ py (* h 7)) 0.0)
)
(if (or ; 如按的不是全部替换则缩放窗口
(= bb 1)
(= bb 2)
)
(progn
(command "zoom" "W" np1 np2)
(czth-02)
)
)
(command "erase" en "")
(if (= bb 1) ; 如按查找
(setq j (1+ j)
schct (+ schct oldchln)
newtxt (strcat newtxt oldch)
)
)
(if (= bb 2) ; 如按替换
(progn
(setq j (1+ j)
txt (strcat newtxt newch (substr txt (+ schct oldchln)))
txtln (strlen txt)
schct (+ schct newchln)
newtxt (strcat newtxt newch)
k (1+ k)
)
(entmod (setq ent (subst
(cons 1 txt)
(assoc 1 ent)
ent
)
)
)
)
)
(if (= bb 3) ; 如按全部替换
(progn
(setq i 0
oldchln (strlen oldch)
newchln (strlen newch)
)
(while (< i (sslength ss))
(setq ent (entget (ssname ss i))
txt (cdr (assoc 1 ent))
txtln (strlen txt)
schct 1
newtxt ""
i (1+ i)
)
(while (<= schct txtln)
(if (= (setq readch (substr txt schct oldchln))
oldch
)
(progn
(setq j (1+ j)
txt (strcat newtxt newch (substr txt (+ schct oldchln)))
txtln (strlen txt)
schct (+ schct newchln)
newtxt (strcat newtxt newch)
k (1+ k)
)
(entmod (setq ent (subst
(cons 1 txt)
(assoc 1 ent)
ent
)
)
)
(princ)
)
(setq schct (1+ schct)
newtxt (strcat newtxt (substr readch 1 1))
)
)
)
)
)
)
)
(setq schct (1+ schct)
newtxt (strcat newtxt (substr readch 1 1))
)
)
)
)
)
)
(princ (strcat "\n 已完成了搜索，共找到了 " (itoa j) " 处，并已完成了 " (itoa k) " 处替换。"))
(alert (strcat "\n 已完成了搜索，共找到了 " (itoa j) " 处，并已完成了 " (itoa k) " 处替换。"))
(setvar "osmode" snap) ; 恢复捕捉
(command ".UNDO" "E") ; 设置undo终点
(princ)
)
(defun czth-05 (newtxt / i readch schct txt01 txtln)
(setq txtln (strlen newtxt)
i 0
schct 1
txt01 ""
)
(while (<= schct txtln)
(setq readch (substr newtxt schct 2))
(if (= readch "\\P")
(progn
(setq i (1+ i))
(setq schct (+ schct 2))
(setq txt01 "")
)
(progn
(setq schct (1+ schct))
(setq txt01 (strcat txt01 (substr readch 1 1)))
)
)
)
(cons i txt01)
)
对话框文件在下边
如果能实现以下几点好非常好用了
1、可以点取图内现有的文字。
2、能够替换块里的文字及属性块内文字。 puzb2001 发表于 2012-2-22 15:04
功能很好
提个建议：
把恢复捕捉行位置调整一下，要不然不会恢复
不行啊只能恢复三维对象捕捉 对象捕捉恢复不了
langjs 的程序一直都不错，都是源码，顶了 不错，有新意！ 好，顶了！！这真是明目张胆的剽窃啊！！ 剽窃有特点呀，只要不是一样的，还是顶了 langjs 的程序一直都不错，都是源码，顶了 很好！祝：新年好！ 好帖，一定要顶上！ 本帖最后由 cabinsummer 于 2012-1-2 08:03 编辑
搞得原版没人看，精华帖才10个回复
http://bbs.mjtd.com/thread-89647-1-1.html
不错，这个程序值得期待。