spp_wall 发表于 2014-7-23 11:35 static/image/common/back.gif
怎么08也不能用！！！！！
不好意思,ffg-getfolder函数复制少了一段代码.现在可以用了.
clinber 发表于 2015-2-10 15:11 static/image/common/back.gif
命令: (LOAD "C:/Users/Administrator/Desktop/xl/参照.lsp") ; 错误: 输入的列表有缺陷
重要事情说三遍,不好意思,ffg-getfolder函数复制少了一段代码.现在可以用了.
wudechao 发表于 2015-11-13 12:58 static/image/common/back.gif
重要事情说三遍,不好意思,ffg-getfolder函数复制少了一段代码.现在可以用了.
谢谢大神啊
wudechao 发表于 2015-11-13 12:58 static/image/common/back.gif
重要事情说三遍,不好意思,ffg-getfolder函数复制少了一段代码.现在可以用了.
谢谢楼主我最近也搞了一个 不过貌似没你这个好;;;****************************************
;;; No.1外部参照绝对路径改为相对路径
;;;****************************************
;;-------------=={ Full Path to Relative Path }==-------------;;
;; ;;
;;Converts a Full XRef path to a Relative Path. ;;
;;------------------------------------------------------------;;
;;Author: Lee Mac, Copyright ? 2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;;Arguments: ;;
;;dir- Directory of the Drawing in which the Xref resides ;;
;;path - Full Xref Path ;;
;;------------------------------------------------------------;;
;;Returns:Relative XRef Path ;;
;;------------------------------------------------------------;;
(defun LM:XRef:Full->Relative ( dir path / p q )
(setq dir (vl-string-right-trim "\\" dir))
(cond
( (and
(setq p (vl-string-position 58dir))
(setq q (vl-string-position 58 path))
(not (eq (strcase (substr dir 1 p)) (strcase (substr path 1 q))))
)
path
)
( (and
(setq p (vl-string-position 92dir))
(setq q (vl-string-position 92 path))
(eq (strcase (substr dir 1 p)) (strcase (substr path 1 q)))
)
(LM:Xref:Full->Relative (substr dir (+ 2 p)) (substr path (+ 2 q)))
)
( (and
(setq q (vl-string-position 92 path))
(eq (strcase dir) (strcase (substr path 1 q)))
)
(strcat ".\\" (substr path (+ 2 q)))
)
( (eq "" dir)
path
)
( (setq p (vl-string-position 92 dir))
(LM:Xref:Full->Relative (substr dir (+ 2 p)) (strcat "..\\" path))
)
( (LM:Xref:Full->Relative "" (strcat "..\\" path)))
)
)
;;-------------=={ Relative Path to Full Path }==-------------;;
;; ;;
;;Converts a Relative XRef path to a Full Path. ;;
;;------------------------------------------------------------;;
;;Author: Lee Mac, Copyright ? 2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;;Arguments: ;;
;;dir- Directory of the Drawing in which the Xref resides ;;
;;path - Relative Xref Path ;;
;;------------------------------------------------------------;;
;;Returns:Full XRef Path ;;
;;------------------------------------------------------------;;
(defun LM:XRef:Relative->Full ( dir path )
(setq dir (vl-string-right-trim "\\" dir))
(cond
( (eq ".." (substr path 1 2))
(LM:XRef:Relative->Full
(substr dir 1 (vl-string-position 92 dir nil t))
(substr path 4)
)
)
( (eq "." (substr path 1 1))
(strcat dir (substr path 2))
)
( (strcat dir "\\" path))
)
)
(defun C:ChXrefPath (/ refblkent refblkfile refblkfilenew refblkfileold refblkname refblknametemp refblkpath refblkpathtemp reffilepath refnamenew)
(vl-load-com)
(setvar "cmdecho" 0)
(setq refFilePath (getvar "DWGPREFIX")) ; 读取当前图纸路径
(while (setq refBlkEnt (tblnext "Block" (not refBlkEnt)))
(setq refBlkName (cdr (assoc 2 refBlkEnt)))
(setq refBlkFile (cdr (assoc 1 refBlkEnt)))
(if (and refBlkFile (/= refBlkFile ""))
(progn
(setq refBlkNameTemp (vl-filename-base refBLKFile))
(setq refBlkPath (vl-filename-directory refBLKFile))
(if (/= refBlkNameTemp refBlkName)
(if (= 46 (ascii refBlkPath))
(progn
(setq refBlkPathTemp (LM:XRef:Relative->Full refFilePath refBlkPath))
(setq refBlkFileOld (strcat refBlkPathTemp "\\" refBlkNameTemp ".dwg"))
(setq refBlkFileNew (strcat refBlkPathTemp "\\" refBlkName ".dwg"))
(vl-file-rename refBlkFileOld refBlkFileNew)
(setq refNameNew (LM:XRef:Full->Relative refFilePath refBlkFileNew))
(print refNameNew)
(if (findfile refNameNew)
(progn
(vl-cmdf "-xRef" "P" refBlkName refNameNew)
(princ (strcat "\n " refBlkName " 修改了"))
(princ)
)
);end_if
)
(progn
(setq refBlkFileNew (strcat refBlkPath "\\" refBlkName ".dwg"))
(vl-file-rename refBlkFile refBlkFileNew)
(setq refNameNew (LM:XRef:Full->Relative refFilePath refBlkFileNew))
(print refNameNew)
(if (findfile refNameNew)
(progn
(vl-cmdf "-xRef" "P" refBlkName refNameNew)
(princ (strcat "\n " refBlkName " 修改了"))
(princ)
)
);end_if
);end_progn
)
(if (/= 46 (ascii refBlkPath))
(progn
(setq refNameNew (LM:XRef:Full->Relative refFilePath refBlkFile))
(print refNameNew)
(if (findfile refNameNew)
(progn
(vl-cmdf "-xRef" "P" refBlkName refNameNew)
(princ (strcat "\n " refBlkName " 修改了"))
(princ)
)
);end_if
);end_progn
)
)
)
);end_if
);end_while
(princ)
)
最好能提供对话框输入，对话框默认输入为：.\\或者..\\
这个功能不错，得顶起来。
这个功能不错，得顶起来。
本帖最后由 wudechao 于 2016-6-21 23:57 编辑
;20160621修改版本
(defun c:xfx (/ *error* ss ffg k path files path2 path3 m m2 n n2 total tst temp xpath i obj)
(vl-load-com)
(defun ffg-getfolder (msg startpath / winshell shfolder ffg path1 catchit)
(setq winshell (vlax-create-object "Shell.Application"))
(setq shfolder (vlax-invoke-method winshell 'browseforfolder 0 msg 1 startpath))
(setq catchit (vl-catch-all-apply '(lambda ()
(setq shfolder (vlax-get-property shfolder 'self))
(setq path1 (vlax-get-property shfolder 'path))
)
)
)
(if (vl-catch-all-error-p catchit)
nil
path1
)
)
(setvar "cmdecho" 0);主程序
(defun *error* (msg)
(if (> total 0)
(prompt (strcat "\n总共有 \" " (itoa total) " \"个参照物体路径改为相对路径."))
(prompt (strcat "\n未找到合适的参照物体路径!"))
);_ 结束if
(setvar "cmdecho" 1)
(princ)
);_结束error
(setq tst nil
m 0
ss (ssget "x" '((0 . "insert")))
)
(setq ffg (getvar "dwgprefix"));获取当前文件路径,
(setq k (vl-string-position 92 ffg 3 nil));查找第二个"\",减少选择路径对话框展开层数(删除硬盘符号和第一级目录)
(setq path (ffg-getfolder "请选择参照文件所在的目录：" (substr ffg 1 k)));获取参照目录
(setq files (vl-directory-files path "*.dwg" 1));列出目录下所有文件
(setq m (vl-string-mismatch ffg path 0 0));前面有多少个相同的字符
(if (>= m (strlen ffg))
(progn
(setq tst t)
);_ 结束prgon
(progn;参照文件路径位于该文件父目录之上(就是参照路径比文件所在路径还短)
(setq n 0
n2 0
path3 ""
);参照路径前面相同部分
(setq path2 (substr ffg (1+ m)));删除参照路径前面相同部分
(setq m2 (strlen path2))
(repeat m2
(setq temp (ascii (substr path2 (- m2 n) 1)))
(if (= temp 92)
(setq n2 (+ 1 n2))
);_ 结束if
(setq n (+ 1 n))
);_ 结束repeat
(repeat n2
(setq path3 (strcat ".." (chr 92) path3))
);_ 结束repeat
);_ 结束progn
);_ 结束if
(setq xpath (substr path (1+ m)));删除参照前面的绝对路径,
(setq i 0
total 0
)
(repeat (sslength ss)
(setq obj (vla-item (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))) (cdr (assoc 2 (entget
(ssname ss i)
)
)
)
)
)
(if (and
(= (vla-get-isxref obj) :vlax-true)
(member (strcat (vla-get-name obj) ".dwg") files);参照图块是否在文件列表
)
(progn
(if (= xpath "")
(progn
(vla-put-path obj (strcat "." (chr 92) xpath (vla-get-name obj) ".dwg"))
);_ 结束progn
(progn
(if tst
(vla-put-path obj (strcat "." (chr 92) xpath (chr 92) (vla-get-name obj) ".dwg"));目录前面添加".\",目录后面添加"\"
(vla-put-path obj (strcat path3 xpath (chr 92) (vla-get-name obj) ".dwg"));
);_ 结束if
);_ 结束progn
);_ 结束if
(setq total (+ 1 total))
);_ 结束progn
);_ 结束if
(setq i (1+ i))
);_ 结束repeat
(setvar "cmdecho" 0)
(command "-xref" "r" "*")
(if (> total 0)
(prompt (strcat "\n总共有 \" " (itoa total) " \"个参照物体路径改为相对路径."))
(prompt (strcat "\n未找到合适的参照物体路径!"))
);_ 结束if
(setvar "cmdecho" 1)
(princ)
);_ 结束defun
wudechao 发表于 2016-6-21 22:57
;20160621修改版本
(defun c:xfx (/ *error* ss ffg k path files path2 path3 m m2 n n2 total tst temp...
这个版本测试了，完全OK。上一版改了之后重新打开就不能找到外部参照了。
2个版本各有用处，都不错。