(完整路径)改(相对路径)LSP,好像用不了，有大神能完善一下吗？

hdq741116723 · 发表于 2018-1-5 10:54:48

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

本帖最后由 newer 于 2018-1-5 12:19 编辑

;;;;参照图块路径改为“相对路径” 且自动重载XREF ---- 支持子目录

;;;;参照图块路径改为“相对路径” 且自动重载XREF ---- 支持子目录
(defun C:Tools-BLK-XrefPathAutoLoad
(/ ssg xpath i obj enl elist blkdef path n Sub_Path)
(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 m (vl-string-mismatch XPath path 0 0 t)) ;_前面有多少个相同的字符
(setq Sub_Path (substr path (1+ m)))
;获取图块参照路径的子串
(vla-put-path blkdef (strcat ".\\" Sub_Path)) ;_参照图块路径改为“相对路径”
(setq n (1+ n))
)
)
(setq i (1+ i))
)
)
(if (> n 0)
(progn (command "_xref" "r" "*")
(prompt (strcat "\n总共有 \" "
(itoa n)
" \"个参照物体路径改为相对路径."
)
)
)
(princ "\n**** 没有外部参照或外部参照没有加载 ****")
)
(princ)
)

;;;;参照图块路径改为“相对路径” 且 自动重载XREF ---- 支持子目录 
(defun C:Tools-BLK-XrefPathAutoLoad 
       (/ ssg xpath i obj enl elist blkdef path n Sub_Path) 
  (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 m (vl-string-mismatch XPath path 0 0 t)) ;_前面有多少个相同的字符 
               (setq Sub_Path (substr path (1+ m))) 
                                        ;获取图块参照路径的子串 
               (vla-put-path blkdef (strcat ".\\" Sub_Path)) ;_参照图块路径改为“相对路径” 
               (setq n (1+ n)) 
        ) 
      ) 
      (setq i (1+ i)) 
    ) 
  ) 
  (if (> n 0) 
    (progn (command "_xref" "r" "*") 
           (prompt (strcat "\n总共有 \" " 
                           (itoa n) 
                           " \"个参照物体路径改为相对路径." 
                   ) 
           ) 
    ) 
    (princ "\n**** 没有外部参照 或 外部参照没有加载 ****") 
  ) 
  (princ) 
)

hdq741116723 · 发表于 2018-1-5 10:59:10

本帖最后由 newer 于 2018-1-5 12:21 编辑

;这几天修改别人的图,被参照图的绝对路径搞的很烦,一怒之下,写了一个改参照绝对路径为相对路径的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 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) 
)

newer · 发表于 2018-1-5 12:18:08

有问题，直接把遇到的情况描述清楚，比如哪里出错了，应该是什么等等。你认为效率不高，是哪里不高，有什么改进的想法？

http://bbs.xdcad.net/thread-714124-1-1.html

newer · 发表于 2018-1-5 12:21:58

另外，代码格式化后，请用论坛贴代码的方法贴源代码。

shuaier · 发表于 2018-1-5 16:04:08

适合参照块的还是参照图片的？论坛上好像有参照块的，没有参照图片的

hdq741116723 · 发表于 2018-1-5 16:45:23

shuaier 发表于 2018-1-5 16:04

论坛的是要安装晓东工具箱

sicky111 · 发表于 2018-1-6 00:04:04

晓东工具箱太强大了。

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

[每日一码] (完整路径)改(相对路径)LSP,好像用不了，有大神能完善一下吗？

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。