; 重新定义外部图片文件引用路径[WG_XrefRepath].lsp


;;  XRP2004.lsp              by Mark McDonough
;;  V3.3                   Oct.15, 1999
;;  Updated as XRP2004.lsp by Mark McDonough, 4/20/04


;;  Rev.1 05/03/99 updated to work for renamed XREFs and for AK2
;;  Rev.2 10/10/99 updated to work for Image paths
;;  Rev 3 04/20/04 updated to remove restrictions on long filenames
;;  Rev 4 12/14/06 updated to allow loading in running in AutoCAD 2007 (although it's not been tested in 2007)
;;  Rev 5 12/06/08 updated by Jimmy Bergmark
;;                 updated to allow running in AutoCAD 2010
;;                 updated to be possible to run without user interaction

;;  This lisp utility searches the block table, finds all Xrefs, then 
;;  repaths the Xrefs (if needed) with shorter "relative paths", thus 
;;  enhancing drawing file portability.  The program strips unneeded
;;  drive letter references and superfluous upper level directory path
;;  information, using instead the old DOS CHDIR or "CD ..\.." syntax.

;;  This program is supplied "AS IS".  The author specifically disclaims 
;;  all warranties, expressed or implied, regarding the merchantability
;;  or fitness for any purpose. The author does not warrant that the
;;  XRP program will be free of errors and assumes no liability for 
;;  damages, direct or consequentail, which may result from the use of 
;;  XRP.

;-------------------------
(defun c:wg_xrefrepath ( /  xrperr ce v_r r_a ifxref cnt cnttot blkdat image_ss ifnf repath flag xnam cnt6 cntnf cntdr
                    dpath x1path pad XNAM2 homepath rchr temp xpath realxnam trpath compath d1path slashcnt
                    cntsteps xnamful
                    imgcnt imgok imgnf imgdr #images image_elist1 image_elist2 image_elist3 image_names
                    image_wholepath istat
                    image_repath img_path x y x2 xrp orgerr sca v# xrp_report
 ) 
;***new error definition
;-----------------------
(defun xrperr (msg)
   (if ce  (setvar "cmdecho" ce))
   (if v_r (setvar "visretain" v_r))
   (if r_a (setvar "regenmode" r_a))
   (setq *error* orgerr)   ;reset previous error def.
   (princ "\n命令终止!")
   (prompt "\n ")
   (princ)
)

;1 loop through block list, see if any regular xrefs, if so count them
;---------------------------------------------------------------------
(defun ifxref (/ flag)
  (setq cnt nil cnttot nil)
  (prompt "\n ")
  (princ "\n")
  (or (setq blkdat (tblnext "block" T))
      (princ "\n 图中没外部引用.")
  )
  (or (setq image_ss (ssget "X" '((0 . "IMAGE"))))
      (princ "\n 图中没图片.")
  )

  (if blkdat
    (progn
      (setq blkdat 1 cnt 0 flag 0)
      (while blkdat
        (setq blkdat (tblnext "block" (= flag 0))
              flag 1
        )
        (and blkdat
             (member (mai_dxf 70 blkdat) '(4 12 36 44))
             (setq cnt (1+ cnt))
        )
      )
    )
  )
  (if (and cnt (> cnt 0))
      (princ (strcat "\n 图中有【" (itoa cnt) "】个外部引用."))
      (princ "\n 图中没外部引用!")
  )
  (if image_ss
      (progn 
        (setq flag 0)
        (princ (strcat "\n 图中有【" (itoa (sslength image_ss)) "】个图片实体."))
      )
  )
  (if (> cnt 0) (setq cnttot cnt))
  (if image_ss (setq imagetot (sslength image_ss)))
  (princ)
)

;the following function is called by the "repath" function, used for the
;summary message to indicate how many XREFs cannot be found (counts XREFs
;that are still attached but can't be found because someone has moved or 
;renamed the XREF drawings.
;---------------------------------------------------------------------------
(defun ifnf ( / flag )
   (setq blkdat 1 flag 0)
   (while blkdat
      (setq blkdat (tblnext "block" (= flag 0))
            flag 1
      )
      (and blkdat 
           (member (cdr (assoc 70 blkdat)) '(4 12))
           (setq cntnf (1+ cntnf))
      )
   )
)

;Step through block list, if item is an xref, determine its position 
;relative to base drawing and then repath it.
;------------------------------------------------------------------------
(defun repath ()
   (setq blkdat 1 flag 0 xnam nil cnt 0 cnt6 0 cntnf 0 cntdr 0)
   (while blkdat
     (setq blkdat (tblnext "block" (= flag 0))
           flag 1
           dpath (getvar "dwgprefix")
     )
     (and blkdat 
          (member (mai_dxf 70 blkdat) '(4 12))
          (progn
               (setq xpath (strcase (mai_dxf 1 blkdat))
                     xnam  (realxnam)
                     xnam2 (strcase (mai_dxf 2 blkdat))
               )
               (princ (strcat "\n外部引用【  " XNAM2 (pad) "】当前没有加载, 不能修改路径。"))
          )
     )
     (and blkdat 
         (member (mai_dxf 70 blkdat) '(36 44))
         (progn
           (setq xpath (strcase (mai_dxf 1 blkdat))
                 xnam  (realxnam)
                 xnam2 (strcase (mai_dxf 2 blkdat))

               ;;important revision
               ;;XNAM  = real XREF dwg name, stripped from ASSOC 1 fullname, w/o ".dwg"
               ;;      = external XREF name
               ;;XNAM2 = XREF name grabed from ASSOC 2 (always has no ".dwg" extension)
               ;;      = internal XREF name (used for reporting to screen)
               ;;This revision accounts for renamed XREFs!
           )
           (if (and (/= (substr xpath 1 1) (strcase (substr dpath 1 1)))
                    (wcmatch xpath "*:*")
               )
               (progn
                   (princ (strcat "\n外部引用【" XNAM2 (pad) "】在不同的驱动器, 不能修改路径。"))
                   (setq cntdr (1+ cntdr))
               )
               (progn
                   (trpath)
                   (if (wcmatch xpath "*:*")
                       (progn
                           (compath)
                           (if (member (mai_dxf 70 blkdat) '(4 12))
                               (princ (strcat "\n外部引用【" XNAM2 (pad) "】当前没有加载, 不能修改路径。"))
                           )
                           (cond ((and (> (strlen X1path) 0) (> (strlen d1path) 0))
                                  (repeat (cntsteps d1path)
                                     (setq x1path (strcat ".." (chr 92) x1path))
                                  )
                                  (setq x1path (strcase (strcat x1path (xnamful)) T))
                                  (if (findfile x1path) 
                                      (progn
                                          (command "_.xref" "path" xnam2 x1path)
                                          (princ (strcat "\n外部引用【" XNAM2 (pad) "】修改为同文件夹下路径。"))
                                          (setq cnt (1+ cnt))
                                      )
                                      (progn
                                          (princ (strcat "\n外部引用【" XNAM2 (pad) "】当前没有找到, 不能修改路径。"))
                                          (setq cntnf (1+ cntnf))
                                      )
                                  )
                                  (setq xnam nil xnam2 nil)
                                 )
                                  ;***condition for xrefs directly above main drawing
                                  ;--------------------------------------------------
                                 ((and (= (strlen X1path) 0) (> (strlen d1path) 0))
                                  (repeat (cntsteps d1path)
                                     (setq x1path (strcat ".." (chr 92) x1path))
                                  )
                                  (setq x1path (strcase (strcat x1path (xnamful)) T))
                                  (if (findfile x1path) 
                                      (progn
                                          (command "_.xref" "path" xnam2 x1path)
                                          (princ (strcat "\n外部引用【" XNAM2 (pad) "】修改为上一级文件夹之上路径。"))
                                          (setq cnt (1+ cnt))
                                      )
                                      (progn
                                          (princ (strcat "\n外部引用【" XNAM2 (pad) "】当前没有找到, 不能修改路径。"))
                                          (setq cntnf (1+ cntnf))
                                      )
                                  )
                                  (setq xnam nil xnam2 nil)
                                 )
                                ;***condition for xrefs at same level as main drawing
                                ;----------------------------------------------------
                                 ((and (= (strlen X1path) 0) (= (strlen d1path) 0))
                                  (princ (strcat "\n外部引用【" XNAM2 (pad) "】修改为上一级文件夹路径。"))
                                  (command "_.xref" "path" xnam2 (xnamful))
                                  (setq xnam nil xnam2 nil cnt (1+ cnt))
                                 )    
                                ;***condition for xrefs below main drawing level
                                ;-----------------------------------------------
                                 ((and (> (strlen X1path) 0) (= (strlen d1path) 0))
                                  (setq x1path (strcat (homepath) (chr 92) x1path)
                                        x1path (strcase (strcat x1path (xnamful)) T)
                                  )
                                  (if (findfile x1path) 
                                      (progn
                                          (command "_.xref" "path" xnam2 x1path)
                                          (princ (strcat "\n外部引用【" XNAM2 (pad) "】修改为上一级文件夹下面的路径。"))
                                          (setq cnt (1+ cnt))
                                      )
                                      (progn
                                          (princ (strcat "\n外部引用【" XNAM2 (pad) "】当前没有找到, 不能修改路径。"))
                                          (setq cntnf (1+ cntnf))
                                      )
                                  )
                                  (setq xnam nil xnam2 nil) 
                                 )
                            );end cond
                        )  ;end progn
                        (progn  ;***else, no drive letter and path is already localized
                              ;------------------------------------------------------
                            (princ (strcat "\n外部引用【" XNAM2 (pad) "】不需要重新修改路径。"))
                            (setq cnt6 (1+ cnt6))
                        )
                    ) ;end if wcmatch xpath *.*
                )
            )
         );end progn
     )
   )
)

;***This function lines up Xref path messages... just for looks
;   Numeric value can be increased to accomodate longer names
;--------------------------------------------------------------
;(pad)
(defun pad ( / spacer )
  (setq spacer " ")
  (if (< (strlen XNAM2) 24) 
      (repeat (- 24 (strlen XNAM2)) (setq spacer (strcat " " spacer)))
  )
  (eval spacer)
)

;***Chops path off of DWGPREFIX, isolating name of single base subdirectory
;--------------------------------------------------------------------------
(defun homepath ( / cnt4)
  (setq rchr nil cnt4 (strlen dpath))
  (if (= (substr dpath cnt4 1) "\\") 
      (setq dpath (substr dpath 1 (- (strlen dpath) 1)) cnt4 (1- cnt4))
  )
  (while cnt4
     (setq rchr (substr dpath cnt4 1))
     (if (= rchr "\\") 
         (setq dpath (strcat ".." (substr dpath cnt4)) cnt4 nil)
         (setq cnt4 (1- cnt4))
     )
  )
  (eval dpath)
)

;***Gets real (external) XREF name by parsing ASSOC 1 of the  
;   full xref pathname, (w/o the ".dwg" extension) = XNAM2
;-----------------------------------------------------------
(defun realxnam ( / cnt5)
  (setq rchr nil temp xpath cnt5 (strlen xpath))
  (if (wcmatch temp "*\\*")
       (while cnt5
             (setq rchr (substr temp cnt5 1))
             (if (= rchr "\\") 
                 (setq temp (strcat (substr temp (1+ cnt5))) cnt5 nil)
                 (setq cnt5 (1- cnt5))
             )
       )
  )
  (if (wcmatch (strcase temp) "*.DWG")
      (setq temp (substr temp 1 (- (strlen temp) 4)))
  )
  (eval temp)
)


;***Trims xref path by removing xref drawing name
;   This function is a necessary test in R12 & R13
;-------------------------------------------------
(defun trpath ()
  (if (wcmatch (strcase xpath) "*.DWG")
      (setq xpath (substr xpath 1 (- (strlen xpath) 4)))
  )
  (setq xpath (substr xpath 1 (- (strlen xpath) (strlen xnam))))
)

;***Important function to determine xref's position relative to main dwg,
;   chops off path common to xref & base dwg, leaving unique path remainder.
;   The symbol "slashcnt" is used to backtrack the path, to ensure the common
;   path is a whole path that's truncated at a path delimitor, not at a 
;   similar named directory.
;   ----------------------------------------------------------------------
(defun compath (/ cnt2)
   (setq d1path (strcase (substr dpath 3))
         x1path (strcase (substr xpath 3))
         cnt2   (strlen d1path)
         slashcnt 0
   )
   (while (/= cnt2 0)
     (if (= (substr d1path 1 1) (substr x1path 1 1))
         (progn
             (setq d1path (substr d1path 2)
                   x1path (substr x1path 2)
             )
             (if (or (= (strlen d1path) 0) (= (strlen x1path) 0))
                 (setq cnt2 0)
             )
             (setq slashcnt (if (wcmatch (substr x1path 1 1) "\\") 0 (1+ slashcnt)))
         )
         (setq cnt2 0)
     )
   )
 ; (setq zzz x1path)
   (or (wcmatch (substr x1path 1 1) "\\")
       (setq x1path (strcat (substr xpath (- (strlen xpath) (+ slashcnt (- (strlen x1path)2))) (1- slashcnt)) x1path))
   )
)

;***Counts # of backslashes in remainder path, thus determining 
;   number of steps to apply DOS CD ..\ syntax
;   -----------------------------------------------------------
(defun cntsteps ( x / cnt3 )
   (setq cnt3 0 slash 0 rchr nil)
   (while (/= cnt3 (strlen x))
      (setq cnt3 (1+ cnt3) rchr (substr x cnt3 1))
      (if (= rchr "\\") (setq slash (1+ slash)))
   )
   (eval slash)
)

;***Ensures repathed xref has a ".dwg" extension, for consistency
;   -------------------------------------------------------------
(defun xnamful ()
   (if (not (wcmatch XNAM "*.dwg"))
       (strcase (strcat XNAM ".dwg") T)
   )
)


;Step through IMAGE selection set, determine its position 
;relative to base drawing and then repath it.
;------------------------------------------------------------------------

(defun image_repath ()
  (setq flag 0 xnam nil imgcnt 0 imgok 0 imgnf 0 imgdr 0 #images 0
        image_elist1 (entget (ssname image_ss 0))
        image_elist2 (entget (mai_dxf 340 image_elist1))
        image_elist3 (entget (mai_dxf 330 image_elist2))
        image_names  (member (assoc 3 image_elist3) image_elist3)
        dpath        (getvar "dwgprefix")
  )
  (while (/= imgcnt (length image_names)) ;maybe should be less than  <
      (setq xnam2 (strcase (cdr (nth imgcnt image_names)))
            xpath (strcase (mai_dxf 1 (cdr (nth (1+ imgcnt) image_names))))
            image_wholepath xpath
            istat (mai_dxf 280 (cdr (nth (1+ imgcnt) image_names)))
      )                  ;if istat = 0, not loaded
                  ;XNAM gets set via the (img_path) function below
      (img_path)  ;delivers xnam, and modified xpath
      (setq imgcnt (+ 2 imgcnt))
      (cond
            ((= istat 0)
             (princ (strcat "\n图片文件【" XNAM2 (pad) "】没有被加载, 不能修改路径。"))
             (setq imgnf (1+ imgnf))
            )
          
            ((and (/= (substr xpath 1 1) (strcase (substr dpath 1 1)))
                  (wcmatch xpath "*:*")
             )
             (princ (strcat "\n图片文件【" XNAM2 (pad) "】在不同的驱动器, 不能修改路径。"))
             (setq imgdr (1+ imgdr) xnam nil xnam2 nil)
            )
               
            ((wcmatch xpath "*:*")
             (compath)
             (cond ;***condition for lateral path images...the majority
                  ((and (> (strlen X1path) 0) (> (strlen d1path) 0)) ;1st cond
                   (repeat (cntsteps d1path)
                       (setq x1path (strcat ".." (chr 92) x1path))
                   )
                   (setq x1path (strcase (strcat x1path xnam)))
                   (if (findfile x1path) 
                       (progn
                           (princ (strcat "\n图片文件【" XNAM2 (pad) "】修改为同文件夹下路径。"))
                           (command "_.image" "path" XNAM2 x1path)
                           (setq #images (1+ #images))
                       )
                       (progn
                           (princ (strcat "\n图片文件【" XNAM2 (pad) "】当前没有找到, 不能修改路径。"))
                           (setq imgnf (1+ imgnf))
                       )
                   )
                   (setq xnam nil xnam2 nil)
                  ) ;end 1st COND
                        ;***condition for images directly above main drawing
                        ;---------------------------------------------------
                  ((and (= (strlen X1path) 0) (> (strlen d1path) 0));2nd cond
                   (repeat (cntsteps d1path)
                       (setq x1path (strcat ".." (chr 92) x1path))
                   )
                   (setq x1path (strcase (strcat x1path xnam)))
                   (if (findfile x1path) 
                       (progn
                          (princ (strcat "\n图片文件【" XNAM2 (pad) "】修改为上一级文件夹之上路径。"))
                          (command "_.image" "path" xnam2 x1path)
                          (setq #images (1+ #images))
                       )
                       (progn
                          (princ (strcat "\n图片文件【" XNAM2 (pad) "】当前没有找到, 不能修改路径。"))
                          (setq x xnam y xpath x2 xnam2 imgnf (1+ imgnf))
                       )
                   )
                   (setq xnam nil xnam2 nil)
                  );end 2nd cond
                        ;***condition for images at same level as main drawing
                        ;-----------------------------------------------------
                  ((and (= (strlen X1path) 0) (= (strlen d1path) 0))
                     (princ (strcat "\n图片文件【" XNAM2 (pad) "】修改为上一级文件夹路径。"))
                     (command "_.image" "path" xnam2 xnam)
                     (setq xnam nil xnam2 nil #images (1+ #images))
                  )
                        ;***condition for images below main drawing level
                        ;------------------------------------------------
                  ((and (> (strlen X1path) 0) (= (strlen d1path) 0))
                   (setq x1path (strcat (homepath) (chr 92) x1path)
                         x1path (strcase (strcat x1path xnam))
                   )
                   (if (findfile x1path) 
                        (progn
                           (princ (strcat "\n图片文件【" XNAM2 (pad) "】修改为上一级文件夹下面的路径。"))
                           (command "_.image" "path" xnam2 x1path)
                           (setq #images (1+ #images))
                        )
                        (progn
                           (princ (strcat "\n图片文件【" XNAM2 (pad) "】当前没有找到, 不能修改路径。"))
                           (setq x xnam y xpath x2 xnam2 imgnf (1+ imgnf))
                        )
                    )
                    (setq xnam nil xnam2 nil) 
                   )
             )   ;end Whole COND
             
            )
                 
            (T  ;***else, no drive letter and path is already localized
                         ;------------------------------------------------------
              (princ (strcat "\n图片文件【" XNAM2 (pad) "】不需要重新修改路径。"))
              (setq imgok (1+ imgok))
            )
      )     ;end Whole  cond
      
  )          ;end while
)          ;end defun

(defun img_path ( / imgcnt2)
  (setq rchr nil imgcnt2  (strlen xpath))
  (if (= (substr xpath imgcnt2 1) "\\") 
      (setq xpath (substr xpath 1 (- (strlen xpath) 1)) imgcnt2 (1- imgcnt2))
  )  ;this will probably never be used
  (while (> imgcnt2 0)
     (setq rchr (substr xpath imgcnt2 1))
     (if (= rchr "\\") 
        (setq xnam (strcase (substr xpath (1+ imgcnt2)))
              ;img_pathnam (strcat (strcase (substr xpath 1 (1- imgcnt2))) "\\")
              xpath (strcase (substr xpath 1 imgcnt2))
              imgcnt2 nil)
        (setq imgcnt2 (1- imgcnt2))
     )
  )
)




(defun xrp_report ()
   (if (>= cnt 1)   ;***If xrefs exist, report status of repath operations
     (progn
       (prompt "\n ")
       (princ (strcat "\n共【"  (if (< cnttot 10) " " "") (itoa cnttot) "】个外部引用"))
       (princ (strcat "\n-" (if (< cnt 10) "-" "") "-------------"))
       (princ (strcat "\n共【"  (if (< cnt 10) " " "") (itoa cnt) "】个外部引用被重新定义路径"))
       (if (>= cnt6 1) 
           (princ (strcat "\n共【" (if (< cnt6 10) " " "") (itoa cnt6) "】个外部引用不需要重新定义路径"))
       )
       (ifnf)
       (if (>= cntdr 1)
           (princ (strcat "\n共【" (if (< cntdr 10) " " "") (itoa cntdr) "】个外部引用在其它驱动器，无法重新定义路径"))
       )
       (if (>= cntnf 1)
           (princ (strcat "\n共【" (if (< cntnf 10) " " "") (itoa cntnf) "】个外部引用没有被找到，无法重新定义路径"))
       )
       (prompt "\n ")
       (setq cnttot nil cnt6 nil cntdr nil cntnf nil)
     )
   )
   (if (> #images 0)
     (progn
       (prompt "\n ")
       (princ (strcat "\n共【"  (if (< (/ (length image_names) 2) 10) " " "") (itoa (/ (length image_names) 2)) "】个不同的图片文件"))
       (princ (strcat "\n-" (if (< #images 10) "-" "") "-----------------------"))
       (princ (strcat "\n共【"  (if (< #images 10) " " "") (itoa #images) "】个图片文件被重新定义路径"))
       (if (>= imgok 1) 
           (princ (strcat "\n共【" (if (< imgok 10) " " "") (itoa imgok) "】个图片文件不需要被重新定义路径"))
       )
       (if (>= imgdr 1)
           (princ (strcat "\n共【" (if (< imgdr 10) " " "") (itoa imgdr) "】个图片文件在其它驱动器，无法重新定义路径"))
       )
       (if (>= imgnf 1)
           (princ (strcat "\n共【" (if (< imgnf 10) " " "") (itoa imgnf) "】个图片文件没有被找到，无法重新定义路径"))
       )
       (prompt "\n ")
     )
   )
)

;Main xref repath function
   (setq sca "scale" orgerr *error* *error* xrperr v# "v3")  
   (ifxref)
   (if (or image_ss (> cnt 0))
       (progn
         (setq ce (getvar "cmdecho"))
         (setvar "cmdecho" 0)
         (setq r_a (getvar "regenmode"))
         (setq v_r (getvar "visretain"))
         (setvar "regenmode" 0)
         (setvar "visretain" 1)
         (repath)
         (if image_ss (image_repath))
         (if (>= cnt 1) (command "regen"))
         (setvar "regenmode" r_a)
         ;;(textscr)
         (xrp_report)
         (princ "\n ")
         (princ "\n ")
         (princ "\r           ")
         ;;(graphscr)
         (if v_r (setvar "visretain" v_r))
         (if ce  (setvar "cmdecho" ce))
         (setq v_r nil ce nil cnt nil r_a nil flag nil rchr nil)
       )
     )
  (setq *error* orgerr orgerr nil)
  (princ)
)

(princ)