; 重新定义外部图片文件引用路径[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))
	(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 slash )
	(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)
