把参照绝对路径改为相对路径

wudechao · 发表于 2014-5-23 15:42:07

本帖最后由 wudechao 于 2015-11-13 12:42 编辑

;这几天修改别人的图,被参照图的绝对路径搞的很烦,一怒之下,写了一个改参照绝对路径为相对路径的lisp,还不够完满,运行效率不高,望高手帮修改指教.
(defun c:xfx (/ ss ffg k path files path2 path3 tmq 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);主程序
  (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 ""
   tmq (substr path 1 m)
   );参照路径前面相同部分
   (setq path2 (vl-string-left-trim tmq ffg));删除参照路径前面相同部分
   (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
  (if tst
(setq xpath (vl-string-left-trim ffg path));删除参照前面的绝对路径,
(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)
(vl-position (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
  (command "-xref" "r" "*")
  (if (> total 0)
(prompt (strcat "\n总共有 \" " (itoa total) " \"个参照物体路径改为相对路径."))
(prompt (strcat "\n未找到合适的参照物体路径!"))
  )
  (setvar "cmdecho" 1)
  (princ)
);_ 结束defun

wudechao · 发表于 2014-5-23 20:40:23

参照有时候很方便的，比如签名，出图日期，几十张图纸，改一个文件就可以搞定。

flytoday · 发表于 2014-5-23 18:41:31

本帖最后由 flytoday 于 2014-5-23 18:42 编辑

最讨厌设计院的图插入参照啦………你说没事搞布局与参照干嘛………烦不烦啊…………给别人电子档时候参照没给打开缺这缺那……有时让人打印出来没内容………电子就是让人看滴舒服………别跟哥讲版权别跟哥讲院里不让给…借口很多…………电子图用于施工、预算比较方便点…给人方便给已方便………………希望那个什么什么设计别参照啦………别用布局啦

moshouhot · 发表于 2022-10-26 18:52:16

;改一下，增加如果参照存在，只改路径，增加支持父目录，子目录，孙目录。。。。。。。
(defun c:WBCZ (/ file scale1 pt0 i total ss filename ent obj elist blkdef)
(vl-load-com)
(defun ffg-path-xiangdui (path-file / tst m m2 ffg n n2 path3 path2 temp xpath path-xiangdui)
 (setq tst nil
m 0
 )
 (setq ffg (getvar "dwgprefix"))
 (setq m (vl-string-mismatch ffg path-file 0 0))
 (if (>= m (strlen ffg))
(progn
(setq tst t)
)
(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))
 )
 (setq n (+ 1 n))
)
(repeat n2
 (setq path3 (strcat ".." (chr 92) path3))
)
)
 )
 (setq xpath (substr path-file (1+ m)))
 (if (= xpath "")
(progn
(setq path-xiangdui (strcat "." (chr 92) xpath))
)
(progn
(if tst
 (setq path-xiangdui (strcat "." (chr 92) xpath))
 (setq path-xiangdui (strcat path3 xpath))
)
)
 )
 path-xiangdui
)
(setvar "cmdecho" 0)
(if (setq file (getfiled "选择参照文件" (strcat (getvar "dwgprefix") "\\") "dwg" 16))
 (progn
(if (= (tblobjname "block" (vl-filename-base file)) nil)
(progn
 (setq scale1 (getvar "userr4"))
 (if (equal scale1 0 0.0001)
 (progn
 (setq scale1 1.00)
 (setvar "userr4" scale1)
 )
 )
 (setq scale1 (getreal (strcat "\n请输入图形放大系数 < " (rtos scale1 2 2) " >:"))
 scale1 (if scale1
 scale1
 (getvar "userr4")
 )
 )
 (setq pt0 (getpoint "\n指定插入点:"))
)
(progn
 (setq i 0
 total 0
 )
 (setq ss (ssget "x" '((0 . "insert"))))
 (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-name obj) (vl-filename-base file))
 (= (vla-get-isxref obj) :vlax-true)
 )
 (progn
(setq filename (vla-get-name obj))
(vla-put-path obj (ffg-path-xiangdui file))
(setq total (1+ total))
 )
 )
 (setq i (1+ i))
 )
 (prompt (strcat "\n参照已经存在，仅仅修改路径。修改了 " (itoa total) " 个名称为\" " filename " \"的参照块路径."))
)
)
 )
)
(if pt0
 (progn
(command "-xref" "a" file "s" scale1 "r" "0.0" pt0)
(setq ent (entget (ssname (ssget "L" '((0 . "insert"))) 0)))
(setq obj (vla-item (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))) (cdr (assoc 2 ent))))
(setq elist (entget (tblobjname "block" (cdr (assoc 2 ent)))))
(setq blkdef (vlax-ename->vla-object (cdr (assoc 330 elist))))
(vla-put-path blkdef (ffg-path-xiangdui file))
 )
)
(command "_xref" "r" "*")
(setvar "cmdecho" 1)
(princ)
)

gaics · 发表于 2014-5-24 10:03:16

支持一下！

BB建筑师 · 发表于 2014-5-24 13:53:28

傻才不用参照---

lingduwx · 发表于 2014-5-29 22:37:11

我也到过，别人发的图，里面的外部参照就不发，到处缺图，烦

doro · 发表于 2014-5-30 09:12:14

很实用

clinber · 发表于 2014-5-30 10:59:42

奇怪需要其他的系统函数还是什么情况为啥我cad2014加载不了呢

mj0000 · 发表于 2014-5-30 13:11:31

这么多代码啊，看看下面这个，论坛里面找来的，具体谁的忘了，时间有点久了

;;;;参照图块路径改为“相对路径” 且自动重载XREF
(defun C:Tools-BLK-XrefPathAutoLoad (/ ssg xpath i obj enl elist blkdef path n)
(setq ssg (ssget "x" '((0 . "insert"))))
(setq XPath (getvar "dwgprefix")) ;_取得当前文档路径
(setq i 0)
(setq n 0)
(if ssg
(repeat (sslength ssg)
(setq obj (vla-item (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))) (cdr (assoc 2 (setq enl (entget (ssname ssg i)))))))
(if (= (vla-get-isxref obj) :vlax-true) ;_判断给定的图块是否为XRef图块
(progn
;;(vla-put-path obj (strcat xpath (vla-get-name obj) ".dwg"));_参照图块路径改为“绝对路径
(setq elist (entget (tblobjname "block" (cdr (assoc 2 enl))))) ;_获取参照图块的图元表
(setq blkdef (vlax-ename->vla-object (cdr (assoc 330 elist))))
(setq path (vla-get-path blkdef)) ;_取得外部参照的路径
(setq path (vl-filename-base path)) ;_去掉文件的路径和扩展名，返回文件的名称
(vla-put-path blkdef (strcat ".\" path ".dwg")) ;_参照图块路径改为“相对路径”
(setq n (1+ n))
)
)
(setq i (1+ i))
)
)
(if (> n 0)
(progn
(command "_xref" "r" "*")
(princ "\n**** Xref路径已改为“相对路径”****")
)
(princ "\n**** 没有外部参照或外部参照没有加载 ****")
)
(princ)
)

;;;;参照图块路径改为“相对路径” 且 自动重载XREF 
(defun C:Tools-BLK-XrefPathAutoLoad (/ ssg xpath i obj enl elist blkdef path n) 
  (setq ssg (ssget "x" '((0 . "insert")))) 
  (setq XPath (getvar "dwgprefix")) ;_取得当前文档路径 
  (setq i 0) 
  (setq n 0) 
  (if ssg 
    (repeat (sslength ssg) 
      (setq obj (vla-item (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))) (cdr (assoc 2 (setq enl (entget (ssname ssg i))))))) 
      (if (= (vla-get-isxref obj) :vlax-true) ;_判断给定的图块是否为XRef图块 
        (progn 
          ;;(vla-put-path obj (strcat xpath (vla-get-name obj) ".dwg"));_参照图块路径改为“绝对路径 
          (setq elist (entget (tblobjname "block" (cdr (assoc 2 enl))))) ;_获取参照图块的图元表 
          (setq blkdef (vlax-ename->vla-object (cdr (assoc 330 elist)))) 
          (setq path (vla-get-path blkdef)) ;_取得外部参照的路径 
          (setq path (vl-filename-base path)) ;_去掉文件的路径和扩展名，返回文件的名称 
          (vla-put-path blkdef (strcat ".\" path ".dwg")) ;_参照图块路径改为“相对路径” 
    (setq n (1+ n)) 
        ) 
      ) 
      (setq i (1+ i)) 
    ) 
  ) 
  (if (> n 0) 
    (progn 
      (command "_xref" "r" "*") 
      (princ "\n**** Xref路径已改为“相对路径”****") 
    ) 
    (princ "\n**** 没有外部参照 或 外部参照没有加载 ****") 
  ) 
  (princ) 
)

wudechao · 发表于 2014-6-3 18:12:16

mj0000 发表于 2014-5-30 13:11
这么多代码啊，看看下面这个，论坛里面找来的，具体谁的忘了，时间有点久了

你这段代码好象不能修改参照路径更改后的图,比如:原来被参照的文件放在文件根目录下,现在改为子目录下.

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

[源码] 把参照绝对路径改为相对路径

相关帖子