| |
Translate to: |
|||||
| Обратная связь | Новости САПР | Программы | Документация | Полезные советы | Обзорные статьи | ||
| Заказ и разработка | Каталог САПР | САПР-конференция | Библиотека ГОСТов | Наши соавторы | Коммерческое ПО | ||
;; XRP2004.lsp
;; V3.3
;; Эта подпрограмма ищет таблицы блоков и внешние ссылки, а затем
;; обновляет пути всех внешних ссылок (если необходимо) на короткие "относительные пути",
;; чту улучшает переносимоть чертежного файла. Подпрограмма обрезает ненужную ссылку на
;; букву диска и лишний путь к уровню верхний директории, используя вместо этого
;; старую команду DOS CHDIR или синтаксис "CD ..\.." .
;***Новое определение ошибки
;-----------------------
(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) ;сбросить предыдущее определение ошибки
(princ "\nКоманда отменена!")
(prompt "\n ")
(princ)
)
;1 просмотреть список блоков, найти все внешние ссылки и пересчитать их
;---------------------------------------------------------------------
(defun ifxref (/ flag)
(setq cnt nil cnttot nil)
(prompt "\n ")
(princ "\n")
;(princ "\nXRP - XREF Relative Path Utility")
(if (null (setq blkdat (tblnext "block" T)))
(princ "\n 0 внешних ссылки в этом чертеже.")
)
(if (null (setq image_ss (ssget "X" '((0 . "IMAGE")))))
(princ "\n 0 изображений в этом чертеже.")
)
(if blkdat
(progn
(setq blkdat 1 cnt 0 flag 0)
(while blkdat
(if (= flag 0) (setq blkdat (tblnext "block" T))
(setq blkdat (tblnext "block"))
)
(setq flag 1)
(if blkdat (if (member (cdr (assoc 70 blkdat)) '(4 12 36 44))
(setq cnt (1+ cnt))))
)
)
)
(if (= cnt 0)
(princ "\n 0 внешних ссылки в этом чертеже!")
(if cnt
(progn
(princ (strcat "\n " (itoa cnt) " внешних ссылки в этом чертеже."))
)
)
)
(if image_ss
(progn
(setq flag 0)
(princ (strcat "\n " (itoa (sslength image_ss)) " изображений в этом чертеже (некоторые могут повторяться)."))
)
)
(if (>= cnt 1) (setq cnttot cnt))
(if image_ss (setq imagetot (sslength image_ss)))
;;(princ "\n Нажмите любую клавишу для продолжения.")
;;(grread)
(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
(if (= flag 0) (setq blkdat (tblnext "block" T))
(setq blkdat (tblnext "block"))
)
(setq flag 1)
(if blkdat
(if (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
(if (= flag 0) (setq blkdat (tblnext "block" T))
(setq blkdat (tblnext "block"))
)
(setq flag 1 dpath (getvar "dwgprefix"))
(if blkdat
(if (member (cdr (assoc 70 blkdat)) '(4 12))
(progn
(setq xpath (strcase (cdr (assoc 1 blkdat)))
xnam (realxnam)
xnam2 (strcase (cdr (assoc 2 blkdat)))
)
(princ (strcat "\nXref " XNAM2 (pad) " **нет загруженных, ПУТЬ НЕ ИЗМЕНЕН"))
)
)
)
(if blkdat
(if (member (cdr (assoc 70 blkdat)) '(36 44))
(progn
(setq xpath (strcase (cdr (assoc 1 blkdat)))
xnam (realxnam)
xnam2 (strcase (cdr (assoc 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 "\nXref " XNAM2 (pad) " **на другом диске, ПУТЬ НЕ ИЗМЕНЕН"))
(setq cntdr (1+ cntdr))
)
(progn
(trpath)
(if (wcmatch xpath "*:*")
(progn
(compath)
(if (member (cdr (assoc 70 blkdat)) '(4 12))
(princ (strcat "\nXref " XNAM2 (pad) " **нет загруженных, ПУТЬ НЕ ИЗМЕНЕН"))
)
(cond ;***condition for lateral path xrefs... the majority
;---------------------------------------------------
((and (> (strlen X1path) 0) (> (strlen d1path) 0))
(progn
(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 "\nXref " XNAM2 (pad) " Путь изменен, соседний каталог"))
(setq cnt (1+ cnt))
)
(progn
(princ (strcat "\nXref " 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))
(progn
(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 "\nXref " XNAM2 (pad) " Путь изменен, над базовым каталогом"))
(setq cnt (1+ cnt))
)
(progn
(princ (strcat "\nXref " 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))
(progn
;(if (or (> (strlen xnam2) 8) (wcmatch xnam2 "* *"))
;(princ (strcat "\nXref " XNAM2 (pad) " **Используются длинные имена, ПУТЬ НЕ ИЗМЕНЕН"))
(progn
(princ (strcat "\nXref " 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))
(progn
(setq x1path (strcat (homepath) (chr 92) x1path))
(setq x1path (strcase (strcat x1path (xnamful)) T))
(if (findfile x1path)
(progn (command "xref" "path" xnam2 x1path)
(princ (strcat "\nXref " XNAM2 (pad) " Путь изменен, ниже базового каталога"))
(setq cnt (1+ cnt))
)
(progn
(princ (strcat "\nXref " 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 "\nXref " 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
;--------------------------------------------------------------
(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)
)
(if (wcmatch (substr x1path 1 1) "\\")
(setq slashcnt 0) (setq slashcnt (1+ slashcnt))
)
)
(setq cnt2 0)
)
)
; (setq zzz x1path)
(if (not (wcmatch (substr x1path 1 1) "\\"))
(progn
(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 (cdr (assoc 340 image_elist1)))
image_elist3 (entget (cdr (assoc 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 <
(progn
(setq xnam2 (strcase (cdr (nth imgcnt image_names)))
xpath (strcase (cdr (assoc 1 (entget (cdr (nth (1+ imgcnt) image_names))))))
image_wholepath xpath
istat (cdr (assoc 280 (entget (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
(if (= istat 0)
(progn
(princ (strcat "\nИзображение " XNAM2 (pad) " **не загружено, ПУТЬ НЕ ИЗМЕНЕН"))
(setq imgnf (1+ imgnf))
)
(progn ;eei
(if (and (/= (substr xpath 1 1) (strcase (substr dpath 1 1)))
(wcmatch xpath "*:*")
)
(progn
(princ (strcat "\nИзображение " XNAM2 (pad) " **на другом диске, ПУТЬ НЕ ИЗМЕНЕН"))
(setq imgdr (1+ imgdr))
(setq xnam nil xnam2 nil)
)
(progn ;xyz
(if (wcmatch xpath "*:*")
(progn ;aai
(compath)
(cond
;***condition for lateral path images...the majority
;---------------------------------------------------
((and (> (strlen X1path) 0) (> (strlen d1path) 0)) ;1st cond
(progn
(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
(progn
(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)
(setq 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))
(progn
;(if (or (> (strlen xnam2) 8) (wcmatch xnam2 "* *"))
;(princ (strcat "\nИзображение " XNAM2 (pad) " **Long filename used, ПУТЬ НЕ ИЗМЕНЕН"))
(progn
(princ (strcat "\nИзображение " XNAM2 (pad) " Repathed, to base directory"))
(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))
(progn
(setq x1path (strcat (homepath) (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)
(setq imgnf (1+ imgnf))
)
)
(setq xnam nil xnam2 nil)
)
)
) ;end Whole COND
) ;end progn aai
(progn ;***else, no drive letter and path is already localized
;------------------------------------------------------
(princ (strcat "\nИзображение " XNAM2 (pad) " *нет необходимости изменять путь*"))
(setq imgok (1+ imgok))
)
) ;end if wcmatch
) ;end progn xyz
;=======
);end if
) ;end progn eei
) ;end if istat
(setq imgcnt (+ 2 imgcnt))
) ;end progn
) ;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 ( )
(setq sca "scale" orgerr *error* *error* xrperr v# "v3")
(if (or (wcmatch (getvar "acadver") "*14*")(wcmatch (getvar "acadver") "*15*")
(wcmatch (getvar "acadver") "*16*")(wcmatch (getvar "acadver") "*17*")
(wcmatch (getvar "acadver") "*18*")
)
(progn
(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 "\nHit any key")
;;(grread)
(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)
)
)
)
(alert "Эта версия XRP разработана только для AutoCAD R14 - 2010")
)
(setq *error* orgerr orgerr nil)
(princ)
)
(defun xrp_report ()
(if (>= cnt 1) ;***Если внешние ссылки существуют, сообщить результат изменения путей
(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 ")
;(setq image_ss nil #images nil imgok nil imgdr nil imgnf nil)
)
)
)
(defun c:xrp () (xrp))
; Удалите вызов функции ниже, если вы хотите, чтобы она не вызывалась автоматически при загрузке чертежа
;(xrp)
(princ)
Copyright © Сайт поддержки пользователей САПР