继续无聊，源码 dbx不打开目录文件替换字符(支持多重块)

狂刀lxx · 发表于 2011-5-10 23:26

注：本程序包含多个有用函数，及相关知识说明
部分参考了 lzh741206 的程序，在此感谢

;| mcht = dbx不打开目录文件替换字符(支持多重块).-----by lxx.2007.4 测试ok!
v1.0 支持选目录和手选多图;支持块中块内文字;
v1.1 支持多项文字替换.
v1.4 支持本图替换操作.自动regen.
v1.3 优化本图替换速度
v1.4 支持块属性.
v1.5 支持旧字符含通配特殊字符,进行转义(加`). 支持修改锁定图层内实体.
|;
;;(defun c:mcht (/ FNAME I VCOL func FNAME FNS FPATH NSTR OSTR PATHFILE PATHKEY FNAME FPATH NSTRS OSTRS)
;;(defun xo-infdo (fname vcol func / doc CNAME RET VERKEY DOC E ENT I REGKEY SS SSBLK ATTS BLKS CDOC CNAMES DOCS)
;;(setq path (vl-filename-directory (getfiled "选择目录:" "按保存确认所选目录" " " 5)))
;;(setq x (car files))
(defun c:mcht (/ CNAME FIL FNAME FPATH VCOL FF
I FNS NSTR OSTR PATHFILE PATHKEY
NSTRS OSTRS) ;*dir = 多选文件初始目录.
(princ "\n mcht = dbx不打开目录文件替换字符(支持多重块)v1.5-----by lxx.2007.4")
(initget "1 2 3 ")
(setq pathkey (getkword "\n 1-选目录/2-多选文件/3-本图操作<3>:"))
(if (not pathkey)(setq pathkey "3"))
(setq vcol '(modelspace paperspace blocks)
cname (strcat(getvar "DWGPREFIX")(getvar "DWGNAME"))
)
(cond
((= pathkey "3")
(setq fns (list cname)))
((= pathkey "2")
(if *dir (setq fns (xo-getfiles *dir))
(setq fns (xo-getfiles "c:\")))
(if fns (setq *dir(vl-filename-directory(car fns))))
)
(T
(setq fpath (qf_getFolder "选择要处理的文件所在目录") ;qf_getFolder 秋风的取目录函数.
)
(if fpath
(setq fpath (strcat fpath "\")
pathfile (vl-directory-files fpath "*.dwg")
fns (mapcar '(lambda (x) (strcat fpath x)) pathfile)
)
)
)
)
;(c:xgetfiles)
;|(defun xx (ob)(if (vlax-property-available-p ob 'textstring)
(vla-put-textstring ob (x$sub "梁雄啸" "lxx" (vla-get-textstring ob)))
))|;
;;两种方式均支持. 函数 or lambda
(while (/= "" (setq ostr (getstring "\n 旧字符/<下一步>:")))
(setq nstr (getstring "\n 新字符<"">:") ;>> 待增强,可点取图上文字,sendkey到输入栏,可二次编辑.!!!!!
ostrs (cons ostr ostrs)
nstrs (cons nstr nstrs))
) ; ostrs,nstrs = 字符列表.一一对应.
(if (and fns ostrs nstrs)
(progn
(setq
ff '("#" "," "[" "]" "@" "*" "?" "~" ) ;避免字符和字符过滤符混淆造成错误.
fil (apply 'strcat
(mapcar '(lambda (x / strs `)
(setq strs (vl-string->list x)
` (ascii "`"))
(setq x (vl-list->string(apply 'append
(mapcar '(lambda(y)(if (member (chr y) ff)(list ` y)
(list y)))strs))
))
(strcat "*" x "*,")) ostrs)
)
)
(princ "\n 正在处理文件:")
(mapcar
'(lambda (fname)
(xo-infdo
fname
vcol
'(lambda (x)
(if
(and (vlax-property-available-p x 'textstring)
(wcmatch (setq str (vla-get-textstring x)) fil)
)
(vla-put-textstring
x
(x$subs nstrs ostrs str)
)
)
)
)
)
fns
)
)
)
;(mapcar 'print fns)
(princ)
)
;| (xo-infdo fname vcol func) = dbx技术对文件内集合进行操作
参数: fname = cad文件(*.dwg格式)
vcol = 集合列表.如'(modelspace paperspace)
func = 操作函数名, 如: 'xx 或 '(lambda(x)....)
操作函数必须含一个变量(集合内实体). 如: (defun xx (x) ...)
返回: 分别操作的表(表内容根据函数来定义).
说明: vcol可以是如下集合:
All Collection Objects(所有的集合实体:)
Blocks Dictionaries DimStyles funccuments FileDependencies Groups
Hyperlinks Layers Linetypes MenuBar MenuGroups ModelSpace
PaperSpace PlotConfigurations PopupMenu PopupMenus
RegisteredApplications SelectionSets TextStyles Toolbar
Toolbars UCSs Viewports Views
|;
(defun xo-infdo (fname vcol func / doc CNAME RET VERKEY DOC E ENT I REGKEY SS SSBLK
ATTS BLKS CDOC CNAMES DOCS llays)
(setq fname (strcase fname))
(print fname)
(setq cdoc(vla-get-activedocument(vlax-get-acad-object)))
(setq cname (strcat(getvar "DWGPREFIX")(getvar "DWGNAME"))) ;; 当前文件名.
(vlax-for x (vlax-get(vlax-get-acad-object) 'documents) (setq docs (cons x docs)))
(setq cnames (mapcar '(lambda(x)(strcase (strcat (vla-get-path x) "\" (vla-get-name x)))) docs))
;(setq fname cname)
(if (member fname cnames)
(progn
;; v1.5加入,锁定图层解锁.>>可放入为xo-infdo的参数.后补>>
(evaldo cdoc (vla-get-layers cdoc)
'(lambda(x)(if(= :vlax-true (vla-get-lock x))
(progn(setq llays(cons x llays))
(vla-put-lock x :vlax-false)
)
)
)
)
(evalcur (setq doc (nth (-(length docs)(length(member fname cnames))) docs)));处理当前文件,evalcur函数
(mapcar '(lambda(x)(vla-put-lock x :vlax-true)) llays)
)
;; 处理非当前文件.
(progn
(setq verkey (if (> (atoi (getvar "AcadVer")) 15)
".16"
""
)
*DBXDOC (vla-getinterfaceobject
(vlax-get-acad-object)
(strcat "ObjectDBX.AxDbDocument" verkey)
)
)
(vla-open *dbxdoc fname :vlax-false) ;open
;; v1.5加入,锁定图层解锁.>>可放入为xo-infdo的参数.后补>>
(evaldo *dbxdoc (vla-get-layers *dbxdoc)
'(lambda(x)(if(= :vlax-true (vla-get-lock x))
(progn(setq llays(cons x llays))
(vla-put-lock x :vlax-false)
)
)
)
)
;;
(setq
ret (mapcar '(lambda (x)
(evaldo *dbxdoc (vlax-get *dbxdoc x) func) ;evaldo 函数
)
vcol
)
);(vlax-dump-object *dbxdoc T)
;; v1.5加入,锁定图层解锁恢复>>
(mapcar '(lambda(x)(vla-put-lock x :vlax-true)) llays)
;;
(vlax-invoke *dbxdoc 'saveas fname)
(vlax-release-object *dbxdoc)
)
)
ret
)
;;; 处理非打开文件.
(defun evaldo (doc obj func)
(vlax-map-collection
obj
'(lambda (x)
(if (vlax-property-available-p x 'count)
(evaldo doc x func)
(if (vlax-method-applicable-p x 'GetAttributes)
(mapcar '(lambda (y) ((eval func) y))
(vlax-invoke x 'GetAttributes)
)
((eval func) x)
)
)
)
)
)
;;;*当前文件* ;(setq doc cdoc) ;(setq cnames nil)
(defun evalcur (doc / ATTS BLKS E ENT I REGKEY SS SSBLK X Y)
(if (equal doc cdoc)
(princ "(*当前文件*)")
(princ "(*已打开文件*)")
)
;;激活已打开文件..->>>>>bug, vlisp先天缺陷? 不能跨文档
(vla-Activate doc)
;;处理*text
(if (setq i -1
ss (ssget "x" (list (cons 0 "*TEXT") (cons 1 fil)))
)
(while (setq i (1+ i)
e (ssname ss i)
)
(setq ent (entget e))
(entmod
(subst (cons 1 (x$subs nstrs ostrs (cdr (assoc 1 ent))))
(assoc 1 ent)
ent
)
)
)
)
(princ "\n .......文字处理完毕.")
;;处理块内文字.
(if (setq blks (vla-get-blocks doc))
(vlax-for x blks ;(vla-item (vla-get-blocks doc) 1)
(setq regkey nil)
(vlax-for y x
(if (and (wcmatch (vla-get-objectname y) "AcDb*Text")
(wcmatch (vla-get-textstring y) fil)
)
(progn (vla-put-textstring
y
(x$subs nstrs ostrs (vla-get-textstring y))
)
(setq regkey T)
)
)
)
(if (and regkey (< 0 (vla-get-count x)))
;(print (assoc 2 (entget(vlax-vla-object->ename x))))
(if (setq i -1
ssblk
(ssget
"x"
(list (cons 0 "INSERT") (cons 2 (vla-get-name x)))
)
)
(while (setq i (1+ i)
e (ssname ssblk i)
)
(entupd e)
)
)
)
)
)
(princ "\n .......块内文字处理完毕.")
;;处理块属性.
(if
(setq i -1
ss (ssget "x" (list (cons 0 "INSERT") (cons 66 1)))
)
(while (setq i (1+ i)
e (ssname ss i)
)
(setq atts (vlax-invoke (vlax-ename->vla-object e) 'getattributes))
(mapcar '(lambda (x / y) ;(setq x (cadr atts))
(if (wcmatch (setq y (vla-get-textstring x)) fil)
(vla-put-textstring x (x$subs nstrs ostrs y))
)
)
atts
)
)
)
(princ "\n .......块属性处理完毕.")
;;恢复激活原当前文件.
(vla-Activate cdoc)
doc
)
;; (qf_getFolder "");; 取目录 by 秋枫.
(defun qf_getFolder (msg / WinShell shFolder path catchit)
(vl-load-com)
(setq winshell (vlax-create-object "Shell.Application")); (vlax-dump-object winshell T)
(setq shFolder (vlax-invoke-method WinShell 'BrowseForFolder 0 msg 1))
(setq
catchit (vl-catch-all-apply
'(lambda ()
(setq shFolder (vlax-get-property shFolder 'self))
(setq path (vlax-get-property shFolder 'path))
)
)
)
(if (vl-catch-all-error-p catchit)
nil
path
)
)
;| (xo-getfiles dir) = 调用win系统对话框选取多个文件(2007)，返回文件列表.----by lxx.2007.4 v2.0
参数: dir = 初始目录
返回: 含路径的文件名列表.
说明: for Windows XP / winnt2k
测试:
(xo-getfiles "c:\\temp\")
-> ("C:\\temp\\测试新块1.dwg" "C:\\temp\\测试新块2.dwg") ;; 多选.
-> ("C:\\temp\\测试新块1.dwg") ;; 单选.
|;
(defun xo-getfiles (Dir / x r y lst fn$ DLGPATH I PATH)
(vl-load-com)
(if (and (not (setq x (vlax-create-object "MSComDlg.CommonDialog")))
(setq dlgpath (findfile "Comdlg32.inf"))
)
(startapp (strcat dlgpath))
)
(if (or (setq x (vlax-create-object "UserAccounts.CommonDialog"))
(setq y (vlax-create-object "MSComDlg.CommonDialog")
x y
)
)
(progn
(vlax-put-property
x
'Filter
"cad文件|*.dwg;*.dxf|cad程序|*.lsp;*.arx;*.fas;*.vlx|位图|*.jpg;*.bmp;*.png;*.gif|所有类型|*.*"
)
;(vlax-put-property x 'FilterIndex 1)
(if y
(vlax-put-property x "MaxFileSize" 10000)
)
(vlax-put-property x 'Flags 512) ; 设置多选文件选项, 如不需要则删除此行
(vlax-put-property x 'InitialDir Dir)
(setq r (vlax-invoke-method x 'ShowOpen))
(if (= 0 r)
nil
(setq fn$ (vlax-get-property x 'FileName))
)
)
)
(setq lst nil)
(if (/= "" fn$)
(cond
((vl-string-search " " fn$)
(while (setq i (vl-string-position (ascii " ") fn$))
(setq lst (cons (substr fn$ 1 i) lst)
fn$ (substr fn$ (+ 2 i))
)
)
(if (/= "" fn$)
(setq lst (cons fn$ lst))
)
(setq lst (reverse lst)
path (car lst)
)
(mapcar '(lambda (x) (strcat path x)) (cdr lst))
)
(T (list fn$))
)
nil
)
)
;|(x$sub 新$ 旧$ 字符串) = 字符串替换-------------------------------lxx.2004.2
(x$sub " " "-" "32-33-0.01-哈哈") -> "32 33 0.01 哈哈"
|;
(defun x$sub (n$ o$ str / n)
(setq n 0)
(while (setq n (vl-string-search o$ str n))
(setq str (vl-string-subst n$ o$ str n))
(setq n (+ n (strlen n$)))
)str
)
;|(x$subs 新$表旧$表字符串) = 字符串多项替换--lxx.2007.4
功能:替换字符串中符合替换表的多项字符.
测试: (x$subs '("aa" "1") '("bb" "2") "bbc-bb2132") ->"aac-aa1131"
|;
(defun x$subs (nstrs ostrs str)
(mapcar '(lambda(x y)(setq str (x$sub x y str))) nstrs ostrs)
str
)
;;====================================================================;;
(princ "\n mcht = dbx不打开目录文件替换字符(支持多重块)v1.5-----by lxx.2007.4")
(princ)
;; dbx技术＝不打开dwg，修改指定路径下多个文件内的文字 by lzh741206
;; [url=http://xdcad.net/forum/showthread.php?s=&postid=1211267#post1211267]http://xdcad.net/forum/showthread.php?s=&postid=1211267#post1211267[/url]
;|
Sub MyReplace(PathName As String, str1 As String, str2 As String)
Dim pFile As String
Dim ObjDbx As Object
pFile = Dir(PathName & "*.dwg")
Set ObjDbx = GetInterfaceObject("ObjectDBX.AxDbDocument.16")
'2002版本下改为Set ObjDbx = GetInterfaceObject("ObjectDBX.AxDbDocument.1")
Do While pFile <> ""
ObjDbx.Open PathName & pFile
For Each i In ObjDbx.ModelSpace
If i.ObjectName = "AcDbText" Or i.ObjectName = "AcDbMText" Then
i.textString = Replace(i.textString, str1, str2)
End If
Next i
ObjDbx.SaveAs PathName & pFile
pFile = Dir()
Loop
End Sub
|;
;|
vl-directory-files 函数
语法
(vl-directory-files [directory pattern directories])
功能
列出给定目录中的所有文件。
说明
1）参数 directory 为字符串，指定要收集文件的目录。若未指定该参数或参数为 nil，那么vl-directory-files 使用当前目录。
2）参数 pattern 为字符串，包含文件名的 DOS 方式。如果未指定该参数或参数为 nil，vl-directory-files 假定为 "*.*"。
3）directories 为整数型，指定返回的表中是否包含路径名。可以指定下列值之一：
-1 仅列出目录。
0 列出文件和目录（缺省值）。
1 仅列出文件。
返回值：
文件和路径列表。若没有符合指定方式的文件，则返回 nil。
样例：
1）_$ (vl-directory-files "c:/acadwin" "acad*.exe")
("ACAD.EXE" "ACADAPP.EXE" "ACADL.EXE" "ACADPS.EXE")
2）_$ (vl-directory-files "d:/acadwin" nil -1)
("." ".." "SUPPORT" "SAMPLE" "ADS" "FONTS" "IGESFONT" "SOURCE" "ASE")
3）_$ (vl-directory-files "d:/acad13c4" nil -1)
("." ".." "WIN" "COM" "DOS")
GetInterfaceObject 方法
Application 对象
一个 AutoCAD 应用程序实例。
VBA 类别名:
AcadApplication
创建方法:
对于VB:
GetObject("AutoCAD.Application.16")
CreateObject("AutoCAD.Application.16")
对于AutoCAD VBA:
不适用。应用程序始终可用()。
访问途径:
Application 属性
与Application对象相关联的属性主应用程序窗口的特性。这些方法控制当前加载的外部应用程序与接口对象的加载或列表。
活动的文档 (AutoCAD 图形) 可使用 ActiveDocument 属性来访问。
要从VBA访问Application 对象，可使用 Thisdrawing.Application。要从VB中访问 Application 对象，可使用 Visual Basic
函数 GetObject 或 CreateObject。
如果 AutoCAD 正在运行，GetObject 函数将会得到当前的 AutoCAD Application 对象。当同时运行了多个 AutoCAD 进程，
GetObject 函数返回Windows 运行对象表中第一个 AutoCAD 实例。请查阅 Microsoft Visual Basic 文档的
Running Object Table (ROT) 和 GetObject 函数 (以获得确认GetObject返回操作的详细信息)。
使用版本相关的 ProgIDs。如果 CreateObject 或 GetObject 函数使用了版本相关的 ProgID，更改函数以适用版本相关 ProgID。例如，
用户可更改 CreateObject ("AutoCAD.Application") 为 CreateObject ("AutoCAD.Application.16")来调用AutoCAD 2004。
Application 对象同时也是 ActiveX 接口的 Global 对象。也就是说 Application 对象的所有方法和属性，都可以用于全局名称空间。

;| mcht = dbx不打开目录文件替换字符(支持多重块).-----by lxx.2007.4 测试ok! 
v1.0 支持选目录和手选多图;支持块中块内文字; 
v1.1 支持多项文字替换. 
v1.4 支持本图替换操作.自动regen. 
v1.3 优化本图替换速度 
v1.4 支持块属性. 
v1.5 支持旧字符含通配特殊字符,进行转义(加`). 支持修改锁定图层内实体. 
|; 
;;(defun c:mcht (/ FNAME I VCOL func FNAME FNS FPATH NSTR OSTR PATHFILE PATHKEY FNAME FPATH NSTRS OSTRS) 
;;(defun xo-infdo (fname vcol func / doc CNAME RET VERKEY DOC E ENT I REGKEY SS SSBLK ATTS BLKS CDOC CNAMES DOCS) 
 
;;(setq path (vl-filename-directory  (getfiled "选择目录:" "按保存确认所选目录" " " 5))) 
;;(setq x (car files)) 
(defun c:mcht (/  CNAME FIL FNAME FPATH VCOL FF 
      I FNS NSTR OSTR PATHFILE PATHKEY 
      NSTRS OSTRS) ;*dir = 多选文件初始目录. 
  (princ "\n mcht = dbx不打开目录文件替换字符(支持多重块)v1.5-----by lxx.2007.4") 
  (initget "1 2 3  ") 
  (setq pathkey (getkword "\n 1-选目录/2-多选文件/3-本图操作<3>:")) 
  (if (not pathkey)(setq pathkey "3")) 
  (setq vcol '(modelspace paperspace blocks) 
 cname (strcat(getvar "DWGPREFIX")(getvar "DWGNAME")) 
    ) 
  (cond 
    ((= pathkey "3") 
     (setq fns (list cname))) 
    ((= pathkey "2") 
     (if *dir (setq fns (xo-getfiles *dir)) 
       (setq fns (xo-getfiles "c:\"))) 
     (if fns (setq *dir(vl-filename-directory(car fns)))) 
     ) 
    (T 
     (setq fpath (qf_getFolder "选择要处理的文件所在目录") ;qf_getFolder 秋风的取目录函数. 
     ) 
     (if fpath 
       (setq fpath    (strcat fpath "\") 
      pathfile (vl-directory-files fpath "*.dwg") 
      fns      (mapcar '(lambda (x) (strcat fpath x)) pathfile) 
       ) 
     ) 
    ) 
  ) 
  ;(c:xgetfiles) 
  ;|(defun xx (ob)(if (vlax-property-available-p ob 'textstring) 
    (vla-put-textstring ob (x$sub  "梁雄啸" "lxx" (vla-get-textstring ob))) 
    ))|; 
  ;;两种方式均支持. 函数 or lambda 
  (while (/= "" (setq ostr (getstring "\n 旧字符/<下一步>:"))) 
    (setq nstr (getstring "\n 新字符<"">:") ;>> 待增强,可点取图上文字,sendkey到输入栏,可二次编辑.!!!!! 
   ostrs (cons ostr ostrs) 
   nstrs (cons nstr nstrs)) 
  ) ; ostrs,nstrs = 字符列表.一一对应. 
  (if (and fns ostrs nstrs) 
    (progn 
      (setq 
 ff  '("#" "," "[" "]" "@" "*" "?" "~" ) ;避免字符和 字符过滤符混淆造成错误. 
 fil (apply 'strcat 
     (mapcar '(lambda (x / strs `) 
         (setq strs (vl-string->list x) 
        ` (ascii "`")) 
         (setq x (vl-list->string(apply 'append 
          (mapcar '(lambda(y)(if (member (chr y) ff)(list ` y) 
          (list y)))strs)) 
          )) 
         (strcat "*" x "*,")) ostrs) 
     ) 
      ) 
      (princ "\n 正在处理文件:") 
      (mapcar 
 '(lambda (fname) 
    (xo-infdo 
      fname 
      vcol 
      '(lambda (x) 
  (if 
    (and (vlax-property-available-p x 'textstring) 
         (wcmatch (setq str (vla-get-textstring x)) fil) 
    ) 
     (vla-put-textstring 
       x 
       (x$subs nstrs ostrs str) 
     ) 
  ) 
       ) 
    ) 
  ) 
 fns 
      ) 
    ) 
  ) 
  ;(mapcar 'print fns) 
  (princ) 
) 
;| (xo-infdo fname vcol func) = dbx技术对文件内集合进行操作 
参数: fname = cad文件(*.dwg格式) 
      vcol = 集合列表.如'(modelspace paperspace) 
      func = 操作函数名, 如: 'xx 或 '(lambda(x)....) 
             操作函数必须含一个变量(集合内实体). 如: (defun xx (x) ...) 
返回: 分别操作的表(表内容根据函数来定义). 
说明: vcol可以是如下集合: 
All Collection Objects(所有的集合实体:) 
Blocks   Dictionaries  DimStyles  funccuments  FileDependencies  Groups 
Hyperlinks  Layers  Linetypes  MenuBar  MenuGroups  ModelSpace   
PaperSpace  PlotConfigurations  PopupMenu  PopupMenus   
RegisteredApplications  SelectionSets  TextStyles  Toolbar 
Toolbars  UCSs  Viewports  Views 
|; 
(defun xo-infdo (fname vcol func / doc CNAME RET VERKEY DOC E ENT I REGKEY SS SSBLK 
   ATTS BLKS CDOC CNAMES DOCS llays) 
  (setq fname (strcase fname)) 
  (print fname) 
  (setq cdoc(vla-get-activedocument(vlax-get-acad-object))) 
  (setq cname (strcat(getvar "DWGPREFIX")(getvar "DWGNAME"))) ;; 当前文件名. 
  (vlax-for x (vlax-get(vlax-get-acad-object) 'documents) (setq docs (cons x docs))) 
  (setq cnames (mapcar '(lambda(x)(strcase (strcat (vla-get-path x) "\" (vla-get-name x)))) docs)) 
  ;(setq fname cname) 
  (if (member fname cnames) 
    (progn 
      ;; v1.5加入,锁定图层解锁.>>可放入为xo-infdo的参数.后补>> 
      (evaldo cdoc (vla-get-layers cdoc) 
       '(lambda(x)(if(= :vlax-true (vla-get-lock x)) 
      (progn(setq llays(cons x llays)) 
            (vla-put-lock x :vlax-false) 
        ) 
      ) 
   ) 
      ) 
      (evalcur (setq doc (nth (-(length docs)(length(member fname cnames))) docs)));处理当前文件,evalcur函数 
      (mapcar '(lambda(x)(vla-put-lock x :vlax-true)) llays) 
    ) 
    ;; 处理非当前文件. 
    (progn 
      (setq verkey  (if (> (atoi (getvar "AcadVer")) 15) 
        ".16" 
        "" 
      ) 
     *DBXDOC (vla-getinterfaceobject 
        (vlax-get-acad-object) 
        (strcat "ObjectDBX.AxDbDocument" verkey) 
      ) 
      ) 
      (vla-open *dbxdoc fname :vlax-false)      ;open 
      ;; v1.5加入,锁定图层解锁.>>可放入为xo-infdo的参数.后补>> 
      (evaldo *dbxdoc (vla-get-layers *dbxdoc) 
       '(lambda(x)(if(= :vlax-true (vla-get-lock x)) 
      (progn(setq llays(cons x llays)) 
            (vla-put-lock x :vlax-false) 
        ) 
      ) 
   ) 
      ) 
      ;; 
      (setq 
 ret (mapcar '(lambda (x) 
         (evaldo *dbxdoc (vlax-get *dbxdoc x) func) ;evaldo 函数 
       ) 
      vcol 
     ) 
      );(vlax-dump-object *dbxdoc T) 
      ;; v1.5加入,锁定图层解锁恢复>> 
      (mapcar '(lambda(x)(vla-put-lock x :vlax-true)) llays) 
      ;; 
      (vlax-invoke *dbxdoc 'saveas fname) 
      (vlax-release-object *dbxdoc) 
    ) 
  ) 
  ret 
) 
;;; 处理非打开文件. 
  (defun evaldo (doc obj func) 
    (vlax-map-collection 
      obj 
      '(lambda (x) 
  (if (vlax-property-available-p x 'count) 
    (evaldo doc x func) 
    (if (vlax-method-applicable-p x 'GetAttributes) 
      (mapcar '(lambda (y) ((eval func) y)) 
       (vlax-invoke x 'GetAttributes) 
      ) 
      ((eval func) x) 
    ) 
  ) 
       ) 
    ) 
  ) 
;;;*当前文件* ;(setq doc cdoc) ;(setq cnames nil) 
  (defun evalcur (doc / ATTS BLKS E ENT I REGKEY SS SSBLK X Y) 
    (if (equal doc cdoc) 
      (princ "(*当前文件*)") 
      (princ "(*已打开文件*)") 
    ) 
    ;;激活已打开文件..->>>>>bug, vlisp先天缺陷? 不能跨文档 
    (vla-Activate doc) 
    ;;处理*text 
    (if (setq i  -1 
       ss (ssget "x" (list (cons 0 "*TEXT") (cons 1 fil))) 
 ) 
      (while (setq i (1+ i) 
     e (ssname ss i) 
      ) 
 (setq ent (entget e)) 
 (entmod 
   (subst (cons 1 (x$subs nstrs ostrs (cdr (assoc 1 ent)))) 
   (assoc 1 ent) 
   ent 
   ) 
 ) 
      ) 
    ) 
    (princ "\n .......文字处理完毕.") 
    ;;处理 块内文字. 
    (if (setq blks (vla-get-blocks doc)) 
      (vlax-for x blks         ;(vla-item (vla-get-blocks doc) 1) 
 (setq regkey nil) 
 (vlax-for y x 
   (if (and (wcmatch (vla-get-objectname y) "AcDb*Text") 
     (wcmatch (vla-get-textstring y) fil) 
       ) 
     (progn (vla-put-textstring 
       y 
       (x$subs nstrs ostrs (vla-get-textstring y)) 
     ) 
     (setq regkey T) 
     ) 
   ) 
 ) 
 (if (and regkey (< 0 (vla-get-count x))) 
           ;(print (assoc 2 (entget(vlax-vla-object->ename x)))) 
   (if (setq i -1 
      ssblk 
       (ssget 
         "x" 
         (list (cons 0 "INSERT") (cons 2 (vla-get-name x))) 
       ) 
       ) 
     (while (setq i (1+ i) 
    e (ssname ssblk i) 
     ) 
       (entupd e) 
     ) 
   ) 
 ) 
      ) 
    ) 
    (princ "\n .......块内文字处理完毕.") 
    ;;处理块属性. 
    (if 
      (setq i  -1 
     ss (ssget "x" (list (cons 0 "INSERT") (cons 66 1))) 
      ) 
       (while (setq i (1+ i) 
      e (ssname ss i) 
       ) 
  (setq atts (vlax-invoke (vlax-ename->vla-object e) 'getattributes)) 
  (mapcar '(lambda (x / y)       ;(setq x (cadr atts)) 
      (if (wcmatch (setq y (vla-get-textstring x)) fil) 
        (vla-put-textstring x (x$subs nstrs ostrs y)) 
      ) 
    ) 
   atts 
  ) 
       ) 
    ) 
    (princ "\n .......块属性处理完毕.") 
    ;;恢复激活原当前文件. 
    (vla-Activate cdoc) 
    doc 
  ) 
;; (qf_getFolder "");; 取目录 by 秋枫. 
(defun qf_getFolder (msg / WinShell shFolder path catchit) 
  (vl-load-com) 
  (setq winshell (vlax-create-object "Shell.Application")); (vlax-dump-object winshell T) 
  (setq shFolder (vlax-invoke-method WinShell 'BrowseForFolder 0 msg 1)) 
  (setq 
    catchit (vl-catch-all-apply 
       '(lambda () 
   (setq shFolder (vlax-get-property shFolder 'self)) 
   (setq path (vlax-get-property shFolder 'path)) 
        ) 
     ) 
  ) 
  (if (vl-catch-all-error-p catchit) 
    nil 
    path 
  ) 
) 
;| (xo-getfiles dir) = 调用win系统对话框选取多个文件(2007)，返回文件列表.----by lxx.2007.4 v2.0 
参数: dir = 初始目录 
返回: 含路径的文件名列表. 
说明: for Windows XP / winnt2k 
测试: 
(xo-getfiles "c:\\temp\") 
 -> ("C:\\temp\\测试新块1.dwg" "C:\\temp\\测试新块2.dwg")  ;; 多选. 
 -> ("C:\\temp\\测试新块1.dwg") ;; 单选. 
|; 
(defun xo-getfiles (Dir / x r y lst fn$ DLGPATH I PATH) 
  (vl-load-com) 
  (if (and (not (setq x (vlax-create-object "MSComDlg.CommonDialog"))) 
    (setq dlgpath (findfile "Comdlg32.inf")) 
      ) 
    (startapp (strcat dlgpath)) 
  ) 
  (if (or (setq x (vlax-create-object "UserAccounts.CommonDialog")) 
   (setq y (vlax-create-object "MSComDlg.CommonDialog") 
  x y 
   ) 
      ) 
    (progn 
      (vlax-put-property 
 x 
 'Filter 
 "cad文件|*.dwg;*.dxf|cad程序|*.lsp;*.arx;*.fas;*.vlx|位图|*.jpg;*.bmp;*.png;*.gif|所有类型|*.*" 
      ) 
           ;(vlax-put-property x 'FilterIndex 1) 
      (if y 
 (vlax-put-property x "MaxFileSize" 10000) 
      ) 
      (vlax-put-property x 'Flags 512)       ; 设置多选文件选项, 如不需要则删除此行 
      (vlax-put-property x 'InitialDir Dir) 
      (setq r (vlax-invoke-method x 'ShowOpen)) 
      (if (= 0 r) 
 nil 
 (setq fn$ (vlax-get-property x 'FileName)) 
      ) 
    ) 
  ) 
  (setq lst nil) 
  (if (/= "" fn$) 
    (cond 
      ((vl-string-search " " fn$) 
       (while (setq i (vl-string-position (ascii " ") fn$)) 
  (setq lst (cons (substr fn$ 1 i) lst) 
        fn$ (substr fn$ (+ 2 i)) 
  ) 
       ) 
       (if (/= "" fn$) 
  (setq lst (cons fn$ lst)) 
       ) 
       (setq lst  (reverse lst) 
      path (car lst) 
       ) 
       (mapcar '(lambda (x) (strcat path x)) (cdr lst)) 
      ) 
      (T (list fn$)) 
    ) 
    nil 
  ) 
) 
;|(x$sub 新$ 旧$ 字符串) = 字符串替换-------------------------------lxx.2004.2 
(x$sub " " "-" "32-33-0.01-哈哈") -> "32 33 0.01 哈哈" 
|; 
(defun x$sub (n$ o$ str / n) 
  (setq n 0) 
  (while (setq n (vl-string-search o$ str n)) 
   (setq str (vl-string-subst n$ o$ str n)) 
   (setq n (+ n (strlen n$))) 
  )str 
) 
;|(x$subs 新$表 旧$表 字符串) = 字符串多项替换--lxx.2007.4 
功能:替换字符串中符合替换表的多项字符. 
测试: (x$subs '("aa" "1") '("bb" "2") "bbc-bb2132") ->"aac-aa1131" 
|; 
(defun x$subs (nstrs ostrs str) 
  (mapcar '(lambda(x y)(setq str (x$sub x y str))) nstrs ostrs) 
  str 
) 
;;====================================================================;; 
(princ "\n mcht = dbx不打开目录文件替换字符(支持多重块)v1.5-----by lxx.2007.4") 
(princ) 
;; dbx技术＝不打开dwg，修改指定路径下多个文件内的文字 by lzh741206 
;; [url=http://xdcad.net/forum/showthread.php?s=&postid=1211267#post1211267]http://xdcad.net/forum/showthread.php?s=&postid=1211267#post1211267[/url] 
;| 
Sub MyReplace(PathName As String, str1 As String, str2 As String) 
    Dim pFile As String 
    Dim ObjDbx As Object 
    pFile = Dir(PathName & "*.dwg") 
    Set ObjDbx = GetInterfaceObject("ObjectDBX.AxDbDocument.16") 
    '2002版本下改为Set ObjDbx = GetInterfaceObject("ObjectDBX.AxDbDocument.1") 
    Do While pFile <> "" 
        ObjDbx.Open PathName & pFile 
        For Each i In ObjDbx.ModelSpace 
            If i.ObjectName = "AcDbText" Or i.ObjectName = "AcDbMText" Then 
                i.textString = Replace(i.textString, str1, str2) 
            End If 
        Next i 
        ObjDbx.SaveAs PathName & pFile 
        pFile = Dir() 
    Loop 
End Sub 
|; 
;| 
vl-directory-files 函数 
语法 
   (vl-directory-files  [directory pattern directories]) 
 
功能 
   列出给定目录中的所有文件。 
 
说明 
    1）参数 directory 为字符串，指定要收集文件的目录。若未指定该参数或参数为 nil，那么vl-directory-files 使用当前目录。 
    2）参数 pattern 为字符串，包含文件名的 DOS 方式。如果未指定该参数或参数为 nil，vl-directory-files 假定为 "*.*"。 
    3）directories 为整数型，指定返回的表中是否包含路径名。可以指定下列值之一： 
-1  仅列出目录。 
0   列出文件和目录（缺省值）。 
1   仅列出文件。 
 
返回值： 
 文件和路径列表。若没有符合指定方式的文件，则返回 nil。 
 
样例： 
1）_$ (vl-directory-files "c:/acadwin" "acad*.exe") 
("ACAD.EXE" "ACADAPP.EXE" "ACADL.EXE" "ACADPS.EXE") 
2）_$ (vl-directory-files "d:/acadwin" nil -1) 
("." ".." "SUPPORT" "SAMPLE" "ADS" "FONTS" "IGESFONT" "SOURCE" "ASE") 
3）_$ (vl-directory-files "d:/acad13c4" nil -1) 
("." ".." "WIN" "COM" "DOS") 
GetInterfaceObject 方法 
Application 对象   
一个 <a href="http://bbs.mjtd.com/forum-41-1.html" target="_blank" class="relatedlink">AutoCAD</a> 应用程序实例。 
VBA 类别名: 
 AcadApplication 
创建方法: 
 对于VB: 
GetObject("AutoCAD.Application.16") 
CreateObject("AutoCAD.Application.16") 
对于AutoCAD VBA: 
不适用。应用程序始终可用()。 
访问途径: 
 Application 属性 
与Application对象相关联的属性主应用程序窗口的特性。这些方法控制当前加载的外部应用程序与接口对象的加载或列表。 
活动的文档 (AutoCAD 图形) 可使用 ActiveDocument 属性来访问。 
要从VBA访问Application 对象，可使用 Thisdrawing.Application。要从VB中访问 Application 对象，可使用 Visual Basic 
函数 GetObject 或 CreateObject。 
如果 AutoCAD 正在运行，GetObject 函数将会得到当前的 AutoCAD Application 对象。当同时运行了多个 AutoCAD 进程， 
GetObject 函数返回Windows 运行对象表中第一个 AutoCAD 实例。请查阅 Microsoft Visual Basic 文档的 
Running Object Table (ROT) 和 GetObject 函数 (以获得确认GetObject返回操作的详细信息)。 
使用版本相关的 ProgIDs。如果 CreateObject 或 GetObject 函数使用了版本相关的 ProgID，更改函数以适用版本相关 ProgID。例如， 
用户可更改 CreateObject ("AutoCAD.Application") 为 CreateObject ("AutoCAD.Application.16")来调用AutoCAD 2004。 
Application 对象同时也是 ActiveX 接口的 Global 对象。也就是说 Application 对象的所有方法和属性，都可以用于全局名称空间。

革天明 · 发表于 2013-4-2 09:24

(defun c:test9()
(setvar "pdmode" 34)
(setq myssss (ssget "x" '((0 . "POINT"))))
(command "erase" myssss "")
)
请教如何不打开图纸实现此函数的功能？我要处理的约有100张图纸，想把这些图纸中的point删除

zhuquanmao · 发表于 2012-11-20 00:06

teykmcqh 发表于 2012-11-19 17:13
我最后还是用块插入方式暂时解决的，不知这位高手有什么思路，其实这个问题归根还是在不打开的情况下多文 ...

不同的图若含相同的块插入到同一张图中会是后面文件中的块儿失效
可以用参照绑定的方法解决这个问题只是块名称发生了变化
插入的图形获得其长度和高度后然后进行排列

yjc · 发表于 2011-5-22 12:38

狂刀研究的比较广，比较透，比较深。厉害。学习的榜样！

redcat · 发表于 2011-5-11 12:46

回复狂刀lxx 的帖子

老刀终于把压箱底都翻出了

yxl88168 · 发表于 2011-5-11 17:45

支持狂刀，我顶

yshf · 发表于 2011-5-11 23:22

是啊，你的程序太好了，支持楼主！

xxzwtr · 发表于 2011-5-12 00:30

强人一个，

tjuzkj · 发表于 2011-5-13 09:01

支持狂刀,厉害！

langjs · 发表于 2011-5-13 19:06

学习学习，好东西

cnks · 发表于 2011-5-13 19:11

箱子东西太多了放不下了啊

CAD83 · 发表于 2011-5-13 22:26

无聊多好啊，狂刀出手，见神杀神，明天再好无聊下啦，呵呵

teykmcqh · 发表于 2011-5-14 16:06

在高手面前，永远只有学习的份，谢谢支持源码！
上前我提过一个问题：如何合并多个CAD图纸为一个文件，就是通过选择目录，把许多个CAD图纸按文件名的排列顺序，呈矩阵分布合并在一张图纸中，谁能帮解决一下吗？
说明两点：一是不用块插入方式，因为块插入炸开后，同时把图纸中的图块也炸开了；二是这许多个CAD图纸都是程序生成的，具有完全相同的格式，只是内容有些不同，譬如钻孔柱状图。

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

[源码] 继续无聊，源码 dbx不打开目录文件替换字符(支持多重块)

点评

本帖子中包含更多资源