继续无聊，源码 dbx不打开目录文件替换字符(支持多重块)
注：本程序包含多个有用函数，及相关知识说明部分参考了 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 DictionariesDimStylesfunccumentsFileDependenciesGroups
HyperlinksLayersLinetypesMenuBarMenuGroupsModelSpace
PaperSpacePlotConfigurationsPopupMenuPopupMenus
RegisteredApplicationsSelectionSetsTextStylesToolbar
ToolbarsUCSsViewportsViews
|;
(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
;; http://xdcad.net/forum/showthread.php?s=&postid=1211267#post1211267
;|
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)
功能
列出给定目录中的所有文件。
说明
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 对象的所有方法和属性，都可以用于全局名称空间。
(defun c:test9()
(setvar "pdmode" 34)
(setq myssss (ssget "x" '((0 . "POINT"))))
(command "erase" myssss "")
)
请教如何不打开图纸实现此函数的功能？我要处理的约有100张图纸，想把这些图纸中的point删除 teykmcqh 发表于 2012-11-19 17:13 static/image/common/back.gif
我最后还是用块插入方式暂时解决的，不知这位高手有什么思路，其实这个问题归根还是在不打开的情况下多文 ...
不同的图若含相同的块 插入到同一张图中会是后面文件中的块儿失效
可以用参照 绑定的方法 解决这个问题 只是块名称发生了变化
插入的图形获得其长度 和 高度后 然后进行排列
狂刀研究的比较广，比较透，比较深。厉害。学习的榜样！ 回复 狂刀lxx 的帖子
老刀终于把压箱底都翻出了 支持狂刀，我顶 是啊，你的程序太好了，支持楼主！ 强人一个，
支持狂刀,厉害！ 学习学习，好东西 箱子东西太多了放不下了啊 无聊多好啊，狂刀出手，见神杀神，明天再好无聊下啦，呵呵 在高手面前，永远只有学习的份，谢谢支持源码！
上前我提过一个问题：如何合并多个CAD图纸为一个文件，就是通过选择目录，把许多个CAD图纸按文件名的排列顺序，呈矩阵分布合并在一张图纸中，谁能帮解决一下吗？
说明两点：一是不用块插入方式，因为块插入炸开后，同时把图纸中的图块也炸开了；二是这许多个CAD图纸都是程序生成的，具有完全相同的格式，只是内容有些不同，譬如钻孔柱状图。