设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › AutoLISP/Visual LISP 编程技术 › 把参照绝对路径改为相对路径
1234下一页
返回列表 发新帖
楼主: wudechao

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

    [复制链接]
wudechao
 楼主| 发表于 2015-11-13 12:47 | 显示全部楼层
spp_wall 发表于 2014-7-23 11:35
怎么08也不能用！！！！！

不好意思,ffg-getfolder函数复制少了一段代码.现在可以用了.
回复 支持 反对

使用道具 举报

wudechao
 楼主| 发表于 2015-11-13 12:58 | 显示全部楼层
clinber 发表于 2015-2-10 15:11
命令: (LOAD "C:/Users/Administrator/Desktop/xl/参照.lsp") ; 错误: 输入的列表有缺陷

重要事情说三遍,不好意思,ffg-getfolder函数复制少了一段代码.现在可以用了.
回复 支持 反对

使用道具 举报

clinber
发表于 2015-11-16 18:34 | 显示全部楼层
wudechao 发表于 2015-11-13 12:58
重要事情说三遍,不好意思,ffg-getfolder函数复制少了一段代码.现在可以用了.

谢谢大神啊
回复 支持 反对

使用道具 举报

clinber
发表于 2015-11-16 18:42 | 显示全部楼层
wudechao 发表于 2015-11-13 12:58
重要事情说三遍,不好意思,ffg-getfolder函数复制少了一段代码.现在可以用了.

