[讨论]剛剛寫的一個查找和替換程序

BDYCAD · 发表于 2004-9-1 11:00:00

各位朋友一起完善这个功能帮手加强下. 我先起个头. 谢谢! ;date: 2004-09-01
;by BDYCAD
;查找与替换
; (reptext <要找的文字> <替换成的文字>)
;应用举例:
;;;(SETQ char-A "DRAWING1" char-B "BDYCADCAD")
;;;(reptext char-A char-B)
(defun reptext(char-A char-B / pc ss index ent index typeA cosd newsize )
(setq pc 0 ss (ssget "x" '((0 . "TEXT"))))
(setq index 0 )
(repeat (sslength ss)
(setq ent (entget (ssname ss index)))
(setq index (+ 1 index))
(setq typeA (assoc 1 ent)
cosd (substr (cdr typeA) 1 (strlen char-A)))
(if (= cosd char-A)
(progn
(setq newsize (cons 1 (if (> (strlen (cdr typeA))(strlen char-B))
(strcat char-B (substr (cdr typeA) (strlen char-A)))
char-B)))
(setq ent (subst newsize typeA ent))
(setq pc (1+ pc))
(entmod ent))))
(princ (strcat "\n替换了" (rtos pc)"个."))
)

行天下 · 发表于 2022-9-28 08:58:23

日常灌水，到此一看

citykunan · 发表于 2004-9-1 11:07:00

CAD中有FIND命令的。

BDYCAD · 发表于 2004-9-1 11:15:00

这个我明白. 可是我是要在程序调用的. 请问可以在lisp程序直接调用 find 命令(不用对话框方式)去查找替换?我没有做过. 但好象不行的. 所以就写了. 但现在程序功能很弱.

tukuitk · 发表于 2004-9-2 17:29:00

(defun Replace (ename oldtext newtext / NewDoc)
(setq obj (vlax-ename->vla-object ename))
(setq tj (cdr (assoc 0 (entget ename))))
(if (not (and (= "" oldtext) (= "" newtext)))
(progn
(cond
((or (= tj "MTEXT") (= tj "TEXT"))
(setq text1 (vla-get-textstring obj))
;;(setq text11 (krsubst newtext oldtext text1))
(setq text11 (dos_strreplace text1 oldtext newtext))
(setq text1_ok (vla-put-textstring obj text11))
)
((= tj "INSERT")
(setq variantvalue
(vlax-variant-value (vla-GetAttributes obj))
)
(if (/= -1 (vlax-safearray-get-u-bound variantvalue 1))
(progn
(setq list_att (vlax-safearray->list variantvalue))
(setq list_len (vl-list-length list_att))
(setq ct 0)
(repeat list_len
(setq text1 (vla-get-textstring (nth ct list_att)))
;;(setq text11 (krsubst newtext oldtext text1))
(setq text11 (dos_strreplace text1 oldtext newtext))
(setq text1_ok
(vla-put-textstring (nth ct list_att) text11)
)
(setq ct (1+ ct))
)
)
)
)
((= tj "ATTDEF")
(setq text1 (vla-get-tagstring obj))
;;(setq text11 (krsubst newtext oldtext text1))
(setq text11 (dos_strreplace text1 oldtext newtext))
(setq text1_ok (vla-put-tagstring obj text11))
)
)
)
(progn
(alert "原文字和新文字均为空还替换什么呢？白费劲！")
(exit)
)
)
(princ)
)

(defun Replace (ename oldtext newtext / NewDoc)
   (setq obj (vlax-ename->vla-object ename))
   (setq tj (cdr (assoc 0 (entget ename))))
   (if (not (and (= "" oldtext) (= "" newtext)))
       (progn
           (cond
  ((or (= tj "MTEXT") (= tj "TEXT"))
   (setq text1 (vla-get-textstring obj))
   ;;(setq text11 (krsubst newtext oldtext text1))
   (setq text11 (dos_strreplace text1 oldtext newtext))
   (setq text1_ok (vla-put-textstring obj text11))
  )
  ((= tj "INSERT")
   (setq variantvalue
    (vlax-variant-value (vla-GetAttributes obj))
   )
   (if (/= -1 (vlax-safearray-get-u-bound variantvalue 1))
         (progn
           (setq list_att (vlax-safearray->list variantvalue))
           (setq list_len (vl-list-length list_att))
           (setq ct 0)
           (repeat list_len
               (setq text1 (vla-get-textstring (nth ct list_att)))
               ;;(setq text11 (krsubst newtext oldtext text1))
               (setq text11 (dos_strreplace text1 oldtext newtext))
               (setq text1_ok
               (vla-put-textstring (nth ct list_att) text11)
               )
               (setq ct (1+ ct))
           )
       )
   )
  )
  ((= tj "ATTDEF")
   (setq text1 (vla-get-tagstring obj))
   ;;(setq text11 (krsubst newtext oldtext text1))
   (setq text11 (dos_strreplace text1 oldtext newtext))
   (setq text1_ok (vla-put-tagstring obj text11))
  )
           )
       )
       (progn
           (alert "原文字和新文字均为空还替换什么呢？白费劲！")
           (exit)
       )
   )
   (princ)
)

这是我很早前写的一个程序中的一部分，调用了DOSLIB中的dos_strreplace函数，实际上也可写个程序来代替dos_strreplace函数的！它不只是可以替换Text或Mtext！

精灵王 · 发表于 2004-9-3 12:26:00

原来cad中有个自带的chtext.lsp文件，可以实现文字替换，就是不支持mtext

雪山飞狐_lzh · 发表于 2004-9-3 13:19:00

这是我以前编的一个通配符号替换程序是VBA的
'支持通配符*格式的替换
'例：*(*)->*

或A*B*->B*C*
'支持替换前后*的数量不等
Public Sub SuperReplace()
On Error Resume Next
Dim ss As AcadSelectionSet
Dim str As String
Dim pStart As String, pEnd As String
Dim i As AcadEntity, j
Dim ft(1) As Integer, fd(1)
Dim pSS, pES
Dim pStrs() As String
Dim pSpec As String ThisDrawing.SelectionSets("*TlsText*").Delete
Set ss = ThisDrawing.SelectionSets.Add("*TlsText*") pStart = Trim(ThisDrawing.Utility.GetString(True, "替换前："))
pEnd = Trim(ThisDrawing.Utility.GetString(True, "替换后："))
pSS = Split(pStart, "*")
pES = Split(pEnd, "*")
pSpec = Replace(pStart, "`", "``")
pSpec = Replace(pSpec, "[", "`[")
pSpec = Replace(pSpec, "]", "`]")
pSpec = Replace(pSpec, ",", "`,")
pSpec = Replace(pSpec, "@", "`@")
pSpec = Replace(pSpec, "~", "`~")
pSpec = Replace(pSpec, ".", "`.")
pSpec = Replace(pSpec, "?", "`?")
ft(0) = 0: fd(0) = "*Text"
ft(1) = 1: fd(1) = pSpec
ss.SelectOnScreen ft, fd
For Each i In ss
If UBound(pES) = 0 Then
i.TextString = pEnd
Else
str = i.TextString
ReDim pStrs(UBound(pSS) + 1) As String
For j = 0 To UBound(pSS)
pStrs(j) = LeftStr(str, pSS(j)) & pES(j)
str = RightStr(str, pSS(j))
Next j pStrs(UBound(pSS) + 1) = str
i.TextString = Join(pStrs, "")
End If
Next i ThisDrawing.SelectionSets("*TlsText*").Delete End Sub

spring · 发表于 2004-9-14 11:42:00

支持 TEXT和MTEXT，如果要查找的文字为 "" 会把新的文字加在开头

只替换文字中子文字,不是替换掉整个文字

演示文件,将0.010替换成0.050

BDYCAD · 发表于 2004-9-14 16:24:00

试了. 很好用.

青青20 · 发表于 2004-9-14 19:25:00

在lisp程序直接调用 find 命令,用对话框方式(设计或改进DCL来解决数据传递).初步估计能行.

雪山飞狐_lzh · 发表于 2004-9-14 21:31:00

为什么不用

(setq ss (ssget (list '(0 . "*Text") (cons 1 (strcat "*" char-A "*")))))

？

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

[讨论]剛剛寫的一個查找和替換程序

本帖子中包含更多资源