谢谢楼主  我最近也搞了一个 不过貌似没你这个好
  2. ;;;****************************************
  3. ;;; No.1  外部参照绝对路径改为相对路径
  4. ;;;****************************************

  6. ;;-------------=={ Full Path to Relative Path }==-------------;;
  7. ;;                                                            ;;
  8. ;;  Converts a Full XRef path to a Relative Path.             ;;
  9. ;;------------------------------------------------------------;;
  10. ;;  Author: Lee Mac, Copyright ? 2011 - www.lee-mac.com       ;;
  11. ;;------------------------------------------------------------;;
  12. ;;  Arguments:                                                ;;
  13. ;;  dir  - Directory of the Drawing in which the Xref resides ;;
  14. ;;  path - Full Xref Path                                     ;;
  15. ;;------------------------------------------------------------;;
  16. ;;  Returns:  Relative XRef Path                              ;;
  17. ;;------------------------------------------------------------;;
  18. (defun LM:XRef:Full->Relative ( dir path / p q )
  19.         (setq dir (vl-string-right-trim "\" dir))
  20.         (cond
  21.                 (   (and
  22.                                         (setq p (vl-string-position 58  dir))
  23.                                         (setq q (vl-string-position 58 path))
  24.                                         (not (eq (strcase (substr dir 1 p)) (strcase (substr path 1 q))))
  25.                                 )
  26.                         path
  27.                 )
  28.                 (   (and
  29.                                         (setq p (vl-string-position 92  dir))
  30.                                         (setq q (vl-string-position 92 path))
  31.                                         (eq (strcase (substr dir 1 p)) (strcase (substr path 1 q)))
  32.                                 )
  33.                         (LM:Xref:Full->Relative (substr dir (+ 2 p)) (substr path (+ 2 q)))
  34.                 )
  35.                 (   (and
  36.                                         (setq q (vl-string-position 92 path))
  37.                                         (eq (strcase dir) (strcase (substr path 1 q)))
  38.                                 )
  39.                         (strcat ".\" (substr path (+ 2 q)))
  40.                 )
  41.                 (   (eq "" dir)
  42.                         path
  43.                 )
  44.                 (   (setq p (vl-string-position 92 dir))
  45.                         (LM:Xref:Full->Relative (substr dir (+ 2 p)) (strcat "..\" path))
  46.                 )
  47.                 (   (LM:Xref:Full->Relative "" (strcat "..\" path)))
  48.         )
  49. )

  51. ;;-------------=={ Relative Path to Full Path }==-------------;;
  52. ;;                                                            ;;
  53. ;;  Converts a Relative XRef path to a Full Path.             ;;
  54. ;;------------------------------------------------------------;;
  55. ;;  Author: Lee Mac, Copyright ? 2011 - www.lee-mac.com       ;;
  56. ;;------------------------------------------------------------;;
  57. ;;  Arguments:                                                ;;
  58. ;;  dir  - Directory of the Drawing in which the Xref resides ;;
  59. ;;  path - Relative Xref Path                                 ;;
  60. ;;------------------------------------------------------------;;
  61. ;;  Returns:  Full XRef Path                                  ;;
  62. ;;------------------------------------------------------------;;

  64. (defun LM:XRef:Relative->Full ( dir path )
  65.         (setq dir (vl-string-right-trim "\" dir))
  66.         (cond
  67.                 (   (eq ".." (substr path 1 2))
  68.                         (LM:XRef:Relative->Full
  69.                                 (substr dir 1 (vl-string-position 92 dir nil t))
  70.                                 (substr path 4)
  71.                         )
  72.                 )
  73.                 (   (eq "." (substr path 1 1))
  74.                         (strcat dir (substr path 2))
  75.                 )
  76.                 (   (strcat dir "\" path))
  77.         )
  78. )

  80. (defun C:ChXrefPath (/ refblkent refblkfile refblkfilenew refblkfileold refblkname refblknametemp refblkpath refblkpathtemp reffilepath refnamenew)
  81.   (vl-load-com)
  82.   (setvar "cmdecho" 0)
  83.   (setq refFilePath (getvar "DWGPREFIX"))     ; 读取当前图纸路径
  84.   (while (setq refBlkEnt (tblnext "Block" (not refBlkEnt)))
  85.     (setq refBlkName (cdr (assoc 2 refBlkEnt)))
  86.                 (setq refBlkFile (cdr (assoc 1 refBlkEnt)))
  87.           (if        (and refBlkFile (/= refBlkFile ""))
  88.                         (progn
  89.                                 (setq refBlkNameTemp (vl-filename-base refBLKFile))
  90.                                 (setq refBlkPath (vl-filename-directory refBLKFile))
  91.                                 (if (/= refBlkNameTemp refBlkName)                               
  92.                                         (if (= 46 (ascii refBlkPath))
  93.                                                 (progn
  94.                                                         (setq refBlkPathTemp (LM:XRef:Relative->Full refFilePath refBlkPath))
  95.                                                         (setq refBlkFileOld (strcat refBlkPathTemp "\" refBlkNameTemp ".dwg"))
  96.                                                         (setq refBlkFileNew (strcat refBlkPathTemp "\" refBlkName ".dwg"))
  97.                                                         (vl-file-rename refBlkFileOld refBlkFileNew)
  98.                                                         (setq refNameNew (LM:XRef:Full->Relative refFilePath refBlkFileNew))
  99.                                                         (print refNameNew)
  100.                                                         (if (findfile refNameNew)
  101.                                                                 (progn
  102.                                                                         (vl-cmdf "-xRef" "P" refBlkName refNameNew)
  103.                                                                         (princ (strcat "\n " refBlkName " 修改了"))
  104.                                                                         (princ)
  105.                                                                 )
  106.                                                         );end_if
  107.                                                 )               
  108.                                                 (progn
  109.                                                         (setq refBlkFileNew (strcat refBlkPath "\" refBlkName ".dwg"))
  110.                                                         (vl-file-rename refBlkFile refBlkFileNew)
  111.                                                         (setq refNameNew (LM:XRef:Full->Relative refFilePath refBlkFileNew))
  112.                                                         (print refNameNew)
  113.                                                         (if (findfile refNameNew)
  114.                                                                 (progn
  115.                                                                         (vl-cmdf "-xRef" "P" refBlkName refNameNew)
  116.                                                                         (princ (strcat "\n " refBlkName " 修改了"))
  117.                                                                         (princ)
  118.                                                                 )
  119.                                                         );end_if
  120.                                                 );end_progn       
  121.                                         )
  122.                                         (if (/= 46 (ascii refBlkPath))
  123.                                                 (progn
  124.                                                         (setq refNameNew (LM:XRef:Full->Relative refFilePath refBlkFile))
  125.                                                         (print refNameNew)
  126.                                                         (if (findfile refNameNew)
  127.                                                                 (progn
  128.                                                                         (vl-cmdf "-xRef" "P" refBlkName refNameNew)
  129.                                                                         (princ (strcat "\n " refBlkName " 修改了"))
  130.                                                                         (princ)
  131.                                                                 )
  132.                                                         );end_if
  133.                                                 );end_progn
  134.                                         )
  135.                                 )
  136.                         )
  137.                 );end_if
  138.         );end_while
  139.         (princ)
  140. )
回复 支持 反对

使用道具 举报

pxt2001
发表于 2016-4-3 09:30 | 显示全部楼层
最好能提供对话框输入，对话框默认输入为：.\\或者..\\
回复 支持 反对

使用道具 举报

pxt2001
发表于 2016-4-3 09:31 | 显示全部楼层
这个功能不错，得顶起来。
回复 支持 反对

使用道具 举报

773786668
发表于 2016-4-24 01:54 | 显示全部楼层
这个功能不错，得顶起来。
回复 支持 反对

使用道具 举报

wudechao
 楼主| 发表于 2016-6-21 22:57 | 显示全部楼层
本帖最后由 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

评分

参与人数 1金钱 +6 收起 理由
utopio + 6

查看全部评分

回复 支持 反对

使用道具 举报

FireflyButler
发表于 2016-11-4 13:45 | 显示全部楼层
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个版本各有用处，都不错。
回复 支持 反对

使用道具 举报

1234下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码，在未取得本站及作者授权的情况下，不得用于商业用途

GMT+8, 2024-5-17 13:08 , Processed in 0.163248 second(s), 22 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表